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.
Index
Code Index:
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.
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');
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.
PARM_NAME()
$iface->PARM_NAME(' new value ')
Parameters and tables are autoloaded methods - than can be accessed
like this to set and get their values.
RFCTYPE_CHAR()
Autoloaded methods are provided for all the constant definitions
relating to SAP parameter types.
name()
Return the name of an interface.
addParm()
$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.
parm()
$iface->parm('PARM_NAME');
Return a reference to a named parameter object.
parms()
Return a list of parameter objects for an interface.
addTab()
$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.
isTab()
$iface->isTab('TAB_NAME');
Returns true if the named parameter is a table.
tab()
$iface->tab('TAB_NAME');
Return a reference to the named table object - see SAP::Tab.
tabs()
Return a list of table objects for the SAP::Iface object.
emptyTables()
Empty the contents of all the tables on a SAP::Iface object.
addException()
$iface->addException('EXCEPTION_NAME');
Add an exception name to the interface.
exception()
$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.
exceptions()
Return a list of exception names associated with a SAP::Iface object.
reset()
Empty all the tables and reset paramters to their default values -
useful when you are doing multiple calls.
iface()
An internal method that generates the internal structure passed into
the C routines.
handler()
return a reference to the callback handler for registered RFC
sysinfo()
return a hash ref containing the system info for the current
registered RFC callback
NAME
SAP::Tab - Perl extension for parsing and creating Tables to be added to an RFC Iface.
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 );
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 );
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 ).
addRow()
Add a row to the table contents.
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.
nextRow()
shift the first row off the table contents, and return a hash ref of
the field values as per the table structure.
rowCount()
$c = $tab1->rowCount();
return the current number of rows in a table object.
empty()
empty the row out of the table.
name()
get the name of the table object.
intype()
Set or get the internal table type.
leng()
Set or get the table row length.
structure()
Set or get the structure object of the table - see SAP::Struct.
NAME
SAP::Parms - Perl extension for parsing and creating an SAP parameter to be added to an RFC Interface.
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 );
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 );
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 ).
type()
$t = $imp1->type( [ type ] );
optionally set and Give the current value of type - this denotes
whether this is an export or import parameter.
decimals()
Set or get the decimals place of the parameter.
intype()
Set or get the internal type ( as required by librfc ).
intvalue()
An internal method for translating the value of a parameter into
the required native C format.
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.
structure()
Set or get the structure object for a parameter - not all
parameters will have an associated structures - only complex
ones. See SAP::Struc.
leng()
Set or get the length attribute of a parameter.
name()
Get the name of a parameter object.
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.
SYNOPSIS
use SAP::Struc;
$struct = new SAP::Struc( NAME => XYZ, FIELDS => [......] );
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.
hash()
$val = $str->hash();
Get a hash of the values of the whole structure (current value).
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.
Exported constants
AUTHOR
Piers Harding, saprfc@ompa.net
But Credit must go to all those that have helped.
SEE ALSO
perl(1), SAP(3), SAP::Rfc(3), SAP::Iface(3)
package SAP::Iface;
use strict;
require 5.005;
use Encode;
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,
UNICODE => 1,
ENDIAN => 1,
HANDLER => 1,
PARAMETERS => 1,
TABLES => 1,
EXCEPTIONS => 1,
SYSINFO => 1,
RFCINTTYP => 1,
LINTTYP => 1
};
$VERSION = '1.54';
# empty destroy method to stop capture by autoload
sub DESTROY {
}
# work arround for the VERSION interface parameter
sub VERSION {
my $self = shift;
my $name = 'VERSION';
if ( 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";
};
}
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;
@_ = ('NAME' => @_) if scalar @_ == 1;
my $self = {
ENDIAN => join(" ", map { sprintf "%#02x", $_ } unpack("C*",pack("L",0x12345678))) eq "0x78 0x56 0x34 0x12" ? "LIT" : "BIG",
PARAMETERS => {},
TABLES => {},
EXCEPTIONS => {},
SYSINFO => {},
@_
};
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};
}
# get the sysinfo of the current connection
# only relevent for registered RFC
sub sysinfo {
my $self = shift;
return $self->{'SYSINFO'};
}
# set/get the handler
sub handler {
my $self = shift;
$self->{'HANDLER'} = shift @_
if scalar @_ == 1;
return $self->{'HANDLER'};
}
# 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 $flag = shift || "";
my $iface = {};
map { $iface->{$_->name()} = { 'TYPE' => $_->type(),
'INTYPE' => $_->intype(),
'DATA' => ($_->structure ? [$_->data() ] : undef),
# 'VALUE' => ((($_->intype() == RFCTYPE_BYTE) && $_->type() == RFCEXPORT ) ? pack("A".$_->leng(), $_->intvalue()) : ($self->unicode && $_->structure ? $_->intvalueparts() : $_->intvalue())),
'VALUE' => ((($_->intype() == RFCTYPE_BYTE) && $_->type() == RFCEXPORT ) ? pack("A".$_->leng(), $_->intvalue()) : $_->intvalue()),
# 'LEN' => ((($_->intype() == RFCTYPE_CHAR) && $_->type() != RFCIMPORT ) ? length($_->intvalue()) : $_->leng()) }
'LEN' => ((($_->intype() == RFCTYPE_CHAR) && $_->type() != RFCIMPORT && ! $_->unicode ) ? length($_->intvalue()) : $_->leng()) }
} ( $flag ? $self->parms : $self->parms_noempty() );
map { $iface->{$_->name()} = { 'TYPE' => RFCTABLE,
'INTYPE' => $_->intype(),
# 'VALUE' => [ ($self->unicode ? $_->introws() : $_->rows()) ],
'VALUE' => [ $_->introws() ],
'DATA' => [$_->data() ],
'LEN' => $_->leng() };
} ( $self->tabs() );
if ($flag){
$iface->{'__HANDLER__'} = $self->{'HANDLER'};
$iface->{'__SELF__'} = $self;
}
# use Data::Dumper;
# print STDERR "Interface to pass in: ".Dumper($iface)."\n";
# exit(0);
return $iface;
}
sub unicode {
my $self = shift;
return $self->{UNICODE};
}
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,
ENDIAN => 1,
UNICODE => 1,
RFCINTTYP => 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 = {
ENDIAN => join(" ", map { sprintf "%#02x", $_ } unpack("C*",pack("L",0x12345678))) eq "0x78 0x56 0x34 0x12" ? "LIT" : "BIG",
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;
}
sub unicode {
my $self = shift;
return $self->{UNICODE};
}
# 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();
my $flds = $str->fieldinfo;
foreach my $row ( @{$self->{'VALUE'}} ){
if ($self->unicode){
# we must be given a hash
die "in Unicode a parameter ($self->{NAME}) must be passed a HASH"
unless ref($row) eq 'HASH';
my $line = [];
map {
my $fld = $_;
my $value = $row->{$fld->{fieldname}};
if ( $fld->{intype} == RFCTYPE_BCD){
$value =~ s/^\s+([ -+]\d.*)$/$1/;
$value ||= 0;
$value = sprintf("%0".int(($fld->{len1}*2) + ($fld->{dec} > 0 ? 1:0)).".".$fld->{dec}."f", $value);
$value =~ s/\.//g;
my @flds = split(//, $value);
shift @flds eq '-' ? push( @flds, 'd'): push( @flds, 'c');
$value = join('', @flds);
$value = pack("H*", $value);
} elsif ( $fld->{intype} == RFCTYPE_FLOAT){
$value = pack("d", $value);
} elsif ( $fld->{intype} == RFCTYPE_INT){
$value = pack(($self->{'ENDIAN'} eq "BIG" ? "l" : "V" ), int($value));
} elsif ( $fld->{intype} == RFCTYPE_INT2){
$value = pack("S", int($value));
} elsif ( $fld->{intype} == RFCTYPE_INT1){
# get the last byte of the integer
$value = chr(int($value));
} elsif ( $fld->{intype} == RFCTYPE_DATE){
$value ||= '00000000';
} elsif ( $fld->{intype} == RFCTYPE_TIME){
$value ||= '000000';
} else {
# This is a char type - sort out unicode
$value ||= " ";
{
use utf8;
Encode::_utf8_on($value);
if (length($value) > $fld->{len1}){
$value = substr($value, 0, $fld->{len1});
} else {
$value = pack("A".$fld->{len1}, $value);
}
Encode::_utf8_off($value);
no utf8;
}
};
push(@{$line}, $value);
} ( @{$flds} );
push(@rows, $line);
} elsif (ref($row) eq 'HASH'){
map { $str->$_($row->{$_}) } keys %{$row};
$row = $str->value;
$str->value("");
push(@rows, $row);
} else {
push(@rows, $row);
}
}
if ($self->unicode){
$self->{'INTVALUE'} = \@rows;
} else {
$self->{'VALUE'} = \@rows;
}
}
if ($self->unicode){
if ( scalar @{$self->{VALUE}} && ref($self->{VALUE}[0]) eq 'HASH'){
my @rows = ();
map {
my $h = $_;
my $r = { map { $_ => $h->{$_} } keys %{$h} };
push(@rows, $r);
} @{$self->{VALUE}};
return @rows;
} else {
return map { [ map { $_ } @{$_} ] } @{$self->{VALUE}};
}
} else {
return map{ pack("A".$self->leng(),$_) } (@{$self->{VALUE}});
}
}
sub introws {
my $self = shift;
if ($self->unicode){
return map { [ map { $_ } @{$_} ] } @{$self->{INTVALUE}};
} else {
return map{ pack("A".$self->leng(),$_) } (@{$self->{VALUE}});
}
}
# retrieve the rows in hashes based on the field names
sub data {
my $self = shift;
my @rows = ();
my $str = $self->structure;
foreach ( $str->fields() ){
push ( @rows, [$str->{FIELDS}->{$_}->{INTYPE}, $str->{FIELDS}->{$_}->{OFFSET2}, $str->{FIELDS}->{$_}->{LEN2}]);
}
return @rows;
}
# retrieve the rows in hashes based on the field names
sub hashRows {
my $self = shift;
my @rows = ();
if ($self->unicode){
foreach ( @{$self->{VALUE}} ){ push(@rows, $_); }
} else {
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;
if (ref($row) eq 'HASH'){
if ($self->unicode){
my $line = [];
my $flds = $self->structure->fieldinfo;
map {
my $fld = $_;
my $value = $row->{$fld->{fieldname}};
if ( $fld->{intype} == RFCTYPE_BCD){
$value =~ s/^\s+([ -+]\d.*)$/$1/;
$value ||= 0;
$value = sprintf("%0".int(($fld->{len1}*2) + ($fld->{dec} > 0 ? 1:0)).".".$fld->{dec}."f", $value);
$value =~ s/\.//g;
my @flds = split(//, $value);
shift @flds eq '-' ? push( @flds, 'd'): push( @flds, 'c');
$value = join('', @flds);
$value = pack("H*", $value);
} elsif ( $fld->{intype} == RFCTYPE_FLOAT){
$value = pack("d", $value);
} elsif ( $fld->{intype} == RFCTYPE_INT){
$value = pack(($self->{'ENDIAN'} eq "BIG" ? "l" : "V" ), int($value));
} elsif ( $fld->{intype} == RFCTYPE_INT2){
$value = pack("S", int($value));
} elsif ( $fld->{intype} == RFCTYPE_INT1){
# get the last byte of the integer
$value = chr(int($value));
} elsif ( $fld->{intype} == RFCTYPE_DATE){
$value ||= '00000000';
} elsif ( $fld->{intype} == RFCTYPE_TIME){
$value ||= '000000';
} else {
# This is a char type - sort out unicode
$value ||= " ";
{
use utf8;
Encode::_utf8_on($value);
if (length($value) > $fld->{len1}){
$value = substr($value, 0, $fld->{len1});
} else {
$value = pack("A".$fld->{len1}, $value);
}
Encode::_utf8_off($value);
no utf8;
}
};
push(@{$line}, $value);
} ( @{$flds} );
push(@{$self->{VALUE}}, $line);
} else {
map { $self->structure->$_($row->{$_}) } keys %{$row};
$row = $self->structure->value;
push(@{$self->{VALUE}}, $row);
}
} elsif (ref($row) eq 'ARRAY'){
my $cnt = 0;
map { $row->[$_->{pos} -1] = substr($row->[$_->{pos} -1], 0, $_->{len1}) } (@{$self->structure->fieldinfo});
my $line = {};
foreach my $fld (@{$self->structure->fieldinfo}){
my $value = $row->[$cnt];
# Transform various packed dta types
if ( $fld->{intype} eq RFCTYPE_INT ){
# Long INT4
$value = unpack((($self->{'RFCINTTYP'} eq 'BIG') ? "N" : "V"), $value);
} elsif ( $fld->{intype} eq RFCTYPE_INT2 ){
# Short INT2
$value = unpack("S",$value);
} elsif ( $fld->{intype} eq RFCTYPE_INT1 ){
# INT1
$value = ord( $value );
} elsif ( $fld->{intype} eq RFCTYPE_NUM ){
# NUMC
$value = int($value);
} elsif ( $fld->{intype} eq RFCTYPE_FLOAT ){
# Float
$value = unpack("d",$value);
} elsif ( $fld->{intype} eq RFCTYPE_BCD and $value ){
# All types of BCD
my @flds = split(//, unpack("H".$fld->{len1}*2, $value));
if ( $flds[$#flds] eq 'd' ){
splice( @flds,0,0,'-');
}
pop( @flds );
splice(@flds,$#flds - ( $fld->{dec} - 1 ),0,'.') if $fld->{dec} > 0;
$value = join('', @flds);
} else {
# This is a char type - sort out unicode
$value ||= " ";
};
$line->{$fld->{fieldname}} = $value;
$cnt++;
}
push(@{$self->{VALUE}}, $line);
} else {
push(@{$self->{VALUE}}, $row);
}
}
}
# Delete all rows in the table
sub empty {
my $self = shift;
$self->rows( [ ] );
$self->{INTVALUE} = [ ];
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 scalar @{$self->{VALUE}};
}
# Autoload methods go after =cut, and are processed by the autosplit program.
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 = {
RFCINTTYP => 1,
NAME => 1,
ENDIAN => 1,
HANDLER => 1,
INTYPE => 1,
LEN => 1,
STRUCTURE => 1,
DECIMALS => 1,
TYPE => 1,
DEFAULT => 1,
VALUE => 1,
UNICODE => 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,
ENDIAN => join(" ", map { sprintf "%#02x", $_ } unpack("C*",pack("L",0x12345678))) eq "0x78 0x56 0x34 0x12" ? "LIT" : "BIG",
DEFAULT => undef,
CHANGED => 0,
VALUE => '',
@_
};
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;
$self->{CHANGED} = 1 if @_;
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 @_;
return $self->{INTYPE};
}
# retrieve the rows in hashes based on the field names
sub data {
my $self = shift;
my @rows = ();
my $str = $self->structure;
foreach ( $str->fields() ){
push ( @rows, [$str->{FIELDS}->{$_}->{INTYPE}, $str->{FIELDS}->{$_}->{OFFSET2}, $str->{FIELDS}->{$_}->{LEN2}]);
}
return @rows;
}
sub unicode {
my $self = shift;
return $self->{UNICODE};
}
# Set/get the parameter value
sub value {
my $self = shift;
# there is a value
if (@_){
$self->{'VALUE'} = shift;
$self->changed(1);
# unicode and a structure
if ($self->unicode && $self->structure){
# we must be given a hash
die "in Unicode a parameter ($self->{NAME}) must be passed a HASH"
unless ref($self->{'VALUE'}) eq 'HASH';
# loop structure fields
# fill in missing ones blank
# create a hash of all for the INTVALUE
$self->{INTVALUE} = [];
map {
my $fld = $_;
my $value = $self->{VALUE}->{$fld->{fieldname}};
if ( $fld->{intype} == RFCTYPE_BCD){
$value =~ s/^\s+([ -+]\d.*)$/$1/;
$value ||= 0;
$value = sprintf("%0".int(($fld->{len1}*2) + ($fld->{dec} > 0 ? 1:0)).".".$fld->{dec}."f", $value);
$value =~ s/\.//g;
my @flds = split(//, $value);
shift @flds eq '-' ? push( @flds, 'd'): push( @flds, 'c');
$value = join('', @flds);
$value = pack("H*", $value);
} elsif ( $fld->{intype} == RFCTYPE_FLOAT){
$value = pack("d", $value);
} elsif ( $fld->{intype} == RFCTYPE_INT){
$value = pack(($self->{'ENDIAN'} eq "BIG" ? "l" : "V" ), int($value));
} elsif ( $fld->{intype} == RFCTYPE_INT2){
$value = pack("S", int($value));
} elsif ( $fld->{intype} == RFCTYPE_INT1){
# get the last byte of the integer
$value = chr(int($value));
} elsif ( $fld->{intype} == RFCTYPE_DATE){
$value ||= '00000000';
} elsif ( $fld->{intype} == RFCTYPE_TIME){
$value ||= '000000';
} else {
# This is a char type - sort out unicode
$value ||= " ";
{
use utf8;
Encode::_utf8_on($value);
if (length($value) > $fld->{len1}){
$value = substr($value, 0, $fld->{len1});
} else {
$value = pack("A".$fld->{len1}, $value);
}
Encode::_utf8_off($value);
no utf8;
}
};
push(@{$self->{INTVALUE}}, $value);
} ( @{$self->structure->fieldinfo} );
}
# it was passed in a hash
if (ref($self->{'VALUE'}) eq 'HASH'){
my $str = $self->structure();
map { $str->$_($self->{'VALUE'}->{$_}) } keys %{$self->{'VALUE'}};
$self->{'VALUE'} = $str->value;
# don't know why I did this
# $str->value("");
return $self->{'VALUE'};
} else {
# no hash - but is a structure
if (my $s = $self->structure ){
$s->value( $self->{'VALUE'} );
my $flds = {};
map { $flds->{$_} = $s->$_() } ( $s->fields );
return $flds;
} else {
# no hash and no structure
if ($self->intype() == RFCTYPE_CHAR ||
$self->intype() == RFCTYPE_BYTE) {
Encode::_utf8_off($self->{VALUE});
if ($self->unicode){
use utf8;
Encode::_utf8_on($self->{VALUE});
if (length($self->{VALUE}) > $self->leng){
$self->{VALUE} = substr($self->{VALUE}, 0, $self->leng);
} else {
$self->{VALUE} = pack("A".$self->leng, $self->{VALUE});
}
Encode::_utf8_off($self->{VALUE});
no utf8;
} else {
$self->{VALUE} = pack("A".$self->leng, $self->{VALUE});
}
}
}
}
return $self->{'VALUE'};
}
# return a complex or simple parameter value
if ($self->structure() && ! $self->unicode ){
$self->structure->value( $self->{'VALUE'} );
return { map {$_ => $self->structure->$_() } ( $self->structure->fields ) };
} else {
return $self->{'VALUE'};
}
}
# get the parameter internal value
sub intvalue {
my $self = shift;
# XXX
## sort out structured parameters
#my $str = $self->structure();
#$self->{'VALUE'} = $str->value if $str;
# this overrides
$self->{'VALUE'} = shift if @_;
# sort out structured value returned from unicode call
if (ref($self->{'VALUE'}) eq 'ARRAY' && $self->unicode){
my $cnt = 0;
# just put it into a hash now
$self->{INVALUE} = [];
map { push(@{$self->{'INTVALUE'}}, substr($self->{'VALUE'}->[$_->{pos} -1], 0, $_->{len1})) } (@{$self->structure->fieldinfo});
$self->{VALUE} = {};
foreach my $fld (@{$self->structure->fieldinfo}){
my $value = $self->{INTVALUE}->[$cnt];
# Transform various packed dta types
if ( $fld->{intype} eq RFCTYPE_INT ){
# Long INT4
$value = unpack((($self->{'RFCINTTYP'} eq 'BIG') ? "N" : "V"), $value);
} elsif ( $fld->{intype} eq RFCTYPE_INT2 ){
# Short INT2
$value = unpack("S",$value);
} elsif ( $fld->{intype} eq RFCTYPE_INT1 ){
# INT1
$value = ord( $value );
} elsif ( $fld->{intype} eq RFCTYPE_NUM ){
# NUMC
$value = int($value);
} elsif ( $fld->{intype} eq RFCTYPE_FLOAT ){
# Float
$value = unpack("d",$value);
} elsif ( $fld->{intype} eq RFCTYPE_BCD and $value ){
# All types of BCD
my @flds = split(//, unpack("H".$fld->{len1}*2, $value));
if ( $flds[$#flds] eq 'd' ){
splice( @flds,0,0,'-');
}
pop( @flds );
splice(@flds,$#flds - ( $fld->{dec} - 1 ),0,'.') if $fld->{dec} > 0;
$value = join('', @flds);
} else {
# This is a char type - sort out unicode
$value ||= " ";
};
$self->{VALUE}->{$fld->{fieldname}} = $value;
$cnt++;
}
}
# Sort out theinternal format
if ( defined $self->{'VALUE'} && $self->{'VALUE'} ne ''){
if ( $self->intype() == RFCTYPE_BCD){
$self->{VALUE} =~ s/^\s+([ -+]\d.*)$/$1/;
$self->{VALUE} ||= 0;
my $value = sprintf("%0".int(($self->{LEN}*2) + ($self->{DECIMALS} > 0 ? 1:0)).".".$self->{DECIMALS}."f", $self->{VALUE});
$value =~ s/\.//g;
my @flds = split(//, $value);
shift @flds eq '-' ? push( @flds, 'd'): push( @flds, 'c');
$value = join('', @flds);
return pack("H*", $value);
} elsif ( $self->intype() == RFCTYPE_FLOAT){
return pack("d", $self->{VALUE});
} elsif ( $self->intype() == RFCTYPE_INT){
return pack(($self->{'ENDIAN'} eq "BIG" ? "l" : "V" ), 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];
return chr(int($self->{VALUE}));
} else {
if ($self->unicode){
return $self->structure ? $self->{INTVALUE} : $self->{VALUE};
} else {
return pack("A".$self->leng(),$self->{VALUE});
}
};
} else {
if ( $self->intype() == RFCTYPE_CHAR ){
return " ";
} else {
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};
}
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 = {
RFCINTTYP => 1,
LINTTYP => 1,
NAME => 1,
FIELDS => 1,
TYPE => 1,
LEN => 1,
DATA => 1
};
# Valid Field parameters
my $FIELDVALID = {
NAME => 1,
ENDIAN => 1,
INTYPE => 1,
EXID => 1,
DECIMALS => 1,
LEN => 1,
OFFSET => 1,
LEN2 => 1,
OFFSET2 => 1,
LEN4 => 1,
OFFSET4 => 1,
POSITION => 1,
VALUE => 1
};
# Valid data types for fields
my $VALCHARTYPE = {
C => RFCTYPE_CHAR,
# these shouldnt be here ...
L => RFCTYPE_CHAR,
G => RFCTYPE_CHAR,
Y => RFCTYPE_CHAR,
X => RFCTYPE_BYTE,
B => RFCTYPE_INT1, # This is a place holder for a 1 byte int <=255+
S => RFCTYPE_INT2,
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_INT1, RFCTYPE_INT1,
RFCTYPE_INT2, RFCTYPE_INT2,
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 = {
ENDIAN => join(" ", map { sprintf "%#02x", $_ } unpack("C*",pack("L",0x12345678))) eq "0x78 0x56 0x34 0x12" ? "LIT" : "BIG",
FIELDS => {},
DATA => [],
LEN => 0,
TYPE => RFCTYPE_CHAR,
@_
};
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;
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};
}
# get the length
sub StrType {
my $self = shift;
# print STDERR "setting structure type : ", @_, "\n";
$self->{'TYPE'} = shift @_ if @_;
# print STDERR "setting Type is now: $self->{TYPE}\n";
return $self->{'TYPE'};
}
# get the length
sub StrLength {
my $self = shift;
return $self->{'LEN'};
}
# 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}};
}
# return the current set of field names
sub fieldinfo {
my $self = shift;
my @data = ();
map { push(@data, {
'fieldname' => $_,
'exid' => $self->{FIELDS}->{$_}->{EXID},
'intype' => $self->{FIELDS}->{$_}->{INTYPE},
'pos' => $self->{FIELDS}->{$_}->{POSITION},
'dec' => $self->{FIELDS}->{$_}->{DECIMALS},
'off1' => $self->{FIELDS}->{$_}->{OFFSET},
'len1' => $self->{FIELDS}->{$_}->{LEN},
'off2' => $self->{FIELDS}->{$_}->{OFFSET2},
'len2' => $self->{FIELDS}->{$_}->{LEN2},
'off4' => $self->{FIELDS}->{$_}->{OFFSET4},
'len4' => $self->{FIELDS}->{$_}->{LEN4}
})
}
sort { $self->{FIELDS}->{$a}->{POSITION} <=>
$self->{FIELDS}->{$b}->{POSITION} }
keys %{$self->{FIELDS}};
return \@data;
}
# 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};
}
sub hash {
my $self = shift;
return { map {$_ => $self->$_() } ( $self->fields ) };
}
# 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} ||= 0;
$fld->{VALUE} = pack(($self->{'RFCINTTYP'} eq 'BIG' ? "N" : "V"), int($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
# 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}));
};
} 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 ){
# All types of BCD
$fld->{VALUE} =~ s/^\s+([ -+]\d.*)$/$1/;
$fld->{VALUE} ||= 0;
# $fld->{VALUE} = sprintf("%0".int(($fld->{LEN}*2) + ($fld->{DECIMALS} > 1 ? 1:0)).".".$fld->{DECIMALS}."f", $fld->{VALUE});
$fld->{VALUE} = sprintf("%0".int(($fld->{LEN}*2) + ($fld->{DECIMALS} > 0 ? 1:0)).".".$fld->{DECIMALS}."f", $fld->{VALUE});
#warn "MASK: %0".int(($fld->{LEN}*2) + ($fld->{DECIMALS} > 1 ? 1:0)).".".$fld->{DECIMALS}."f\n";
$fld->{VALUE} =~ s/\.//g;
@flds = split(//, $fld->{VALUE});
shift @flds eq '-' ? push( @flds, 'd'): push( @flds, 'c');
$fld->{VALUE} = join('', @flds);
#warn "$fld->{NAME}: $fld->{LEN}/$fld->{DECIMALS} - $fld->{VALUE} lval:".length($fld->{VALUE})."\n";
$fld->{VALUE} = pack("H*",$fld->{VALUE});
}
$fld->{VALUE} ||= "";
} (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);
$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 @fields = $self->fields($self);
#print STDERR "unpacking: $self->{NAME} => $self->{VALUE} \n";
#use Data::Dumper;
#print STDERR Dumper($self->{DATA})."\n";
my $offset = 0;
map {
my $fld = $self->{FIELDS}->{$fields[$_]};
$offset = int($fld->{OFFSET}) if exists $fld->{OFFSET};
# print STDERR "field: $fld->{NAME} type: $fld->{INTYPE} len: $fld->{LEN} off: $offset\n";
$fld->{VALUE} = substr($self->{VALUE}, $offset, int($fld->{LEN}));
# print STDERR "actual length: ".length($self->{VALUE})."\n";
# print STDERR "field value: ".unpack("H*", $fld->{VALUE})."#\n";
# Transform various packed dta types
if ( $fld->{INTYPE} eq RFCTYPE_INT ){
# Long INT4
$fld->{VALUE} =
unpack((($self->{'RFCINTTYP'} eq 'BIG') ? "N" : "V"), $fld->{VALUE});
} elsif ( $fld->{INTYPE} eq RFCTYPE_INT2 ){
# Short INT2
# print STDERR "extracting $fld->{NAME} => ".unpack("H*", $fld->{VALUE})."\n";
$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,'-');
}
pop( @flds );
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);
}
1;