package SAP::Iface; use strict; use vars qw($VERSION $AUTOLOAD); use constant RFCIMPORT => 0; use constant RFCEXPORT => 1; use constant RFCTABLE => 2; use constant RFCTYPE_CHAR => 0; use constant RFCTYPE_DATE => 1; use constant RFCTYPE_BCD => 2; use constant RFCTYPE_TIME => 3; use constant RFCTYPE_BYTE => 4; use constant RFCTYPE_NUM => 6; use constant RFCTYPE_FLOAT => 7; use constant RFCTYPE_INT => 8; use constant RFCTYPE_INT2 => 9; use constant RFCTYPE_INT1 => 10; # Globals # Valid parameters my $IFACE_VALID = { NAME => 1, PARAMETERS => 1, TABLES => 1, EXCEPTIONS => 1 }; $VERSION = '1.04'; # empty destroy method to stop capture by autoload sub DESTROY { } sub AUTOLOAD { my $self = shift; my @parms = @_; my $type = ref($self) or die "$self is not an Object in autoload of Iface"; my $name = $AUTOLOAD; $name =~ s/.*://; # Autoload constants if ( uc($name) eq 'RFCEXPORT' ) { return RFCEXPORT; } elsif ( uc($name) eq 'RFCIMPORT' ) { return RFCIMPORT; } elsif ( uc($name) eq 'RFCTABLE' ) { return RFCTABLE; } elsif ( uc($name) eq 'RFCTYPE_CHAR' ) { return RFCTYPE_CHAR; } elsif ( uc($name) eq 'RFCTYPE_BYTE' ) { return RFCTYPE_BYTE; } elsif ( uc($name) eq 'RFCTYPE_DATE' ) { return RFCTYPE_DATE; } elsif ( uc($name) eq 'RFCTYPE_TIME' ) { return RFCTYPE_TIME; } elsif ( uc($name) eq 'RFCTYPE_BCD' ) { return RFCTYPE_BCD; } elsif ( uc($name) eq 'RFCTYPE_NUM' ) { return RFCTYPE_NUM; } elsif ( uc($name) eq 'RFCTYPE_FLOAT' ) { return RFCTYPE_FLOAT; } elsif ( uc($name) eq 'RFCTYPE_INT' ) { return RFCTYPE_INT; } elsif ( uc($name) eq 'RFCTYPE_INT2' ) { return RFCTYPE_INT2; } elsif ( uc($name) eq 'RFCTYPE_INT1' ) { return RFCTYPE_INT1; # Autoload parameters and tables } elsif ( exists $self->{PARAMETERS}->{uc($name)} ) { &parm($self, $name)->value( @_ ); } elsif ( exists $self->{TABLES}->{uc($name)} ) { &tab($self, $name)->rows( @_ ); } else { die "Parameter $name does not exist in Interface - no autoload"; }; } # Construct a new SAP::Iface object sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = { PARAMETERS => {}, TABLES => {}, EXCEPTIONS => {}, @_ }; die "No RFC Name supplied to Interface !" if ! exists $self->{NAME}; # Validate parameters map { delete $self->{$_} if ! exists $IFACE_VALID->{$_} } keys %{$self}; $self->{NAME} = $self->{NAME}; # create the object and return it bless ($self, $class); return $self; } # get the name sub name { my $self = shift; return $self->{NAME}; } # Add an export parameter Object sub addParm { my $self = shift; die "No parameter supplied to Interface !" if ! @_; my $parm; if (my $ref = ref($_[0])){ die "This is not an Parameter for the Interface - $ref ! " if $ref ne "SAP::Parms"; $parm = $_[0]; } else { $parm = SAP::Parms->new( @_ ); }; return $self->{PARAMETERS}->{$parm->name()} = $parm; } # Access the export parameters sub parm { my $self = shift; die "No parameter name supplied for interface" if ! @_; my $parm = uc(shift); die "Parameter $parm Does not exist in interface !" if ! exists $self->{PARAMETERS}->{$parm}; return $self->{PARAMETERS}->{$parm}; } # Return the parameter list sub parms { my $self = shift; return sort { $a->name() cmp $b->name() } values %{$self->{PARAMETERS}}; } # Return the parameter list excluding empty export parameters sub parms_noempty { my $self = shift; return sort { $a->name() cmp $b->name() } grep { ! ($_->type() == RFCEXPORT && ! $_->changed()) }values %{$self->{PARAMETERS}}; } # Add an Table Object sub addTab { my $self = shift; die "No Table supplied for interface !" if ! @_; my $table; if ( my $ref = ref($_[0]) ){ die "This is not a Table for interface: $ref ! " if $ref ne "SAP::Tab"; $table = $_[0]; } else { $table = SAP::Tab->new( @_ ); }; return $self->{TABLES}->{$table->name()} = $table; } # Is this a Table parameter sub isTab { my $self = shift; my $table = uc(shift); return exists $self->{TABLES}->{ $table } ? 1 : undef; } # Access the Tables sub tab { my $self = shift; die "No Table name supplied for interface" if ! @_; my $table = uc(shift); die "Table $table Does not exist in interface !" if ! exists $self->{TABLES}->{ $table }; return $self->{TABLES}->{ $table }; } # Return the Table list sub tabs { my $self = shift; return sort { $a->name() cmp $b->name() } values %{$self->{TABLES}}; } # Empty The contents of all tables in an interface sub emptyTables { my $self = shift; map { $_->empty(); } ( $self->tabs() ); return 1; } # Add an Exception code sub addException { my $self = shift; die "No exception parameter supplied to Interface !" if ! @_; my $exception = uc(shift); return $self->{EXCEPTIONS}->{$exception} = $exception; } # Check Exception Exists sub exception { my $self = shift; die "No Exception parameter name supplied for interface" if ! @_; my $exception = uc(shift); return ( ! exists $self->{EXCEPTIONS}->{ $exception } ) ? $exception : undef; } # Return the Exception parameter list sub exceptions { my $self = shift; return sort keys %{$self->{EXCEPTIONS}}; } # Reset the entire interface sub reset { my $self = shift; # Reset all the tables emptyTables( $self ); # Reset all parameters map { $_->value( $_->default ); } ( parms() ); return 1; } #Generate the Interface hash sub iface{ my $self = shift; my $iface = {}; map { $iface->{$_->name()} = { 'TYPE' => $_->type(), 'INTYPE' => $_->intype(), # 'VALUE' => $_->intvalue(), 'VALUE' => ((($_->intype() == RFCTYPE_BYTE) && $_->type() == RFCEXPORT ) ? pack("A".$_->leng(), $_->intvalue()) : $_->intvalue()), # 'LEN' => ($_->intype() == RFCTYPE_CHAR ? length($_->intvalue()) : $_->leng()) } 'LEN' => ((($_->intype() == RFCTYPE_CHAR) && $_->type() != RFCIMPORT ) ? length($_->intvalue()) : $_->leng()) } } ( $self->parms_noempty() ); map { $iface->{$_->name()} = { 'TYPE' => RFCTABLE, 'INTYPE' => $_->intype(), 'VALUE' => [ ($_->rows()) ], 'LEN' => $_->leng() }; } ( $self->tabs() ); # use Data::Dumper; # warn "This is the IFACE: ".Dumper($iface)."\n"; return $iface; } =head1 NAME SAP::Iface - Perl extension for parsing and creating an Interface Object. The interface object would then be passed to the SAP::Rfc object to carry out the actual call, and return of values. =head1 SYNOPSIS use SAP::Iface; $iface = new SAP::Iface( NAME =>"RFCNAME" ); NAME is mandatory. or more commonly: use SAP::Rfc; $rfc = new SAP::Rfc( ASHOST => ... ); $iface = $rfc->discover('RFC_READ_REPORT'); =head1 DESCRIPTION This class is used to construct a valid interface object ( SAP::Iface.pm ). The constructor requires the parameter value pairs to be passed as hash key values ( see SYNOPSIS ). Generally you would not create one of these manually as it is far easier to use the "discovery" functionality of the SAP::Rfc->discover("RFCNAME") method. This returns a fully formed interface object. This is achieved by using standard RFCs supplied by SAP to look up the definition of an RFC interface and any associated structures. Methods: new use SAP::Iface; $iface = new SAP::Iface( NAME =>"RFC_READ_TABLE" ); Create a new Interface object. $iface->PARM_NAME(' new value ') Parameters and tables are autoloaded methods - than can be accessed like this to set and get their values. $iface->RFCTYPE_CHAR Autoloaded methods are provided for all the constant definitions relating to SAP parameter types. $iface->name() Return the name of an interface. $iface->addParm( TYPE => SAP::Iface->RFCEXPORT, INTYPE => SAP::Iface->RFCTYPE_CHAR, NAME => 'A_NAME', STRUCTURE => $rfc->structure('NAME_OF_STRUCTURE'), DEFAULT => 'the default value', VALUE => 'the current value', DECIMALS => 0, LEN => 20 ); Add an RFC interface parameter to the SAP::Iface definition - see SAP::Parm. $iface->parm('PARM_NAME'); Return a reference to a named parameter object. $iface->parms(); Return a list of parameter objects for an interface. $iface->addTab( INTYPE => SAP::Iface->RFCTYPE_BYTE, NAME => 'NAME_OF_TABLE', STRUCTURE => $rfc->structure('NAME_OF_STRUCTURE'), LEN => 35 ); Add an RFC interface table definition to the SAP::Iface object - see SAP::Tab. $iface->isTab('TAB_NAME'); Returns true if the named parameter is a table. $iface->tab('TAB_NAME'); Return a reference to the named table object - see SAP::Tab. $iface->tabs(); Return a list of table objects for the SAPP::Iface object. $iface->emptyTables(); Empty the contents of all the tables on a SAP::Iface object. $iface->addException('EXCEPTION_NAME'); Add an exception name to the interface. $iface->exception('EXCEPTION_NAME'); Return the named exception name - basically I dont do anything with exceptions yet except keep a list of names that could be checked against an RFC failure return code. $iface->exceptions(); Return a list of exception names associated with a SAP::Iface object. $iface->reset(); Empty all the tables and reset paramters to their default values - useful when you are doing multiple calls. $iface->iface(); An internal method that generates the internal structure passed into the C routines. =cut package SAP::Tab; use strict; use vars qw($VERSION); # Globals use constant RFCIMPORT => 0; use constant RFCEXPORT => 1; use constant RFCTABLE => 2; use constant RFCTYPE_CHAR => 0; use constant RFCTYPE_DATE => 1; use constant RFCTYPE_BCD => 2; use constant RFCTYPE_TIME => 3; use constant RFCTYPE_BYTE => 4; use constant RFCTYPE_NUM => 6; use constant RFCTYPE_FLOAT => 7; use constant RFCTYPE_INT => 8; use constant RFCTYPE_INT2 => 9; use constant RFCTYPE_INT1 => 10; # Valid parameters my $TAB_VALID = { VALUE => 1, NAME => 1, INTYPE => 1, LEN => 1, STRUCTURE => 1 }; # Valid data types my $TAB_VALTYPE = { RFCTYPE_CHAR, RFCTYPE_CHAR, RFCTYPE_BYTE, RFCTYPE_BYTE, RFCTYPE_BCD, RFCTYPE_BCD, RFCTYPE_DATE, RFCTYPE_DATE, RFCTYPE_TIME, RFCTYPE_TIME, RFCTYPE_NUM, RFCTYPE_NUM, RFCTYPE_INT, RFCTYPE_INT, RFCTYPE_INT2, RFCTYPE_INT2, RFCTYPE_INT1, RFCTYPE_INT1, RFCTYPE_FLOAT, RFCTYPE_FLOAT }; # Construct a new SAP::Table object. sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = { VALUE => [], INTYPE => RFCTYPE_BYTE, @_ }; die "Table Name not supplied !" if ! exists $self->{NAME}; die "Table $self->{NAME} Length not supplied !" if ! exists $self->{LEN}; # Validate parameters map { delete $self->{$_} if ! exists $TAB_VALID->{$_} } keys %{$self}; $self->{NAME} = uc($self->{NAME}); # create the object and return it bless ($self, $class); return $self; } # Set/get the table rows - pass a reference to a anon array sub rows { my $self = shift; if (@_){ $self->{'VALUE'} = shift; my @rows = (); my $str = $self->structure(); foreach my $row ( @{$self->{'VALUE'}} ){ if (ref($row) eq 'HASH'){ map { $str->$_($row->{$_}) } keys %{$row}; $row = $str->value; $str->value(""); } push(@rows, $row); } $self->{'VALUE'} = \@rows; } return map{ pack("A".$self->leng(),$_) } (@{$self->{VALUE}}); } # retrieve the rows in hashes based on the field names sub hashRows { my $self = shift; my @rows = (); foreach ( map{ pack("A".$self->leng(),$_) } (@{$self->{VALUE}}) ){ $self->structure->value( $_ ); push ( @rows, { map { $_ => $self->structure->$_() } ( $self->structure->fields ) } ); } return @rows; } # Return the next available row from a table sub nextRow { my $self = shift; my $row = shift @{$self->{VALUE}}; if ( $row ) { $self->structure->value( $row ); return { map {$_ => $self->structure->$_() } ( $self->structure->fields ) }; } else { return undef; } } # Set/get the structure parameter sub structure { my $self = shift; $self->{STRUCTURE} = shift if @_; return $self->{STRUCTURE}; } # add a row sub addRow { my $self = shift; if (@_){ my $row = shift; my $str = $self->structure(); if (ref($row) eq 'HASH'){ map { $str->$_($row->{$_}) } keys %{$row}; $row = $str->value; $str->value(""); } push(@{$self->{VALUE}}, $row); } } # Delete all rows in the table sub empty { my $self = shift; $self->rows( [ ] ); return 1; } # Get the table name sub name { my $self = shift; return $self->{NAME}; } # Set/get the value of type sub intype { my $self = shift; $self->{INTYPE} = shift if @_; die "Table Type not valid $self->{INTYPE} !" if ! exists $TAB_VALTYPE->{$self->{INTYPE}}; return $self->{INTYPE}; } # Set/get the table length sub leng { my $self = shift; $self->{LEN} = shift if @_; return $self->{LEN}; } # Get the number of rows sub rowCount { my $self = shift; # return $#{$self->{VALUE}} + 1; return scalar @{$self->{VALUE}}; } # Autoload methods go after =cut, and are processed by the autosplit program. =head1 NAME SAP::Tab - Perl extension for parsing and creating Tables to be added to an RFC Iface. =head1 SYNOPSIS use SAP::Tab; $tab1 = new SAP::Tab( INTYPE => SAP::Iface->RFCTYPE_BYTE, NAME => 'NAME_OF_TABLE', STRUCTURE => $rfc->structure('NAME_OF_STRUCTURE'), LEN => 35 ); =head1 DESCRIPTION This class is used to construct a valid Table object to be add to an interface object ( SAP::Iface.pm ). The constructor requires the parameter value pairs to be passed as hash key values ( see SYNOPSIS ). Methods: new use SAP::Tab; $tab1 = new SAP::Tab( INTYPE => SAP::Iface->RFCTYPE_BYTE, NAME => 'NAME_OF_TABLE', STRUCTURE => $rfc->structure('NAME_OF_STRUCTURE'), LEN => 35 ); $tab->rows() @r = $tab1->rows( [ row1, row2, row3 .... ] ); optionally set and Give the current rows of a table. or: $tab1->rows( [ { TEXT => "NAME LIKE 'SAPL\%RFC\%'", .... } ] ); pass in a list of hash refs where each hash ref is the key value pairs of the table structures fields ( as per the DDIC ). $tab->addRow() Add a row to the table contents. $tab->hashRows() @r = $tab1->hashRows; This returns an array of hashes representing each row of a table. The hashes are fieldname/value pairs of the row structure. $tab->nextRow() shift the first row off the table contents, and return a hash ref of the field values as per the table structure. $tab->rowCount() $c = $tab1->rowCount(); return the current number of rows in a table object. $tab->empty() empty the row out of the table. $tab->name() get the name of the table object. $tab->intype() Set or get the internal table type. $tab->leng() Set or get the table row length. $tab->structure() Set or get the structure object of the table - see SAP::Struct. =cut package SAP::Parms; use strict; use vars qw($VERSION); # Globals use constant RFCIMPORT => 0; use constant RFCEXPORT => 1; use constant RFCTABLE => 2; use constant RFCTYPE_CHAR => 0; use constant RFCTYPE_DATE => 1; use constant RFCTYPE_BCD => 2; use constant RFCTYPE_TIME => 3; use constant RFCTYPE_BYTE => 4; use constant RFCTYPE_NUM => 6; use constant RFCTYPE_FLOAT => 7; use constant RFCTYPE_INT => 8; use constant RFCTYPE_INT2 => 9; use constant RFCTYPE_INT1 => 10; # Valid parameters my $PARMS_VALID = { NAME => 1, INTYPE => 1, LEN => 1, STRUCTURE => 1, DECIMALS => 1, TYPE => 1, DEFAULT => 1, VALUE => 1, CHANGED => 1 }; # Valid data types my $PARMTYPE = { RFCEXPORT, RFCEXPORT, RFCIMPORT, RFCIMPORT, RFCTABLE, RFCTABLE }; # Valid data types my $PARMS_VALTYPE = { RFCTYPE_CHAR, RFCTYPE_CHAR, RFCTYPE_BYTE, RFCTYPE_BYTE, RFCTYPE_BCD, RFCTYPE_BCD, RFCTYPE_DATE, RFCTYPE_DATE, RFCTYPE_TIME, RFCTYPE_TIME, RFCTYPE_NUM, RFCTYPE_NUM, RFCTYPE_INT, RFCTYPE_INT, RFCTYPE_INT2, RFCTYPE_INT2, RFCTYPE_INT1, RFCTYPE_INT1, RFCTYPE_FLOAT, RFCTYPE_FLOAT }; # Construct a new SAP::Parms parameter object. sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = { INTYPE => RFCTYPE_CHAR, DEFAULT => undef, CHANGED => 0, VALUE => undef, @_ }; die "Parameter TYPE not supplied !" if ! exists $self->{TYPE}; die "Parameter Type not valid $self->{TYPE} !" if ! exists $PARMTYPE->{$self->{TYPE}}; die "Parameter Internal Type not valid $self->{INTYPE} !" if ! exists $PARMS_VALTYPE->{$self->{INTYPE}}; # Validate parameters map { delete $self->{$_} if ! exists $PARMS_VALID->{$_} } keys %{$self}; $self->{NAME} = uc($self->{NAME}); # create the object and return it bless ($self, $class); return $self; } # Set/get the value of type sub type { my $self = shift; $self->{TYPE} = shift if @_; return $self->{TYPE}; } # get the changed flag sub changed { my $self = shift; return $self->{'CHANGED'}; } # Set/get the value of decimals sub decimals { my $self = shift; $self->{DECIMALS} = shift if @_; return $self->{DECIMALS}; } # Set/get the value ofinternal type sub intype { my $self = shift; $self->{INTYPE} = shift if @_; die "Parameter INTYPE not valid $self->{INTYPE} !" if ! exists $PARMS_VALTYPE->{$self->{INTYPE}}; return $self->{INTYPE}; } # Set/get the parameter value sub value { my $self = shift; # print STDERR "setting value: ".$self->name()." to ", @_,"\n"; if (@_){ $self->{'VALUE'} = shift; if (ref($self->{'VALUE'}) eq 'HASH'){ my $str = $self->structure(); map { $str->$_($self->{'VALUE'}->{$_}) } keys %{$self->{'VALUE'}}; $self->{'VALUE'} = $str->value; $str->value(""); } else { $self->{'CHANGED'} = $self->{'VALUE'} eq $self->{'DEFAULT'} ? 0 : 1; } $self->leng(length($self->{'VALUE'})); } # print STDERR " value for: ".$self->name()." is ", $self->{'VALUE'},"\n"; if (my $s = $self->structure ){ $s->value( $self->{'VALUE'} ); my $flds = {}; map { $flds->{$_} = $s->$_() } ( $s->fields ); return $flds; } else { return $self->{'VALUE'}; } } # get the parameter internal value sub intvalue { my $self = shift; $self->{VALUE} = shift if @_; # print STDERR "PARM: ".$self->name() ." type ".$self->intype()." is: ".$self->{'VALUE'}."\n"; # Sort out theinternal format # if ( $self->{VALUE}){ if ( $self->{VALUE} ne ''){ if ( $self->intype() == RFCTYPE_BCD){ return pack("H*", $self->{VALUE}); } elsif ( $self->intype() == RFCTYPE_FLOAT){ return pack("d", $self->{VALUE}); } elsif ( $self->intype() == RFCTYPE_INT){ # return pack("I4", int($self->{VALUE})); return pack("l", int($self->{VALUE})); } elsif ( $self->intype() == RFCTYPE_INT2){ return pack("S", int($self->{VALUE})); } elsif ( $self->intype() == RFCTYPE_INT1){ # get the last byte of the integer return (unpack("A A A A", int($self->{VALUE})))[-1]; } else { # print STDERR " length is: ".$self->leng()." value is: ".$self->{'VALUE'}."\n"; return pack("A".$self->leng(),$self->{VALUE}); }; } else { if ( $self->intype() == RFCTYPE_CHAR ){ # $self->leng( 1 ); return " "; } else { # $self->leng( 0 ); return ""; }; }; } # Set/get the parameter default sub default { my $self = shift; $self->{DEFAULT} = shift if @_; return $self->{DEFAULT}; } # Set/get the parameter structure sub structure { my $self = shift; $self->{STRUCTURE} = shift if @_; return $self->{STRUCTURE}; } # Set/get the parameter length sub leng { my $self = shift; if ( $self->intype() == RFCTYPE_FLOAT){ $self->{LEN} = 8; } elsif ( $self->intype() == RFCTYPE_INT){ $self->{LEN} = 4; } elsif ( $self->intype() == RFCTYPE_INT2){ $self->{LEN} = 2; } elsif ( $self->intype() == RFCTYPE_INT1){ $self->{LEN} = 1; } else { $self->{LEN} = shift if @_; }; return $self->{LEN}; } # get the name sub name { my $self = shift; return $self->{NAME}; } # Below is the stub of documentation for your module. You better edit it! =head1 NAME SAP::Parms - Perl extension for parsing and creating an SAP parameter to be added to an RFC Interface. =head1 SYNOPSIS use SAP::Parms; $imp1 = new SAP::Parms( TYPE => SAP::Iface->RFCEXPORT, INTYPE => SAP::Iface->RFCTYPE_CHAR, NAME => 'A_NAME', STRUCTURE => $rfc->structure('NAME_OF_STRUCTURE'), DEFAULT => 'the default value', VALUE => 'the current value', DECIMALS => 0, LEN => 20 ); =head1 DESCRIPTION This class is used to construct a valid parameter to add to an interface object ( SAP::Iface.pm ). The constructor requires the parameter value pairs to be passed as hash key values ( see SYNOPSIS ). Methods: new use SAP::Parms; $imp1 = new SAP::Parms( TYPE => SAP::Iface->RFCEXPORT, INTYPE => SAP::Iface->RFCTYPE_CHAR, NAME => 'A_NAME', STRUCTURE => $rfc->structure('NAME_OF_STRUCTURE'), DEFAULT => 'the default value', VALUE => 'the current value', DECIMALS => 0, LEN => 20 ); $p->value() $v = $imp1->value( [ val ] ); optionally set and Give the current value. or - pass in a hash ref where the hash ref contains key/value pairs for the fields in the complex parameters structure ( as per the DDIC ). $p->type() $t = $imp1->type( [ type ] ); optionally set and Give the current value of type - this denotes whether this is an export or import parameter. $p->decimals() Set or get the decimals place of the parameter. $p->intype() Set or get the internal type ( as required by librfc ). $p->intvalue() An internal method for translating the value of a parameter into the required native C format. $p->default() Set or get the place holder for the default value of a paramter - in order to reset the value of a parameter to the default you need to $p->value( $p->default ); This is really an internal method that $iface->reset calls on each parameter. $p->structure() Set or get the structure object for a parameter - not all parameters will have an associated structures - only complex ones. See SAP::Struc. $p->leng() Set or get the length attribute of a parameter. $p->name() Get the name of a parameter object. =cut package SAP::Struc; use strict; use vars qw($VERSION $AUTOLOAD); # require AutoLoader; # Globals use constant RFCTYPE_CHAR => 0; use constant RFCTYPE_DATE => 1; use constant RFCTYPE_BCD => 2; use constant RFCTYPE_TIME => 3; use constant RFCTYPE_BYTE => 4; use constant RFCTYPE_NUM => 6; use constant RFCTYPE_FLOAT => 7; use constant RFCTYPE_INT => 8; use constant RFCTYPE_INT2 => 9; use constant RFCTYPE_INT1 => 10; # Valid parameters my $VALID = { NAME => 1, FIELDS => 1 }; # Valid Field parameters my $FIELDVALID = { NAME => 1, INTYPE => 1, DECIMALS => 1, LEN => 1, OFFSET => 1, POSITION => 1, VALUE => 1 }; # Valid data types for fields my $VALCHARTYPE = { C => RFCTYPE_CHAR, X => RFCTYPE_BYTE, B => RFCTYPE_INT1, # This is a place holder for a 1 byte int <=255+ S => RFCTYPE_INT, P => RFCTYPE_BCD, D => RFCTYPE_DATE, T => RFCTYPE_TIME, N => RFCTYPE_NUM, F => RFCTYPE_FLOAT, I => RFCTYPE_INT }; # Valid data types my $VALTYPE = { RFCTYPE_CHAR, RFCTYPE_CHAR, RFCTYPE_BYTE, RFCTYPE_BYTE, RFCTYPE_BCD, RFCTYPE_BCD, RFCTYPE_DATE, RFCTYPE_DATE, RFCTYPE_TIME, RFCTYPE_TIME, RFCTYPE_NUM, RFCTYPE_NUM, RFCTYPE_INT, RFCTYPE_INT, RFCTYPE_FLOAT, RFCTYPE_FLOAT }; # empty destroy method to stop capture by autoload sub DESTROY { } sub AUTOLOAD { my $self = shift; my @parms = @_; my $type = ref($self) or die "$self is not an Object in autoload of Structure"; my $name = $AUTOLOAD; $name =~ s/.*://; unless ( exists $self->{FIELDS}->{uc($name)} ) { die "Field $name does not exist in structure - no autoload"; }; &fieldValue($self,$name,@parms); } # Construct a new SAP::export parameter object. sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = { FIELDS => {}, @_ }; die "Structure Name not supplied !" if ! exists $self->{NAME}; $self->{NAME} = uc($self->{NAME}); # Validate parameters map { delete $self->{$_} if ! exists $VALID->{$_} } keys %{$self}; # create the object and return it bless ($self, $class); return $self; } # Set/get structure field sub addField { my $self = shift; my %field = @_; map { delete $field{$_} if ! exists $FIELDVALID->{$_} } keys %field; die "Structure NAME not supplied!" if ! exists $field{NAME}; $field{NAME} = uc($field{NAME}); $field{NAME} =~ s/\s//g; die "Structure NAME allready exists - $field{NAME}!" if exists $self->{FIELDS}->{$field{NAME}}; $field{INTYPE} =~ s/\s//g; $field{INTYPE} = uc( $field{INTYPE} ); die "Structure INTYPE not supplied!" if ! exists $field{INTYPE}; if ( $field{INTYPE} =~ /[A-Z]/ ){ die "Structure Type not valid $field{INTYPE} !" if ! exists $VALCHARTYPE->{$field{INTYPE}}; $field{INTYPE} = $VALCHARTYPE->{$field{INTYPE}}; } else { die "Structure Type not valid $field{INTYPE} in $self->{NAME} - $field{NAME} - length $field{LEN} !" if ! exists $VALTYPE->{$field{INTYPE}}; }; $field{POSITION} = ( scalar keys %{$self->{FIELDS}} ) + 1; return $self->{FIELDS}->{$field{NAME}} = { map { $_ => $field{$_} } keys %field }; } # Delete a field from the structure sub deleteField { my $self = shift; my $field = shift; die "Structure field does not exist: $field " if ! exists $self->{FIELDS}->{uc($field)}; delete $self->{FIELDS}->{uc($field)}; return $field; } # Set/get the field value and update the overall structure value sub fieldValue { my $self = shift; my $field = shift; $field = ($self->fields)[$field] if $field =~ /^\d+$/; die "Structure field does not exist: $field " if ! exists $self->{FIELDS}->{uc($field)}; $field = $self->{FIELDS}->{uc($field)}; if (scalar @_ > 0){ $field->{VALUE} = shift @_; delete $self->{PACKED} if exists $self->{PACKED}; } return $field->{VALUE}; } # get the field name by position sub fieldName { my $self = shift; my $field = shift; # print "Number: $field \n"; die "Structure field does not exist by array position: $field " if ! ($self->fields)[$field - 1]; return ($self->fields)[$field - 1 ]; } # get the name sub name { my $self = shift; return $self->{NAME}; } # return the current set of field names sub fields { my $self = shift; return sort { $self->{FIELDS}->{$a}->{POSITION} <=> $self->{FIELDS}->{$b}->{POSITION} } keys %{$self->{FIELDS}}; } # Set/get the parameter value sub value { my $self = shift; # an empty value maybe passed if ( scalar @_ > 0 ){ $self->{VALUE} = shift @_ ; _unpack_structure( $self ); } else { _pack_structure( $self ) if ! exists $self->{PACKED}; } return $self->{VALUE}; } # internal routine to pack individual field values back into structure sub _pack_structure { my $self = shift; my @fields = fields($self); my $offset = 0; my @flds = undef; map { my $fld = $self->{FIELDS}->{$fields[$_]}; $fld->{OFFSET} = $offset if ! $fld->{OFFSET} > 0; $offset += int($fld->{LEN}); # Transform various packed dta types if ( $fld->{INTYPE} eq RFCTYPE_INT ){ # Long INT4 # $fld->{VALUE} = pack("I4",$fld->{VALUE}); $fld->{VALUE} ||= 0; $fld->{VALUE} = pack("l",$fld->{VALUE}); } elsif ( $fld->{INTYPE} eq RFCTYPE_INT2 ){ # Short INT2 $fld->{VALUE} ||= 0; $fld->{VALUE} = pack("S",$fld->{VALUE}); } elsif ( $fld->{INTYPE} eq RFCTYPE_INT1 ){ # Short INT1 $fld->{VALUE} = chr( int( $fld->{VALUE} ) ); } elsif ( $fld->{INTYPE} eq RFCTYPE_NUM ){ # NUMC # $fld->{VALUE} = int($fld->{VALUE}); # what if it is num char ? $fld->{VALUE} = "0" unless exists $fld->{VALUE}; if ( $fld->{VALUE} == 0 || $fld->{VALUE} =~ /^[0-9]+$/ ){ $fld->{VALUE} = sprintf("%0".$fld->{LEN}."d", int($fld->{VALUE})); }; # $fld->{VALUE} = int($fld->{VALUE}); } elsif ( $fld->{INTYPE} eq RFCTYPE_DATE ){ # Date $fld->{VALUE} = '00000000' if ! $fld->{VALUE}; } elsif ( $fld->{INTYPE} eq RFCTYPE_TIME ){ # Time $fld->{VALUE} = '000000' if ! $fld->{VALUE}; } elsif ( $fld->{INTYPE} eq RFCTYPE_FLOAT ){ # Float $fld->{VALUE} ||= 0; $fld->{VALUE} = pack("d",$fld->{VALUE}); # } elsif ( $fld->{INTYPE} eq RFCTYPE_BCD and $fld->{VALUE} ){ } elsif ( $fld->{INTYPE} eq RFCTYPE_BCD ){ # All types of BCD $fld->{VALUE} =~ s/^\s+([ -+]\d.*)$/$1/; $fld->{VALUE} ||= 0; #print STDERR "SPRINTF: ".sprintf("%0".int(($fld->{LEN}*2) - 1).".".$fld->{DECIMALS}."f", $fld->{VALUE})."\n"; $fld->{VALUE} = sprintf("%0".int(($fld->{LEN}*2) + 1).".".$fld->{DECIMALS}."f", $fld->{VALUE}); $fld->{VALUE} =~ s/\.//g; #print STDERR "FIELD: ".$self->{NAME}." = ".$fld->{VALUE}."\n"; @flds = split(//, $fld->{VALUE}); shift @flds eq '-' ? push( @flds, 'd'): push( @flds, 'c'); #print STDERR "FIELD: ", $fld->{NAME}, " LEN: ", $fld->{LEN}, " VAL: ", join('', @flds), " DEC: ", $fld->{DECIMALS}, "\n"; $fld->{VALUE} = join('', @flds); #print STDERR "VALUE: ".$fld->{VALUE}."\n"; $fld->{VALUE} = pack("H*",$fld->{VALUE}); #print STDERR "VALUE: ".unpack("H*",$fld->{VALUE})."\n"; } $fld->{VALUE} ||= ""; # print "FIELD: ", $fld->{NAME}, " VAL: ", $fld->{VALUE}, "\n"; } (0..$#fields); # find the length of a row my $lastoff = $self->{FIELDS}->{$fields[$#fields]}->{OFFSET} + $self->{FIELDS}->{$fields[$#fields]}->{LEN}; my $format = ""; map { my $fld = $self->{FIELDS}->{$fields[$_]}; $format = join(" ","A".($lastoff - $fld->{OFFSET}), $format); $lastoff = int($fld->{OFFSET}); } reverse (0..$#fields); #my $format = &_format( $self ); $self->{VALUE} = pack( $format, ( map { $self->{FIELDS}->{$_}->{VALUE} } ( @fields ) ) ); $self->{PACKED} = 1; } # internal routine to unpack field values from the overall structure value sub _unpack_structure { my $self = shift; #my $format = &_format( $self ); #my @fieldvalues = unpack($format, $self->{VALUE}); #print "AFTER AFTER HEX:", unpack("H*", $self->{VALUE}), "\n"; my @fields = $self->fields($self); # print "SELF IS: $self \n"; # map { print "val: $_ \n" } @fields; my $offset = 0; map { my $fld = $self->{FIELDS}->{$fields[$_]}; $offset = int($fld->{OFFSET}) if exists $fld->{OFFSET}; # print "Field: ", $fld->{NAME}, " OFF: $offset TYPE: $fld->{INTYPE} - ROW: ", $self->{VALUE}, "\n"; $fld->{VALUE} = substr($self->{VALUE}, $offset, int($fld->{LEN})); # Transform various packed dta types if ( $fld->{INTYPE} eq RFCTYPE_INT ){ # Long INT4 # $fld->{VALUE} = unpack("I4",$fld->{VALUE}); $fld->{VALUE} = unpack("l",$fld->{VALUE}); } elsif ( $fld->{INTYPE} eq RFCTYPE_INT2 ){ # Short INT2 $fld->{VALUE} = unpack("S",$fld->{VALUE}); } elsif ( $fld->{INTYPE} eq RFCTYPE_INT1 ){ # INT1 $fld->{VALUE} = ord( $fld->{VALUE} ); } elsif ( $fld->{INTYPE} eq RFCTYPE_NUM ){ # NUMC $fld->{VALUE} = int($fld->{VALUE}); } elsif ( $fld->{INTYPE} eq RFCTYPE_FLOAT ){ # Float $fld->{VALUE} = unpack("d",$fld->{VALUE}); } elsif ( $fld->{INTYPE} eq RFCTYPE_BCD and $fld->{VALUE} ){ # All types of BCD my @flds = split(//, unpack("H".$fld->{LEN}*2,$fld->{VALUE})); if ( $flds[$#flds] eq 'd' ){ splice( @flds,0,0,'-'); #} else { # splice( @flds,0,0,'+'); } pop( @flds ); # print "FIELD: ", $fld->{NAME}, " VAL: ", join('', @flds), "DEC: ", $fld->{DECIMALS}, "\n"; splice(@flds,$#flds - ( $fld->{DECIMALS} - 1 ),0,'.') if $fld->{DECIMALS} > 0; $fld->{VALUE} = join('', @flds); } $offset += int($fld->{LEN}) if ! exists $fld->{OFFSET}; } (0..$#fields); } # Below is the stub of documentation for your module. You better edit it! =head1 NAME SAP::Struc - Perl extension for parsing and creating a Structure definition. The resulting structure object is then used for SAP::Parms, and SAP::Tab objects to manipulate complex data elements. =head1 SYNOPSIS use SAP::Struc; $struct = new SAP::Struc( NAME => XYZ, FIELDS => [......] ); =head1 DESCRIPTION This class is used to construct a valid structure object - a structure object that would be used in an Export(Parms), Import(Parms), and Table(Tab) object ( SAP::Iface.pm ). This is normally done through the SAP::Rfc->structure('STRUCT_NAME') method that does an auto look up of the data dictionary definition of a structure. The constructor requires the parameter value pairs to be passed as hash key values ( see SYNOPSIS ). The value of each field can either be accessed through $str->fieldValue(field1), or through the autoloaded method of the field name eg. $str->FIELD1(). Methods: new use SAP::Struc; $str = new SAP::Struc( NAME => XYZ ); addField use SAP::Struc; $str = new SAP::Struc( NAME => XYZ ); $str->addField( NAME => field1, INTYPE => chars ); add a new field into the structure object. The field is given a position counter of the number of the previous number of fields + 1. Name is mandatory, but type will be defaulted to chars if omitted. deleteField use SAP::Struc; $str = new SAP::Struc( NAME => XYZ ); $str->addField( NAME => field1, INTYPE => chars ); $str->deleteField('field1'); Allow fields to be deleted from a structure. name $name = $str->name(); Get the name of the structure. fieldName Get the field name by position in the structure - $s->fieldName( 3 ). fieldType $ftype = $str->fieldType(field1, [ new field type ]); Set/Get the SAP BC field type of a component field of the structure. This will force the overall value of the structure to be recalculated. value $fvalue = $str->value('new value'); Set/Get the value of the whole structure. fieldValue $fvalue = $str->fieldValue(field1, [new component value]); Set/Get the value of a component field of the structure. This will force the overall value of the structure to be recalculated. fields @f = &$struct->fields(); Return an array of the fields of a structure sorted in positional order. =head1 Exported constants NONE =head1 AUTHOR Piers Harding, saprfc@ompa.net But Credit must go to all those that have helped. =head1 SEE ALSO perl(1), SAP(3), SAP::Rfc(3), SAP::Iface(3) =cut 1;