#!/usr/bin/perl -w
use strict;

=pod

=head1 NAME

perl.pl

=head1 DESCRIPTION

Copyright Piers Harding 2004 - all rights reserved.
This code is distributed under the same terms as Perl itself.

Perl for ABAP programmers

=cut
use SAP::Rfc;
use SAP::Iface;
use Data::Dumper;
use Getopt::Std;
use POSIX;
use vars qw( $VERSION $DEBUG );

$DEBUG = 0;
$VERSION = 1;

# handle command line options
use vars qw($opt_d $opt_b $opt_h $opt_n $opt_g $opt_s);
getopts('bdhn:g:s:');

# did they ask for help ?
die usage() if defined($opt_h);

# are we debugging ?
debug("Debugging is switched on...") if $DEBUG = $opt_d;

# Auto flush the print buffer
$| = 1;

debug("VERSION: ".$SAP::Rfc::VERSION );
$SAP::Rfc::EXCEPTION_ONLY = 1;

# construct the connection to the gateway
my $rfc = new SAP::Rfc(
              TPNAME   => $opt_n ? $opt_n  : 'perl',
              GWHOST   => $opt_g ? $opt_g : 'seahorse',
              GWSERV   => $opt_s ? $opt_s : '3300',
              TRACE    => $opt_d ? 1 : 0,
	      );

# construct the FUNCTIONS to support
$rfc->iface(rfc_exec_perl());

# on with the real business
debug("START");

# object cache and counter
my $obj_counter = 0;
my $obj_tree = {};

# right - off into the back ground
daemonise() if $opt_b;

# start the main loop
$rfc->accept();

debug("RC: ".$rfc->error());

# will probably never get here
debug("FINISH");

exit 0;


sub do_exec_perl {

  my $iface = shift;
  debug("Running do_exec_perl...");
  my $type = $iface->TYPE;
  $type =~ s/\s+$//;
  debug("call type is: $type");

  my $cmd = $iface->COMMAND;
  $cmd =~ s/\s+$//;
  my @chars = split(//,$cmd);
  pop @chars;
  $cmd = join("",@chars);
  debug("Command is: #$cmd#");

  my $res;

  # eval a piece if code
  if ($type eq 'E'){
    eval $cmd;
    debug("Exec error is: $@") if $@;
    die "EXEC_ERROR" if $@;

    # eval a piece if code and return one value
  } elsif ($type eq 'ER'){
    $res = eval $cmd;
    debug("Exec error is: $@") if $@;
    die "EXEC_ERROR" if $@;
    debug("Exec result is: $res");
    $iface->RESULTS( [ pack("A512",$res) ]);

    # eval N pieces if code and return N values
  } elsif ($type eq 'ENRN'){
    my @totres = ();
    foreach my $cmd ($iface->PARAMS){
      my @res = eval $cmd;
      debug("Exec error is: $@") if $@;
      die "EXEC_ERROR" if $@;
      debug("Exec result is: ".join(" | ", @res));
      push(@totres, @res);
    }
    $iface->RESULTS( [ map { pack("A512",$_) } @totres ]);

    # execute a regex and return 1 value
  } elsif ($type eq 'R'){
    my $target = ($iface->PARAMS)[0];
    $target =~ s/\s+$//;
    ($res) = $target =~ /$cmd/;
    debug("The result for regex($cmd/:$target) is: #$res#");
    $iface->RESULTS( [ pack("A512", $res) ]);

    # execute N regexs and return N values
  } elsif ($type eq 'RN'){
    my @totres = ();
    foreach my $target ($iface->PARAMS){
      $target =~ s/\s+$//;
      my (@res) = $target =~ /$cmd/;
      debug("The result for regex($cmd/:$target) is: ".join(" | ", @res));
      push(@totres, @res);
    }
    $iface->RESULTS( [ map { pack("A512", $_) } @totres ]);

    # create a Perl object and return an objid
  } elsif ($type eq 'C'){
    my $obj;
    my @parms = map { $_ =~ s/\s+$//; $_ } ($iface->PARAMS);
    debug("object name is: $cmd");
    debug("Parameters are: ".join(" | ", @parms));
    debug("eval looks like: \$obj = $cmd->new(\@parms);");
    eval "\$obj = $cmd->new(\@parms);";
    debug("Exec error is: $@") if $@;
    die "EXEC_ERROR" if $@;
    $obj_counter++;
    $obj_tree->{$obj_counter} = $obj;
    $iface->RESULTS( [ pack("A512", $obj_counter) ]);
    debug("result object is: $obj_counter - $obj - ".ref($obj));

    # execute a static Perl method - return N values
  } elsif ($type eq 'S'){
    my @parms = map { $_ =~ s/\s+$//; $_ } ($iface->PARAMS);
    debug("static method name is: #$cmd#");
    debug("Parameters are: ".join(" | ", @parms));
    my @res = ();
    eval { no strict "refs"; @res = &$cmd( @parms ); };
    debug("Exec error is: $@") if $@;
    die "EXEC_ERROR" if $@;
    $iface->RESULTS( [ map { pack("A512", $_) } @res ]);
    debug("Exec result is: ".join(" | ", @res));

    # execute an Perl instance method - return N values
  } elsif ($type eq 'M'){
    my @parms = map { $_ =~ s/\s+$//; $_ } ($iface->PARAMS);
    debug("parameters: ".join(" | ", @parms));
    my $objid = pop(@parms);
    die "NO_OBJECT" unless exists $obj_tree->{int($objid)};
    my $obj = $obj_tree->{int($objid)};
    debug("method name is: $cmd - $obj - ".ref($obj));
    debug("Parameters are: ".join(" | ", @parms));
    my @res;
    eval { @res = $obj->$cmd( @parms ); };
    debug("Exec error is: $@") if $@;
    die "EXEC_ERROR" if $@;
    $iface->RESULTS( [ map { pack("A512", $_) } @res ]);
    debug("Exec result is: ".join(" | ", @res));

    # deletes an object referenced by objid
  } elsif ($type eq 'D'){
    debug("object tree: ".Dumper($obj_tree));
    delete $obj_tree->{int($cmd)} if exists $obj_tree->{int($cmd)};
  } else {
    die "ILLEGAL_CALL";
  }
  debug("Finished iteration - returning...\n\n");
  return 1;

}


sub rfc_exec_perl {
  my $iface = new SAP::Iface(NAME => "RFC_EXEC_PERL", HANDLER => \&do_exec_perl);
  $iface->addParm( TYPE => $iface->RFCIMPORT,
                   INTYPE => $iface->RFCTYPE_CHAR,
                   NAME => "COMMAND",
                   LEN => 512);
  $iface->addParm( TYPE => $iface->RFCIMPORT,
                   INTYPE => $iface->RFCTYPE_CHAR,
                   NAME => "TYPE",
                   LEN => 5);
  $iface->addTab( NAME => "PARAMS",
                  LEN => 512);
  $iface->addTab( NAME => "RESULTS",
                  LEN => 512);
  return $iface;
}


sub usage {

  no warnings;
  return <<EO_USAGE;
  $0 $VERSION usage:
  $0 -n <TPNAME of the reg.RFC> -g <gateway host> [-s <gateway service> -b -h -d ]

  -n = the TPNAME of the registered RFC in the gateway
  -g = the gateway host
  -s = the gateway service no. - default 3300
  -b = push the program into the background
  -d = switch on debugging 
  -h = display this help

EO_USAGE

}

sub debug{

  return unless $DEBUG;
  print  STDERR scalar localtime().": ", @_, "\n";

}


sub daemonise {
   chdir '/'    or die "Can't chdir to /: $!";
   open STDIN, '/dev/null' or die "Can't read /dev/null: $!";
   open STDOUT, '>/dev/null' or die "Can't write to /dev/null: $!";
   defined(my $pid = fork) or die "Can't fork: $!";
   exit if $pid;
   setsid or die "Can't start a new session: $!";
   open STDERR, '>&STDOUT' or die "Can't dup stdout: $!";
}