X-Git-Url: http://git.shiar.net/perl/plp/.git/blobdiff_plain/7e6bbd1c2d57c1129f58d79e21943a26e931c0d3..df5933195f9dbe0fc69a1bd9752b84f267e4ec06:/PLP.pm
diff --git a/PLP.pm b/PLP.pm
index 2df9c3b..a190e3b 100644
--- a/PLP.pm
+++ b/PLP.pm
@@ -1,6 +1,6 @@
package PLP;
-use v5.6;
+use 5.006;
use PLP::Functions ();
use PLP::Fields;
@@ -8,103 +8,96 @@ use PLP::Tie::Headers;
use PLP::Tie::Delay;
use PLP::Tie::Print;
-#use strict;
+use File::Basename ();
+use File::Spec;
+#use Cwd ();
-our $VERSION = '3.10';
+use strict;
-# subs in this package:
-# sendheaders Send headers
-# source($path, $level, $linespec) Read and parse .plp files
-# error($error, $type) Handle errors
+our $VERSION = '3.18';
+
+# Subs in this package:
# _default_error($plain, $html) Default error handler
-# clean Reset variables
# cgi_init Initialization for CGI
-# mod_perl_init($r) Initialization for mod_perl
-# start Start the initialized PLP script
+# 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
-# Sends the headers waiting in %PLP::Script::header
-sub sendheaders () {
- our $sentheaders = 1;
- print STDOUT "Content-Type: text/plain\n\n" if $PLP::DEBUG & 2;
- print STDOUT map("$_: $PLP::Script::header{$_}\n", keys %PLP::Script::header), "\n";
-};
-
-# 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 ($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/\cQ;\n#line 1 "$file"\nprint q\cQ/
- : qq/\n#line 1 "$file"\nprint q\cQ/;
- my $linenr = 0;
-
- 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)];};
+# This gets referenced as the initial $PLP::ERROR
+sub _default_error {
+ my ($plain, $html) = @_;
+ print qq{
},
+ qq{Debug information: $html |
};
+}
+
+# CGI initializer: parses PATH_TRANSLATED
+sub cgi_init {
+
+ $PLP::print = 'print';
- LINE:
- while (defined (my $line = )) {
- $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 $inA || $inB) {
- $inA = 1;
- $source .= "\cQ, ";
- } elsif ($part eq '<:' and not $inA || $inB) {
- $inB = 1;
- $source .= "\cQ; ";
- } elsif ($part eq ':>' and $inA) {
- $inA = 0;
- $source .= ", q\cQ";
- } elsif ($part eq ':>' and $inB) {
- $inB = 0;
- $source .= "; print q\cQ";
- } elsif ($part =~ /^<\((.*?)\)>\z/ and not $inA || $inB) {
- $source .= source($1, $level + 1) .
- qq/\cQ, \n#line $linenr "$file"\nq\cQ/;
- } else {
- $part =~ s/\\/\\\\/ if not $inA || $inB;
- $source .= $part;
- }
+ 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;
}
- $source .= "\cQ" unless $level;
+
+ 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;
- return $source;
+ $PLP::code = PLP::source($file, 0, undef, $path);
}
-# Handles errors, uses the sub reference $PLP::ERROR that gets two arguments:
-# the error message in plain text, and the error message with html entities
+# 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::sendheaders() unless $PLP::sentheaders;
$PLP::ERROR->($plain, $html);
} else {
select STDOUT;
@@ -112,104 +105,208 @@ sub error {
+{
404 => [
'Not Found',
- "The requested URL $ENV{REQUEST_URI} was not found on this server."
+ "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."
+ "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}