# Not to be used without the CGI script;
-our $VERSION = '3.00';
+our $VERSION = '3.06';
use PLP::Functions ();
use PLP::Fields;
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<source> itself), and optional linespec (used by C<PLP::Functions::Include>),
+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
: 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 = <SOURCE>)) {
$linenr++;
for (;;) {
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{<!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>";
+ }
+}
+
+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>};
+}
+
+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;
git.shiar.nl / perl / plp / .git / blobdiff