X-Git-Url: http://git.shiar.net/perl/plp/.git/blobdiff_plain/0f5e78a789961923b45cae1a881c655fff9e7283..4cbac41f4d1bef193cf955c6c854c8a9ed258119:/PLP.pm diff --git a/PLP.pm b/PLP.pm index 7d3bf99..03b5b92 100644 --- a/PLP.pm +++ b/PLP.pm @@ -2,7 +2,7 @@ package PLP; # Not to be used without the CGI script; -our $VERSION = '3.00'; +our $VERSION = '3.06'; use PLP::Functions (); use PLP::Fields; @@ -10,14 +10,44 @@ use PLP::Tie::Headers; use PLP::Tie::Delay; use PLP::Tie::Print; -sub SendHeaders () { +=head1 PLP + +None of the functions in this module should be called by PLP scripts. + +Functions: + +=over 10 + +=item sendheaders + +Sends the headers waiting in %PLP::Script::header + +=item source + +Given a filename and optional level (level should be C<0> if it isn't called +by C itself), and optional linespec (used by C), +parses a PLP file and returns Perl code, ready to be eval'ed. + +=item error + +Given a description OR number, returns a piece of HTML, OR prints error headers. + +=item start + +Inits everything, reads the first file, sets environment. + +=cut + +sub sendheaders () { our $sentheaders = 1; print STDOUT "Content-Type: text/plain\n\n" if $DEBUG & 2; print STDOUT map("$_: $PLP::Script::header{$_}\n", keys %PLP::Script::header), "\n"; }; sub source { - my ($path, $level) = @_; + 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 @@ -25,9 +55,9 @@ sub source { : qq/\n#line 1 "$file"\nprint q\cQ/; my $linenr = 0; local *SOURCE; - open SOURCE, $path or return $level + open SOURCE, '<', $path or return $level ? qq{\cQ; die qq[Can't open "\Q$path\E" (\Q$!\E)]; print q\cQ} - : qq{\ndie qq[Can't open "\Q$path\e" (\Q$!\E)];}; + : qq{\n#line $linespec\ndie qq[Can't open "\Q$path\E" (\Q$!\E)];}; LINE: while (defined (my $line = )) { $linenr++; for (;;) { @@ -68,5 +98,86 @@ sub source { return $source; } +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

\n$ENV{SERVER_SIGNATURE}"; + } +} + +sub _default_error { + my ($plain, $html) = @_; + print qq{
}, + qq{Debug information:
$html
}; +} + +sub start { + my $file = $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"; + + if (exists $ENV{MOD_PERL}) { + Apache->request->uri($ENV{REQUEST_URI}); + print STDOUT "Status: 404 Not Found"; + Apache::exit(); + } else { + PLP::error(undef, 404); + exit; + } + } + my $pi = $1; + $ENV{PLP_NAME} =~ s/\Q$pi\E$//; + $path_info = $pi . $path_info; + } + + if (exists $ENV{MOD_PERL}) { + Apache->request->uri($ENV{REQUEST_URI}); + } + + if (not -r $file) { + print STDERR "PLP: Can't read: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n"; + if (exists $ENV{MOD_PERL}) { + print STDOUT "Status: 403 Forbidden"; + Apache::exit(); + } else { + 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); + + tie *PLPOUT, 'PLP::Tie::Print'; + select PLPOUT; + $PLP::ERROR = \&_default_error; +} + 1;