More files for rlm_perl

diff --git a/src/modules/rlm_perl/persistent.pl b/src/modules/rlm_perl/persistent.pl
new file mode 100644 (file)
index 0000000..4758a7c
--- /dev/null
+++ b/src/modules/rlm_perl/persistent.pl
@@ -0,0 +1,57 @@
+package Embed::Persistent;
+        use strict;
+        use vars '%Cache';
+        use Symbol qw(delete_package);
+
+        sub valid_package_name {
+            my($string) = @_;
+            $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
+            # second pass only for words starting with a digit
+            $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
+            # Dress it up as a real package name
+            $string =~ s|/|::|g;
+            return "Embed" . $string;
+        }
+
+        sub eval_file {
+            my($filename, $delete) = @_;
+            my $package = valid_package_name($filename);
+            my $mtime = -M $filename;
+            if(defined $Cache{$package}{mtime}
+               &&
+               $Cache{$package}{mtime} <= $mtime)
+            {
+               # we have compiled this subroutine already,
+               # it has not been updated on disk, nothing left to do
+               #print STDERR "already compiled $package->handler\n";
+            }
+            else {
+               local *FH;
+               open FH, $filename or die "open '$filename' $!";
+               local($/) = undef;
+               my $sub = <FH>;
+               close FH;
+
+               #wrap the code into a subroutine inside our unique package
+               my $eval = qq{package $package; sub handler { $sub; }};
+               {
+                   # hide our variables within this block
+                   my($filename,$mtime,$package,$sub);
+                   eval $eval;
+               }
+               die $@ if $@;
+
+               #cache it unless we're cleaning out each time
+               $Cache{$package}{mtime} = $mtime unless $delete;
+            }
+
+            eval {$package->handler;};
+            die $@ if $@;
+
+            delete_package($package) if $delete;
+
+            #take a look if you want
+            #print Devel::Symdump->rnew($package)->as_string, $/;
+        }
+
+1;

diff --git a/src/modules/rlm_perl/test.pl b/src/modules/rlm_perl/test.pl
new file mode 100644 (file)
index 0000000..924f8a1
--- /dev/null
+++ b/src/modules/rlm_perl/test.pl
@@ -0,0 +1,29 @@
+#  This program is free software; you can redistribute it and/or modify
+#  it under the terms of the GNU General Public License as published by
+#  the Free Software Foundation; either version 2 of the License, or
+#  (at your option) any later version.
+#
+#  This program is distributed in the hope that it will be useful,
+#  but WITHOUT ANY WARRANTY; without even the implied warranty of
+#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+#  GNU General Public License for more details.
+#
+#  You should have received a copy of the GNU General Public License
+#  along with this program; if not, write to the Free Software
+#  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+#
+# Copyright 2002  The FreeRADIUS server project
+# Copyright 2002  Boian Jordanov <bjordanov@orbitel.bg>
+#
+use strict;
+
+open (FILE,">/tmp/debug") or die "File cannot be opened \n";
+for (keys %ENV) {
+       print FILE "$_ = $ENV{$_} \n";
+}
+$!=0;
+close(FILE);
+
+$main::result{'Framed-IP-Address'} = '127.0.0.1';
+
+die;