+# 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 };
+}
+
+# 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;
+ }
+
+ 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);
+}
+
+# This is the mod_perl initializer.
+# Returns 0 on success.
+sub mod_perl_init {
+ my $r = shift;
+
+ $ENV{PLP_FILENAME} = my $filename = $r->filename;
+
+ unless (-f $filename) {
+ return Apache::Constants::NOT_FOUND;
+ }
+ unless (-r _) {
+ return Apache::Constants::FORBIDDEN;
+ }
+
+ (my $dir) = $filename =~ m!(.*)/!s;
+ chdir $dir;
+ $ENV{PLP_NAME} = $r->uri;
+ $PLP::code = PLP::source($r->filename);
+
+ return 0; # OK
+}
+
+# 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;
+ *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');
+}
+
+# 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();
+ return Apache::Constants::OK;
+}
+