-#--------------#
- package PLP;
-#--------------#
+package PLP;
-use v5.6;
+use 5.006;
use PLP::Functions ();
use PLP::Fields;
use PLP::Tie::Delay;
use PLP::Tie::Print;
+use File::Basename ();
+use File::Spec;
+#use Cwd ();
+
use strict;
-our $VERSION = '3.13';
+our $VERSION = '3.19';
-# subs in this package:
-# sendheaders Send headers
-# source($path, $level, $linespec) Read and parse .plp files
-# error($error, $type) Handle errors
+# Subs in this package:
# _default_error($plain, $html) Default error handler
-# clean Reset variables
# cgi_init Initialization for CGI
-# mod_perl_init($r) Initialization for mod_perl
-# start Start the initialized PLP script
+# 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
+# Change the CWD
-# Sends the headers waiting in %PLP::Script::header
-sub sendheaders () {
- our $sentheaders = 1;
- print STDOUT "Content-Type: text/plain\n\n" if $PLP::DEBUG & 2;
- print STDOUT map("$_: $PLP::Script::header{$_}\n", keys %PLP::Script::header), "\n";
-};
-
-# 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 $source = $level
- ? qq/\cQ;\n#line 1 "$file"\nprint q\cQ/
- : qq/\n#line 1 "$file"\nprint q\cQ/;
- my $linenr = 0;
-
- 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)];};
+# This gets referenced as the initial $PLP::ERROR
+sub _default_error {
+ my ($plain, $html) = @_;
+ print qq{<table border=1 class="PLPerror"><tr><td>},
+ qq{<span><b>Debug information:</b><BR>$html</td></tr></table>};
+}
+
+# CGI initializer: parses PATH_TRANSLATED
+sub cgi_init {
+
+ $PLP::print = 'print';
- 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;
- }
+ 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;
}
- $source .= "\cQ" unless $level;
- return $source;
+ 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);
+}
+
+# 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 };
}
-# Handles errors, uses the sub reference $PLP::ERROR that gets two arguments:
-# the error message in plain text, and the error message with html entities
+# 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::sendheaders() unless $PLP::sentheaders;
$PLP::ERROR->($plain, $html);
} else {
select STDOUT;
+{
404 => [
'Not Found',
- "The requested URL $ENV{REQUEST_URI} was not found on this server."
+ "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."
+ "You don't have permission to access $ENV{REQUEST_URI} " .
+ "on this server."
],
}->{$type}
};
print "Status: $type\nContent-Type: text/html\n\n",
- qq{<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">\n},
- "<html><head>\n<title>--$type $short</title>\n</head></body>\n",
- "<
h1>$short</h1>\n$long<p>\n<hr>\n$ENV{SERVER_SIGNATURE}</body></html>";
+ qq{<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">\n<html>},
+ "<head>\n<title>$type $short</title>\n</head></body>\n<h1>$short",
+ "</h1>\n$long<p>\n<hr>\n$ENV{SERVER_SIGNATURE}</body></html>";
}
}
-# This gets referenced as the initial $PLP::ERROR
-sub _default_error {
- my ($plain, $html) = @_;
- print qq{<table border=1 class="PLPerror"><tr><td>},
- qq{<span><b>Debug information:</b><BR>$html</td></tr></table>};
-}
-
-# This cleans up from previous requests, and sets the default $PLP::DEBUG
-sub clean {
- @PLP::END = ();
- $PLP::code = '';
- $PLP::sentheaders = 0;
- $PLP::inA = 0;
- $PLP::inB = 0;
- $PLP::DEBUG = 1;
- delete @ENV{ grep /^PLP_/, keys %ENV };
+# This is run by the CGI script. (#!perl \n use PLP; PLP::everything;)
+sub everything {
+ clean();
+ cgi_init();
+ start();
}
-# The *_init subs do the following:
-# o Set $PLP::code to the initial code
-# o Set $ENV{PLP_*} and makes PATH_INFO if needed
-# o Change the CWD
-
-# 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};
- $ENV{PLP_NAME} = $ENV{PATH_INFO};
- my $path_info;
- while (not -f $file) {
- if (not $file =~ 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 $file) {
- print STDERR "PLP: Can't read: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
- PLP::error(undef, 403);
- exit;
+# This is the mod_perl handler.
+sub handler {
+ require Apache::Constants;
+ clean();
+ if (my $ret = mod_perl_init($_[0])) {
+ return $ret;
}
-
- 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} = $file;
- (my $dir = $file) =~ s{/[^/]+$}[];
- chdir $dir;
-
- $PLP::code = PLP::source($file, 0);
+ #S start($_[0]);
+ start();
+ no strict 'subs';
+ return Apache::Constants::OK();
}
-# This is the mod_perl initializer.
-# Returns 0 on success.
+# mod_perl initializer: returns 0 on success, Apache error code on failure
sub mod_perl_init {
- my $r = shift;
+ our $r = shift;
+
+ $PLP::print = 'PLP::mod_perl_print';
$ENV{PLP_FILENAME} = my $filename = $r->filename;
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;
+#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
}
-# Let the games begin!
-# No lexicals may exist at this point.
+# FAST printing under mod_perl
+sub mod_perl_print {
+ return unless grep length, @_;
+ PLP::sendheaders() unless $PLP::sentheaders;
+ $PLP::r->print(@_);
+}
+
+# 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";
+}
+
+{
+ 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;
+
+ 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] };
+ }
+ 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 = '';
+
+ 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 $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
+ );
+ }
+
+ if ($use_cache) {
+ $cached{$path}[1] = $source;
+ $cached{$path}[2] = -M $path;
+ }
+
+ 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';
*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.
-}
-
-# This is run by the CGI script.
-# The CGI script is just:
-# #!/usr/bin/perl
-# use PLP;
-# PLP::everything();
-sub everything {
- clean();
- cgi_init();
- start();
-}
-
-# This is the mod_perl handler.
-sub handler {
- require Apache::Constants;
- clean();
- if (my $ret = mod_perl_init(shift)) {
- return $ret;
- }
- start();
- no strict 'subs';
- return Apache::Constants::OK();
+ # Symbol::delete_package('PLP::Script');
+ # The above does not work. TODO - find out why not.
}
1;
SetHandler perl-script
PerlHandler PLP
PerlSendHeader On
+ PerlSetVar PLPcache On
</Files>
# Who said CGI was easier to set up? :)
ScriptAlias /foo/bar/ /PLP_COMMON/
<Directory /foo/bar/>
- AllowOverride None
- Options +ExecCGI
- Order allow,deny
- Allow from all
+ AllowOverride None
+ Options +ExecCGI
+ Order allow,deny
+ Allow from all
</Directory>
AddHandler plp-document plp
Action plp-document /PLP_COMMON/plp.cgi
Includes another file before the PLP code is executed. The file is included
literally, so it shares lexical variables. Because this is a compile-time tag,
it's fast, but you can't use a variable as the filename. You can create
-recursive includes, so beware of that! Whitespace in the filename is not
-ignored so C<< <( foo.txt)> >> includes the file named C< foo.txt>, including
-the space in its name. A compile-time alternative is include(), which is
-described in L<PLP::Functions>.
+recursive includes, so beware! (PLP will catch simple recursion: the maximum
+depth is 128.) Whitespace in the filename is not ignored so C<< <( foo.txt)> >>
+includes the file named C< foo.txt>, including the space in its name. A
+
compile-time alternative is include(), which is described in L<PLP::Functions>.
=back
=back
+=head2 (mod_perl only) PerlSetVar configuration directives
+
+=over 22
+
+=item PLPcache
+
+Sets caching B<On>/B<Off>. 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<On> 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
any output. This means the opening C<< <: >> have to be the first characters in
your document, without any whitespace in front of them. If you start output and
try to set headers later, an error message will appear telling you on which
-line your output started.
+line your output started. An alternative way of setting headers is using Perl's
+BEGIN blocks. BEGIN blocks are executed as soon as possible, before anything
+else.
Because the interpreter that mod_perl uses never ends, C<END { }> blocks won't
work properly. You should use C<PLP_END { };> instead. Note that this is a not
especially when mixed with modules that expect normal CGI environments, like
CGI.pm. Read L<PLP::Fields> for information more about this.
-=head1 WEBSITE
-
-For now, all documentation is on the website. Everything will be POD one day,
-but until that day, you will need to visit http://plp.juerd.nl/
-
-=head1 FAQ
+=head1 FAQ and HowTo
A lot of questions are asked often, so before asking yours, please read the
-FAQ at L<PLP::FAQ>.
+FAQ at L<PLP::FAQ>. Some examples can be found at L<PLP::HowTo>.
=head1 NO WARRANTY
No warranty, no guarantees. Use PLP at your own risk, as I disclaim all
responsibility.
-=head1 AUTHOR
+=head1 AUTHORS
+
+Currently maintained by Mischa POSLAWSKY <perl@shiar.org>
+
+Originally by Juerd Waalboer <juerd@cpan.org>
+
+=head1 SEE ALSO
-Juerd Waalboer <juerd@juerd.nl>
+L<PLP::Functions>, L<PLP::Fields>, L<PLP::FAQ>, L<PLP::HowTo>
=cut
+### Garbage bin
+
+# About the #S lines:
+# I wanted to implement Safe.pm so that scripts were run inside a
+# configurable compartment. This needed for XS modules to be pre-loaded,
+# hence the PLPsafe_* Apache directives. However, $safe->reval() lets
+# Apache segfault. End of fun. The lines are still here so that I can
+# s/^#S //g to re-implement them whenever this has been fixed.
+
+#S # For PLPsafe scripts
+#S sub safe_eval {
+#S my ($r, $code) = @_;
+#S $r->send_http_header('text/plain');
+#S require Safe;
+#S unless ($PLP::safe) {
+#S $PLP::safe = Safe->new('PLP::Script');
+#S for ( map split, $r->dir_config->get('PLPsafe_module') ) {
+#S $PLP::safe->share('*' . $_ . '::');
+#S s!::!/!g;
+#S require $_ . '.pm';
+#S }
+#S $PLP::safe->permit(Opcode::full_opset());
+#S $PLP::safe->deny(Opcode::opset(':dangerous'));
+#S }
+#S $PLP::safe->reval($code);
+#S }
+#S my ($r) = @_;
+
+# start()
+#S if ($PLP::use_safe) {
+#S PLP::safe_eval($r, $PLP::code);
+#S } else {
+# eval qq{ package PLP::Script; $PLP::code; };
+#S }
+# PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/;
+#S if ($PLP::use_safe) {
+#S PLP::safe_eval($r, '$_->() for reverse @PLP::END');
+#S } else {
+# eval { package PLP::Script; $_->() for reverse @PLP::END };
+#S }
+# PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/;
+
+###
git.shiar.nl / perl / plp / .git / blobdiff