————package
SAP::Iface;
use
strict;
# Globals
# Valid parameters
my
$IFACE_VALID
= {
NAME
=> 1,
PARAMETERS
=> 1,
TABLES
=> 1,
EXCEPTIONS
=> 1
};
$VERSION
=
'1.00'
;
# 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}};
}
# 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(),
# 'LEN' => ($_->intype() == RFCTYPE_CHAR ? length($_->intvalue()) : $_->leng()) }
'LEN'
=> (((
$_
->intype() == RFCTYPE_CHAR) &&
$_
->type() != RFCIMPORT ) ?
length
(
$_
->intvalue()) :
$_
->leng()) }
} (
$self
->parms() );
map
{
$iface
->{
$_
->name()} = {
'TYPE'
=> RFCTABLE,
'INTYPE'
=>
$_
->intype(),
'VALUE'
=> [ (
$_
->rows()) ],
'LEN'
=>
$_
->leng() };
} (
$self
->tabs() );
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;
# Globals
# 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;
# Globals
# Valid parameters
my
$PARMS_VALID
= {
NAME
=> 1,
INTYPE
=> 1,
LEN
=> 1,
STRUCTURE
=> 1,
DECIMALS
=> 1,
TYPE
=> 1,
DEFAULT
=> 1,
VALUE
=> 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
,
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};
}
# 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(
""
);
}
$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
->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;
# require AutoLoader;
# Globals
# 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;