-# 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 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
-
-# CGI initializer: parses PATH_TRANSLATED
-sub cgi_init {
- 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);
-}
-
-# mod_perl initializer: returns 0 on success, Apache error code on failure
-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();
- }
-
- $ENV{PLP_NAME} = $r->uri;
-
- our $use_cache = $r->dir_config('PLPcache') !~ /^off$/i;
- 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
-}
-
-# For PLPsafe scripts
-sub safe_eval {
- my ($r, $code) = @_;
- $r->send_http_header('text/plain');
- require Safe;
- unless ($PLP::safe) {
- $PLP::safe = Safe->new('PLP::Script');
- for ( map split, $r->dir_config->get('PLPsafe_module') ) {
- $PLP::safe->share('*' . $_ . '::');
- s!::!/!g;
- require $_ . '.pm';
- }
- $PLP::safe->permit(Opcode::full_opset());
- $PLP::safe->deny(Opcode::opset(':dangerous'));
- }
- $PLP::safe->reval($code);
-}