perl/persistent.pl

   1 #
   2 # This allows perl programs to call functions dynamically
   3 #
   4 # This has been nicked directly from the perlembed pages
   5 # so has the perl copyright
   6 #
   7 # $Id$
   8 #
   9
  10 package Embed::Persistent;
  11 #persistent.pl
  12
  13 #require Devel::Symdump;
  14 use strict;
  15 use vars '%Cache';
  16
  17 sub valid_package_name {
  18         my($string) = @_;
  19         $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
  20 #second pass only for words starting with a digit
  21         $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
  22
  23 #Dress it up as a real package name
  24         $string =~ s|/|::|g;
  25         return "Embed" . $string;
  26 }
  27
  28 #borrowed from Safe.pm
  29 sub delete_package {
  30         my $pkg = shift;
  31         my ($stem, $leaf);
  32
  33         no strict 'refs';
  34         $pkg = "main::$pkg\::";    # expand to full symbol table name
  35                 ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
  36
  37         my $stem_symtab = *{$stem}{HASH };
  38
  39         delete $stem_symtab->{$leaf     };
  40  }
  41
  42 sub eval_file {
  43         my($filename, $delete) = @_;
  44         my $package = valid_package_name($filename);
  45         my $mtime = -M $filename;
  46         if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime } <= $mtime) {
  47 #we have compiled this subroutine already,
  48 #it has not been updated on disk, nothing left to do
  49                 print STDERR "already compiled $package->handler\n";
  50         } else {
  51                 local *FH;
  52                 open FH, $filename or die "open '$filename' $!";
  53                 local($/) = undef;
  54                 my $sub = <FH>;
  55                 close FH;
  56
  57 #wrap the code into a subroutine inside our unique package
  58                 my $eval = qq{package $package; sub handler { $sub; }};
  59                 {
  60 #hide our variables within this block
  61                         my($filename,$mtime,$package,$sub);
  62                         eval $eval;
  63                 }
  64                 die $@ if $@;
  65
  66 #cache it unless we're cleaning out each time
  67                 $Cache{$package}{mtime} = $mtime unless $delete;
  68 }
  69
  70 eval {$package->handler;};
  71 die $@ if $@;
  72
  73 delete_package($package) if $delete;
  74
  75 #take a look if you want
  76 #print Devel::Symdump->rnew($package)->as_string, $/;
  77 }
  78
  79 1;
  80
  81 __END__