X-Git-Url: http://git.shiar.net/perl/plp/.git/blobdiff_plain/c425b50ff4140d6e6d9556fd1e4c380def5fc3e0..a3a4d694959ff6549ab0a37632440f529229c576:/PLP.pm diff --git a/PLP.pm b/PLP.pm index a5936fd..8a535da 100644 --- a/PLP.pm +++ b/PLP.pm @@ -10,330 +10,242 @@ use PLP::Tie::Print; use File::Basename (); use File::Spec; -use Cwd (); use strict; -our $VERSION = '3.18'; +our $VERSION = '3.19'; # Subs in this package: # _default_error($plain, $html) Default error handler -# cgi_init Initialization for CGI # clean Reset variables # error($error, $type) Handle errors # everything Do everything: CGI # handler($r) Do everything: mod_perl -# mod_perl_init($r) Initialization for mod_perl -# mod_perl_print Faster printing for mod_perl # sendheaders Send headers # source($path, $level, $linespec) Read and parse .plp files # start Start the initialized PLP script # The _init subs do the following: # Set $PLP::code to the initial code -# Set $ENV{PLP_*} and makes PATH_INFO if needed +# Set $ENV{PLP_*} and make PATH_INFO if needed # Change the CWD # This gets referenced as the initial $PLP::ERROR sub _default_error { - my ($plain, $html) = @_; - print qq{

}, - qq{Debug information:
$html

}; -} - -# CGI initializer: parses PATH_TRANSLATED -sub cgi_init { - - $PLP::print = 'print'; - - my $path = $ENV{PATH_TRANSLATED}; - $ENV{PLP_NAME} = $ENV{PATH_INFO}; - my $path_info; - 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; - } - my $pi = $1; - $ENV{PLP_NAME} =~ s/\Q$pi\E$//; - $path_info = $pi . $path_info; - } - - if (not -r $path) { - print STDERR "PLP: Can't read: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n"; - PLP::error(undef, 403); - exit; - } - - delete @ENV{ - qw(PATH_TRANSLATED SCRIPT_NAME SCRIPT_FILENAME PATH_INFO), - grep /^REDIRECT_/, keys %ENV - }; - - $ENV{PATH_INFO} = $path_info if defined $path_info; - $ENV{PLP_FILENAME} = $path; - my ($file, $dir) = File::Basename::fileparse($path); - chdir $dir; - - $PLP::code = PLP::source($file, 0, undef, $path); + my ($plain, $html) = @_; + print qq{

}, + qq{Debug information:
$html

}; } # This cleans up from previous requests, and sets the default $PLP::DEBUG sub clean { - @PLP::END = (); - $PLP::code = ''; - $PLP::sentheaders = 0; - $PLP::DEBUG = 1; - $PLP::print = ''; - $PLP::r = undef; - delete @ENV{ grep /^PLP_/, keys %ENV }; + @PLP::END = (); + $PLP::code = ''; + $PLP::sentheaders = 0; + $PLP::DEBUG = 1; + $PLP::print = ''; + delete @ENV{ grep /^PLP_/, keys %ENV }; } # Handles errors, uses subref $PLP::ERROR (default: \&_default_error) sub error { - my ($error, $type) = @_; - if (not defined $type or $type < 100) { - return undef unless $PLP::DEBUG & 1; - my $plain = $error; - (my $html = $plain) =~ s/([<&>])/'&#' . ord($1) . ';'/ge; - PLP::sendheaders() unless $PLP::sentheaders; - $PLP::ERROR->($plain, $html); - } else { - select STDOUT; - my ($short, $long) = @{ - +{ - 404 => [ - 'Not Found', - "The requested URL $ENV{REQUEST_URI} was not found " . - "on this server." - ], - 403 => [ - 'Forbidden', - "You don't have permission to access $ENV{REQUEST_URI} " . - "on this server." - ], - }->{$type} - }; - print "Status: $type\nContent-Type: text/html\n\n", - qq{\n}, - "\n$type $short\n\n

$short", - "

\n$long

\n$ENV{SERVER_SIGNATURE}"; - } + my ($error, $type) = @_; + if (not defined $type or $type < 100) { + return undef unless $PLP::DEBUG & 1; + my $plain = $error; + (my $html = $plain) =~ s/([<&>])/'&#' . ord($1) . ';'/ge; + PLP::sendheaders() unless $PLP::sentheaders; + $PLP::ERROR->($plain, $html); + } else { + select STDOUT; + my ($short, $long) = @{ + +{ + 404 => [ + 'Not Found', + "The requested URL $ENV{REQUEST_URI} was not found " . + "on this server." + ], + 403 => [ + 'Forbidden', + "You don't have permission to access $ENV{REQUEST_URI} " . + "on this server." + ], + }->{$type} + }; + print "Status: $type\nContent-Type: text/html\n\n", + qq{\n}, + "\n$type $short\n\n

$short", + "

\n$long

\n$ENV{SERVER_SIGNATURE}"; + } } -# This is run by the CGI script. (#!perl \n use PLP; PLP::everything;) +# Wrap old request handlers. sub everything { - clean(); - cgi_init(); - start(); + require PLP::Backend::CGI; + PLP::Backend::CGI::everything(); } - -# This is the mod_perl handler. sub handler { - require Apache::Constants; - clean(); - if (my $ret = mod_perl_init($_[0])) { - return $ret; - } - #S start($_[0]); - start(); - no strict 'subs'; - return Apache::Constants::OK(); -} - -# mod_perl initializer: returns 0 on success, Apache error code on failure -sub mod_perl_init { - our $r = shift; - - $PLP::print = 'PLP::mod_perl_print'; - - $ENV{PLP_FILENAME} = my $filename = $r->filename; - - unless (-f $filename) { - return Apache::Constants::NOT_FOUND(); - } - unless (-r _) { - return Apache::Constants::FORBIDDEN(); - } - - $ENV{PLP_NAME} = $r->uri; - - our $use_cache = $r->dir_config('PLPcache') !~ /^off$/i; -#S our $use_safe = $r->dir_config('PLPsafe') =~ /^on$/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 -} - -# FAST printing under mod_perl -sub mod_perl_print { - return unless grep length, @_; - PLP::sendheaders() unless $PLP::sentheaders; - $PLP::r->print(@_); + require PLP::Backend::Apache; + PLP::Backend::Apache::handler(@_); } # Sends the headers waiting in %PLP::Script::header sub sendheaders () { - $PLP::sentheaders ||= [ caller 1 ? (caller 1)[1, 2] : (caller)[1, 2] ]; - print STDOUT "Content-Type: text/plain\n\n" if $PLP::DEBUG & 2; - print STDOUT map("$_: $PLP::Script::header{$_}\n", keys %PLP::Script::header), "\n"; + $PLP::sentheaders ||= [ caller 1 ? (caller 1)[1, 2] : (caller)[1, 2] ]; + print STDOUT "Content-Type: text/plain\n\n" if $PLP::DEBUG & 2; + print STDOUT map("$_: $PLP::Script::header{$_}\n", keys %PLP::Script::header), "\n"; } { - my %cached; # Conceal cached sources: ( path => [ [ deps ], source, -M ] ) - - # 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 ($file, $level, $linespec, $path) = @_; - our $use_cache; - - # $file is displayed, $path is used. $path is constructed from $file if - # not given. - - $level = 0 unless defined $level; - $linespec = '1' unless defined $linespec; + my %cached; # Conceal cached sources: ( path => [ [ deps ], source, -M ] ) - 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];}; - } + # 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 ($file, $level, $linespec, $path) = @_; + our $use_cache; + + # $file is displayed, $path is used. $path is constructed from $file if + # not given. + + $level = 0 unless defined $level; + $linespec = '1' unless 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];}; + } - my $in_block = 0; # 1 => "<:", 2 => "<:=" - - $path ||= File::Spec->rel2abs($file); - - my $source_start = $level - ? qq/\cQ;\n#line 1 "$file"\n$PLP::print q\cQ/ - : qq/\n#line 1 "$file"\n$PLP::print 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] }; + my $in_block = 0; # 1 => "<:", 2 => "<:=" + + $path ||= File::Spec->rel2abs($file); + + my $source_start = $level + ? qq/\cQ;\n#line 1 "$file"\n$PLP::print q\cQ/ + : qq/\n#line 1 "$file"\n$PLP::print 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"; + } } - return $level - ? $source_start . $cached{$path}[1] - : $source_start . $cached{$path}[1] . "\cQ"; - } - } - $cached{$path} = [ [ ], undef, undef ] if $use_cache; - - my $linenr = 0; - my $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 $in_block) { + $in_block = 2; + $source .= "\cQ, ("; + } elsif ($part eq '<:' and not $in_block) { + $in_block = 1; + $source .= "\cQ; "; + } elsif ($part eq ':>' and $in_block) { + $source .= ( + $in_block == 2 + ? "), q\cQ" # 2 + : "; $PLP::print q\cQ" # 1 + ); + $in_block = 0; + } elsif ($part =~ /^<$(.*?)$>\z/ and not $in_block) { + my $ipath = File::Spec->rel2abs( + $1, File::Basename::dirname($path) + ); + $source .= source($1, $level + 1, undef, $ipath) . + qq/\cQ, \n#line $linenr "$file"\nq\cQ/; + push @{ $cached{$path}[0] }, $ipath; + } else { + $part =~ s/\\/\\\\/ unless $in_block; + $source .= $part; + } + } + } + + if ($in_block) { + $source .= ( + $in_block == 2 + ? "), q\cQ" # 2 + : "; $PLP::print q\cQ" # 1 + ); + } - 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 $in_block) { - $in_block = 2; - $source .= "\cQ, ("; - } elsif ($part eq '<:' and not $in_block) { - $in_block = 1; - $source .= "\cQ; "; - } elsif ($part eq ':>' and $in_block) { - $source .= ( - $in_block == 2 - ? "), q\cQ" # 2 - : "; $PLP::print q\cQ" # 1 - ); - $in_block = 0; - } elsif ($part =~ /^<$(.*?)$>\z/ and not $in_block) { - my $ipath = File::Spec->rel2abs( - $1, File::Basename::dirname($path) - ); - $source .= source($1, $level + 1, undef, $ipath) . - qq/\cQ, \n#line $linenr "$file"\nq\cQ/; - push @{ $cached{$path}[0] }, $ipath; - } else { - $part =~ s/\\/\\\\/ unless $in_block; - $source .= $part; + if ($use_cache) { + $cached{$path}[1] = $source; + $cached{$path}[2] = -M $path; } - } - } - - if ($in_block) { - $source .= ( - $in_block == 2 - ? "), q\cQ" # 2 - : "; $PLP::print q\cQ" # 1 - ); - } - if ($use_cache) { - $cached{$path}[1] = $source; - $cached{$path}[2] = -M $path; + return $level + ? $source_start . $source + : $source_start . $source . "\cQ"; } - - return $level - ? $source_start . $source - : $source_start . $source . "\cQ"; - } } # Let the games begin! No lexicals may exist at this point. sub start { - no strict; - tie *PLPOUT, 'PLP::Tie::Print'; - select PLPOUT; - $PLP::ERROR = \&_default_error; - - PLP::Fields::doit(); - { - package PLP::Script; - use vars qw(%headers %header %cookies %cookie %get %post %fields); - *headers = \%header; - *cookies = \%cookie; - PLP::Functions->import(); - - # No lexicals may exist at this point. - - eval qq{ package PLP::Script; $PLP::code; }; - PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/; - - eval { package PLP::Script; $_->() for reverse @PLP::END }; - PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/; - } - PLP::sendheaders() unless $PLP::sentheaders; - select STDOUT; - undef *{"PLP::Script::$_"} for keys %PLP::Script::; - # Symbol::delete_package('PLP::Script'); - # The above does not work. TODO - find out why not. + no strict; + tie *PLPOUT, 'PLP::Tie::Print'; + select PLPOUT; + $PLP::ERROR = \&_default_error; + + PLP::Fields::doit(); + { + package PLP::Script; + use vars qw(%headers %header %cookies %cookie %get %post %fields); + *headers = \%header; + *cookies = \%cookie; + PLP::Functions->import(); + + # No lexicals may exist at this point. + + eval qq{ package PLP::Script; $PLP::code; }; + PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/; + + eval { package PLP::Script; $_->() for reverse @PLP::END }; + PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/; + } + PLP::sendheaders() unless $PLP::sentheaders; + select STDOUT; + undef *{"PLP::Script::$_"} for keys %PLP::Script::; + # Symbol::delete_package('PLP::Script'); + # The above does not work. TODO - find out why not. } 1; @@ -344,47 +256,30 @@ PLP - Perl in HTML pages =head1 SYNOPSIS -=head2 mod_perl installation +=head2 Lighttpd installation -=over 10 +F configuration using L: -=item * httpd.conf (for mod_perl setup) + server.modules = ( + "mod_fastcgi", + ) + fastcgi.server = ( + ".plp" => (( + "bin-path" => "/usr/bin/perl -MPLP::Backend::FastCGI", + "socket" => "/tmp/fcgi-plp.socket", + )), + ) + +=head2 Apache installation + +F for a L setup: SetHandler perl-script - PerlHandler PLP + PerlHandler PLP::Backend::Apache PerlSendHeader On - PerlSetVar PLPcache On - # Who said CGI was easier to set up? :) - -=back - -=head2 CGI installation - -=over 10 - -=item * /foo/bar/plp.cgi (local filesystem address) - - #!/usr/bin/perl - use PLP; - PLP::everything(); - -=item * httpd.conf (for CGI setup) - - ScriptAlias /foo/bar/ /PLP_COMMON/ - - AllowOverride None - Options +ExecCGI - Order allow,deny - Allow from all - - AddHandler plp-document plp - Action plp-document /PLP_COMMON/plp.cgi - -=back - =head2 Test script (test.plp) @@ -397,8 +292,33 @@ PLP - Perl in HTML pages PLP is yet another Perl embedder, primarily for HTML documents. Unlike with other Perl embedders, there is no need to learn a meta-syntax or object -model: one can just use the normal Perl constructs. PLP runs under mod_perl -for speeds comparable to those of PHP, but can also be run as a CGI script. +model: one can just use the normal Perl constructs. PLP runs under +L and L +for speeds comparable to those of PHP, but can also be run as a standard +L script. + +=head2 Setup + +See either +L, +L (recommended) +or L. +At least the following servers are supported: + +=over 10 + +=item Lighttpd + +With L or L. + +=item Apache + +Either version 1 or 2. Using +L, +L, +or L. + +=back =head2 PLP Syntax @@ -422,7 +342,7 @@ Includes a dynamic expression in your document. The expression is evaluated in list context. Please note that the expression should not end a statement: avoid semi-colons. No whitespace may be between C<< <: >> and the equal sign. -C<< foo <:= $bar :> $baz >> is like C<< <: print 'foo ', $bar, ' baz'; :> >>. +C<< foo <:= $bar :> $baz >> is like C<< <: print 'foo ', $bar, ' $baz'; :> >>. =item C<< <(filename)> >> @@ -478,20 +398,6 @@ These are described in L. =back -=head2 (mod_perl only) PerlSetVar configuration directives - -=over 22 - -=item PLPcache - -Sets caching B/B. When caching, PLP saves your script in memory and -doesn't re-read and re-parse it if it hasn't changed. PLP will use more memory, -but will also run 50% faster. - -B is default, anything that isn't =~ /^off$/i is considered On. - -=back - =head2 Things that you should know about Not only syntax is important, you should also be aware of some other important @@ -513,7 +419,7 @@ else. Because the interpreter that mod_perl uses never ends, C blocks won't work properly. You should use C instead. Note that this is a not a built-in construct, so it needs proper termination with a semi-colon (as do - and ). +C and C). Under mod_perl, modules are loaded only once. A good modular design can improve performance because of this, but you will have to B the modules