tools/p1.pl

   1  package Embed::Persistent;
   2 #
   3 # Hacked version of the sample code from the perlembedded doco.
   4 #
   5 # Only major changes are to separate the compiling and cacheing from
   6 # the execution so that the cache can be kept in "non-volatile" parent
   7 # process while the execution is done from "volatile" child processes
   8 # and that STDOUT is redirected to a file by means of a tied filehandle
   9 # so that it can be returned to NetSaint in the same way as for
  10 # commands executed via the normal popen method.
  11 #
  12
  13  use strict;
  14  use vars '%Cache';
  15  use Symbol qw(delete_package);
  16
  17
  18 package OutputTrap;
  19 #
  20 # Methods for use by tied STDOUT in embedded PERL module.
  21 #
  22 # Simply redirects STDOUT to a temporary file associated with the
  23 # current child/grandchild process.
  24 #
  25
  26 use strict;
  27 # Perl before 5.6 does not seem to have warnings.pm ???
  28 #use warnings;
  29 use IO::File;
  30
  31 sub TIEHANDLE {
  32         my ($class, $fn) = @_;
  33         my $handle = new IO::File "> $fn" or die "Cannot open embedded work filei $!\n";
  34         bless { FH => $handle, Value => 0}, $class;
  35 }
  36
  37 sub PRINT {
  38         my $self = shift;
  39         my $handle = $self -> {FH};
  40         print $handle join("",@_);
  41 }
  42
  43 sub PRINTF {
  44         my $self = shift;
  45         my $fmt = shift;
  46         my $handle = $self -> {FH};
  47         printf $handle ($fmt,@_);
  48 }
  49
  50 sub CLOSE {
  51         my $self = shift;
  52         my $handle = $self -> {FH};
  53         close $handle;
  54 }
  55
  56  package Embed::Persistent;
  57
  58  sub valid_package_name {
  59      my($string) = @_;
  60      $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
  61      # second pass only for words starting with a digit
  62      $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
  63
  64      # Dress it up as a real package name
  65      $string =~ s|/|::|g;
  66      return "Embed::" . $string;
  67  }
  68
  69  sub eval_file {
  70      my $filename = shift;
  71      my $delete = shift;
  72      my $pn = substr($filename, rindex($filename,"/")+1);
  73      my $package = valid_package_name($pn);
  74      my $mtime = -M $filename;
  75      if(defined $Cache{$package}{mtime}
  76         &&
  77         $Cache{$package}{mtime} <= $mtime)
  78      {
  79         # we have compiled this subroutine already,
  80         # it has not been updated on disk, nothing left to do
  81         #print STDERR "already compiled $package->hndlr\n";
  82      }
  83      else {
  84         local *FH;
  85         open FH, $filename or die "open '$filename' $!";
  86         local($/) = undef;
  87         my $sub = <FH>;
  88         close FH;
  89         # cater for routines that expect to get args without prgname
  90         # and for those using @ARGV
  91         $sub = "shift(\@_);\n\@ARGV=\@_;\n" . $sub;
  92
  93         # cater for scripts that have embedded EOF symbols (__END__)
  94         $sub =~ s/__END__/\;}\n__END__/;
  95
  96         #wrap the code into a subroutine inside our unique package
  97         my $eval = qq{
  98                 package main;
  99                 use subs 'CORE::GLOBAL::exit';
 100                 sub CORE::GLOBAL::exit { die "ExitTrap: \$_[0] ($package)"; }
 101                 package $package; sub hndlr { $sub; }
 102                 };
 103         {
 104             # hide our variables within this block
 105             my($filename,$mtime,$package,$sub);
 106             eval $eval;
 107         }
 108         if ($@){
 109                 print STDERR $@."\n";
 110                 die;
 111         }
 112
 113         #cache it unless we're cleaning out each time
 114         $Cache{$package}{mtime} = $mtime unless $delete;
 115
 116      }
 117  }
 118
 119  sub run_package {
 120      my $filename = shift;
 121      my $delete = shift;
 122      my $tmpfname = shift;
 123      my $ar = shift;
 124      my $pn = substr($filename, rindex($filename,"/")+1);
 125      my $package = valid_package_name($pn);
 126      my $res = 0;
 127
 128      tie (*STDOUT, 'OutputTrap', $tmpfname);
 129
 130      my @a = split(/ /,$ar);
 131
 132      eval {$res = $package->hndlr(@a);};
 133
 134      if ($@){
 135                 if ($@ =~ /^ExitTrap:  /) {
 136                         $res = 0;
 137                 } else {
 138               # get return code (which may be negative)
 139                         if ($@ =~ /^ExitTrap: (-?\d+)/) {
 140                                 $res = $1;
 141                         } else {
 142                                 $res = 2;
 143                                 print STDERR "<".$@.">\n";
 144                         }
 145                 }
 146      }
 147      untie *STDOUT;
 148      return $res;
 149  }
 150
 151  1;