+use File::Basename ();
+use File::Spec;
+#use Cwd ();
+
+use strict;
+
+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
+# Change the CWD
+
+# This gets referenced as the initial $PLP::ERROR
+sub _default_error {
+ my ($plain, $html) = @_;
+ print qq{<table border=1 class="PLPerror"><tr><td>},
+ qq{<b>Debug information:</b><br>$html</td></tr></table>};
+}
+
+# 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);
+}
+
+# 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 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{<!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 is run by the CGI script. (#!perl \n 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($_[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(@_);
+}
+
+# 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';
+ 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/;