v3.15 release

- Added caching of scripts. This means using more memory but it also means
  executing scripts 45-65% faster! (mod_perl only)
- Added configurability of caching: PerlSetVar PLPcache On/Off (Default: On)
- Changed PLP.pm to use File::Basename and File::Spec
- Added recursion protection for compile-time includes (fixed max depth: 128)

diff --git a/Changes b/Changes
index b86377e7179cf087f65ec592067e5d8e17905402..6b7f9a2629b9c2c912663a767bfbc33090cc85ed 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,3 +1,10 @@
+3.15 - May 21, 2002:
+- Added caching of scripts. This means using more memory but it also means
+  executing scripts 45-65% faster! (mod_perl only)
+- Added configurability of caching: PerlSetVar PLPcache On/Off (Default: On)
+- Changed PLP.pm to use File::Basename and File::Spec
+- Added recursion protection for compile-time includes (fixed max depth: 128)
+
 3.14 - May 20, 2002:
 - New plp.vim
 - Small documentation change

diff --git a/PLP.pm b/PLP.pm
index 578c13325c829be02d4e8c6dac2a4c9de4b5607b..a75b42ab02ef42e375c6c16b388be83a294192ab 100644 (file)
--- a/PLP.pm
+++ b/PLP.pm
@@ -10,9 +10,13 @@ use PLP::Tie::Headers;
 use PLP::Tie::Delay;
 use PLP::Tie::Print;
 
+use File::Basename ();
+use File::Spec;
+use Cwd ();
+
 use strict;
 
-our $VERSION = '3.14';
+our $VERSION = '3.15';
 
 # subs in this package:
 #  sendheaders                      Send headers
@@ -37,65 +41,113 @@ sub sendheaders () {
 # Given a filename and optional level (level should be 0 if the caller isn't
 # source() itself), and optional linespec (used by PLP::Functions::Include),
 # this function parses a PLP file and returns Perl code, ready to be eval'ed
-sub source {
-    my ($path, $level, $linespec) = @_;
-    $level = 0      if not defined $level;
-    $linespec = '1' if not defined $linespec;
-    
-    our ($inA, $inB);
-    
-    (my $file = $path) =~ s[.*/][];
+{
+    my %cached; # Conceal cached sources
     
-    my $source = $level
-       ? qq/\cQ;\n#line 1 "$file"\nprint q\cQ/
-       : qq/\n#line 1 "$file"\nprint q\cQ/;
-    my $linenr = 0;
+    # %cached = (
+    #  $filename => [
+    #      [ dependency, dependency, dependency ], # <(...)>
+    #      'source',
+    #      -M
+    #  ]
+    # );
     
-    local *SOURCE;
-    open SOURCE, '<', $path or return $level
-       ? qq{\cQ; die qq[Can't open "\Q$path\E" (\Q$!\E)]; print q\cQ}
-       : qq{\n#line $linespec\ndie qq[Can't open "\Q$path\E" (\Q$!\E)];};
-    
-    LINE:
-    while (defined (my $line = <SOURCE>)) {
-       $linenr++;
-       for (;;) {
-           $line =~ /
-               \G                  # Begin where left off
-               ( \z                # End
-               | <:=? | :>         # PLP tags     <:= ... :> <: ... :>
-               | <\(.*?\)>         # Include tags <(...)>
-               | <[^:(][^<:]*      # Normal text
-               | :[^>][^<:]*       # Normal text
-               | [^<:]*            # Normal text
-               )
-           /gxs;
-           next LINE unless length $1;
-           my $part = $1;
-           if ($part eq '<:=' and not $inA || $inB) {
-               $inA = 1;
-               $source .= "\cQ, ";
-           } elsif ($part eq '<:' and not $inA || $inB) {
-               $inB = 1;
-               $source .= "\cQ; ";
-           } elsif ($part eq ':>' and $inA) {
-               $inA = 0;
-               $source .= ", q\cQ";
-           } elsif ($part eq ':>' and $inB) {
-               $inB = 0;
-               $source .= "; print q\cQ";
-           } elsif ($part =~ /^<\((.*?)\)>\z/ and not $inA || $inB) {
-               $source .= source($1, $level + 1) .
-                          qq/\cQ, \n#line $linenr "$file"\nq\cQ/;
-           } else {
-               $part =~ s/\\/\\\\/ if not $inA || $inB;
-               $source .= $part;
+    sub source {
+       my ($file, $level, $linespec, $path) = @_;
+       $level = 0      if not defined $level;
+       $linespec = '1' if not defined $linespec;
+       
+       if ($level > 128) {
+           %cached = ();
+           return $level
+               ? qq{\cQ; die qq[Include recursion detected]; print q\cQ}
+               : qq{\n#line $linespec\ndie qq[Include recursion detected];};
+       }
+
+       our ($inA, $inB, $use_cache);
+       $path ||= File::Spec->rel2abs($file);
+       
+       my $source_start = $level
+           ? qq/\cQ;\n#line 1 "$file"\nprint q\cQ/
+           : qq/\n#line 1 "$file"\nprint q\cQ/;
+       
+       if ($use_cache and exists $cached{$path}) {
+           BREAKOUT: {
+               my @checkstack = ($path);
+               my $item;
+               my %checked;
+               while (defined(my $item = shift @checkstack)) {
+                   next if $checked{$item};
+                   last BREAKOUT if $cached{$item}[2] > -M $item;
+                   $checked{$item} = 1;
+                   push @checkstack, @{ $cached{$item}[0] }
+                       if @{ $cached{$item}[0] };
+               }
+               return $level
+                   ? $source_start . $cached{$path}[1]
+                   : $source_start . $cached{$path}[1] . "\cQ";
            }
        }
-    }
-    $source .= "\cQ" unless $level;
 
-    return $source;
+       $cached{$path} = [ [ ], undef, undef ] if $use_cache;
+       
+       my $linenr = 0;
+       my $source = '';
+
+       local *SOURCE;
+       open SOURCE, '<', $path or return $level
+           ? qq{\cQ; die qq[Can't open "\Q$path\E" (\Q$!\E)]; print q\cQ}
+           : qq{\n#line $linespec\ndie qq[Can't open "\Q$path\E" (\Q$!\E)];};
+       
+       LINE:
+       while (defined (my $line = <SOURCE>)) {
+           $linenr++;
+           for (;;) {
+               $line =~ /
+                   \G                  # Begin where left off
+                   ( \z                # End
+                   | <:=? | :>         # PLP tags     <:= ... :> <: ... :>
+                   | <\(.*?\)>         # Include tags <(...)>
+                   | <[^:(][^<:]*      # Normal text
+                   | :[^>][^<:]*       # Normal text
+                   | [^<:]*            # Normal text
+                   )
+               /gxs;
+               next LINE unless length $1;
+               my $part = $1;
+               if ($part eq '<:=' and not $inA || $inB) {
+                   $inA = 1;
+                   $source .= "\cQ, ";
+               } elsif ($part eq '<:' and not $inA || $inB) {
+                   $inB = 1;
+                   $source .= "\cQ; ";
+               } elsif ($part eq ':>' and $inA) {
+                   $inA = 0;
+                   $source .= ", q\cQ";
+               } elsif ($part eq ':>' and $inB) {
+                   $inB = 0;
+                   $source .= "; print q\cQ";
+               } elsif ($part =~ /^<\((.*?)\)>\z/ and not $inA || $inB) {
+                   my $ipath = File::Spec->rel2abs($1);
+                   $source .= source($1, $level + 1, undef, $ipath) .
+                              qq/\cQ, \n#line $linenr "$file"\nq\cQ/;
+                   push @{ $cached{$path}[0] }, $ipath;
+               } else {
+                   $part =~ s/\\/\\\\/ if not $inA || $inB;
+                   $source .= $part;
+               }
+           }
+       }
+
+       if ($use_cache) {
+           $cached{$path}[1] = $source;
+           $cached{$path}[2] = -M $path;
+       }
+
+       return $level
+           ? $source_start . $source
+           : $source_start . $source . "\cQ";
+    }
 }
 
 # Handles errors, uses the sub reference $PLP::ERROR that gets two arguments:
@@ -155,11 +207,11 @@ sub clean {
 # This sub is meant for CGI requests only, and takes apart PATH_TRANSLATED
 # to find the file.
 sub cgi_init {
-    my $file = defined $_[0] ? $_[0] : $ENV{PATH_TRANSLATED};
+    my $path = $ENV{PATH_TRANSLATED};
     $ENV{PLP_NAME} = $ENV{PATH_INFO};
     my $path_info;
-    while (not -f $file) {
-        if (not $file =~ s/(\/+[^\/]*)$//) {
+    while (not -f $path) {
+        if (not $path =~ s/(\/+[^\/]*)$//) {
            print STDERR "PLP: Not found: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
            PLP::error(undef, 404);
            exit;
@@ -169,7 +221,7 @@ sub cgi_init {
        $path_info = $pi . $path_info;
     }
     
-    if (not -r $file) {
+    if (not -r $path) {
        print STDERR "PLP: Can't read: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
        PLP::error(undef, 403);
        exit;
@@ -181,11 +233,11 @@ sub cgi_init {
     };
 
     $ENV{PATH_INFO} = $path_info if defined $path_info;
-    $ENV{PLP_FILENAME} = $file;
-    (my $dir = $file) =~ s{/[^/]+$}[];
+    $ENV{PLP_FILENAME} = $path;
+    my ($file, $dir) = File::Basename::fileparse($path);
     chdir $dir;
 
-    $PLP::code = PLP::source($file, 0);
+    $PLP::code = PLP::source($file, 0, undef, $path);
 }
 
 # This is the mod_perl initializer.
@@ -202,10 +254,14 @@ sub mod_perl_init {
        return Apache::Constants::FORBIDDEN();
     }
     
-    (my $dir) = $filename =~ m!(.*)/!s;
-    chdir $dir;
     $ENV{PLP_NAME} = $r->uri;
-    $PLP::code = PLP::source($r->filename);
+
+    our $use_cache = $r->dir_config('PLPcache') !~ /^off$/i;
+    my $path = $r->filename();
+    my ($file, $dir) = File::Basename::fileparse($path);
+    chdir $dir;
+
+    $PLP::code = PLP::source($file, 0, undef, $path);
 
     return 0; # OK
 }
@@ -279,6 +335,7 @@ PLP - Perl in HTML pages
         SetHandler perl-script
         PerlHandler PLP
         PerlSendHeader On
+       PerlSetVar PLPcache On
     </Files>
 
     # Who said CGI was easier to set up? :)