X-Git-Url: http://git.shiar.nl/perl/plp/.git/blobdiff_plain/6fb22c399428a8e7cac088cab5603e75a87016fa..4cbac41f4d1bef193cf955c6c854c8a9ed258119:/PLP.pm?ds=inline

diff --git a/PLP.pm b/PLP.pm
index 704870c..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.01';
+our $VERSION = '3.06';
 
 use PLP::Functions ();
 use PLP::Fields;
@@ -10,7 +10,35 @@ 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<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";
@@ -27,7 +55,7 @@ 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{\n#line $linespec\ndie qq[Can't open "\Q$path\E" (\Q$!\E)];};
     LINE: while (defined (my $line = <SOURCE>)) {
@@ -73,10 +101,11 @@ sub 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;
-	$error =~ s/([<&>])/'&#' . ord($1) . ';'/ge;
-	print qq{<table border=1 class="PLPerror"><tr><td>},
-	      qq{<span><b>Debug information:</b><BR>$error</td></tr></table>};
+	$PLP::ERROR->($plain, $html);
     } else {
 	select STDOUT;
 	my ($short, $long) = @{ +{
@@ -90,5 +119,65 @@ sub 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>};
+}
+
+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;