src/modules/rlm_perl/persistent.pl

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