From 0e6ce8b6bf210446db18405c548ad83fc62ace81 Mon Sep 17 00:00:00 2001 From: Juerd Waalboer Date: Tue, 21 May 2002 12:26:08 +0000 Subject: [PATCH] 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) --- Changes | 7 +++ PLP.pm | 187 ++++++++++++++++++++++++++++++++++++-------------------- 2 files changed, 129 insertions(+), 65 deletions(-) diff --git a/Changes b/Changes index b86377e..6b7f9a2 100644 --- 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 578c133..a75b42a 100644 --- 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 = )) { - $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 = )) { + $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 # Who said CGI was easier to set up? :) -- 2.30.0