perl/persistent.pl

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