3 # Not to be used without the CGI script;
15 None of the functions in this module should be called by PLP scripts.
23 Sends the headers waiting in %PLP::Script::header
27 Given a filename and optional level (level should be C<0> if it isn't called
28 by C<source> itself), and optional linespec (used by C<PLP::Functions::Include>),
29 parses a PLP file and returns Perl code, ready to be eval'ed.
33 Given a description OR number, returns a piece of HTML, OR prints error headers.
37 Inits everything, reads the first file, sets environment.
43 print STDOUT "Content-Type: text/plain\n\n" if $DEBUG & 2;
44 print STDOUT map("$_: $PLP::Script::header{$_}\n", keys %PLP::Script::header), "\n";
48 my ($path, $level, $linespec) = @_;
49 $level = 0 if not defined $level;
50 $linespec = '1' if not defined $linespec;
52 (my $file = $path) =~ s[.*/][];
54 ? qq/\cQ;\n#line 1 "$file"\nprint q\cQ/
55 : qq/\n#line 1 "$file"\nprint q\cQ/;
58 open SOURCE, $path or return $level
59 ? qq{\cQ; die qq[Can't open "\Q$path\E" (\Q$!\E)]; print q\cQ}
60 : qq{\n#line $linespec\ndie qq[Can't open "\Q$path\E" (\Q$!\E)];};
61 LINE: while (defined (my $line = <SOURCE>)) {
65 \G # Begin where left off
67 | <:=? | :> # PLP tags <:=? ... :>
68 | <\(.*?\)> # Include tags <(...)>
69 | <[^:(][^<:]* # Normal text
70 | :[^>][^<:]* # Normal text
71 | [^<:]* # Normal text
74 next LINE unless length $1;
76 if ($part eq '<:=' and not $inA || $inB) {
79 } elsif ($part eq '<:' and not $inA || $inB) {
82 } elsif ($part eq ':>' and $inA) {
85 } elsif ($part eq ':>' and $inB) {
87 $source .= "; print q\cQ";
88 } elsif ($part =~ /^<\((.*?)\)>\z/ and not $inA || $inB) {
89 $source .= source($1, $level + 1) .
90 qq/\cQ, \n#line $linenr "$file"\nq\cQ/;
92 $part =~ s/\\/\\\\/ if not $inA || $inB;
97 $source .= "\cQ" unless $level;
102 my ($error, $type) = @_;
103 if (not defined $type or $type < 100) {
104 PLP::sendheaders unless $PLP::sentheaders;
105 $error =~ s/([<&>])/'&#' . ord($1) . ';'/ge;
106 print qq{<table border=1 class="PLPerror"><tr><td>},
107 qq{<span><b>Debug information:</b><BR>$error</td></tr></table>};
110 my ($short, $long) = @{ +{
111 404 => [ 'Not Found', "The requested URL $ENV{REQUEST_URI} was not found on this server." ],
112 403 => [ 'Forbidden', "You don't have permission to access $ENV{REQUEST_URI} on this server." ],
114 print "Status: $type\nContent-Type: text/html\n\n",
115 qq{<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">\n},
116 "<html><head>\n<title>--$type $short</title>\n</head></body>\n",
117 "<h1>$short</h1>\n$long<p>\n<hr>\n$ENV{SERVER_SIGNATURE}</body></html>";
122 my $file = $ENV{PATH_TRANSLATED};
123 $ENV{PLP_NAME} = $ENV{PATH_INFO};
125 while (not -f $file) {
126 if (not $file =~ s/(\/+[^\/]*)$//) {
127 print STDERR "PLP: Not found: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
129 if (exists $ENV{MOD_PERL}) {
130 Apache->request->uri($ENV{REQUEST_URI});
131 print STDOUT "Status: 404 Not Found";
134 PLP::error(undef, 404);
139 $ENV{PLP_NAME} =~ s/\Q$pi\E$//;
140 $path_info = $pi . $path_info;
143 if (exists $ENV{MOD_PERL}) {
144 Apache->request->uri($ENV{REQUEST_URI});
148 print STDERR "PLP: Can't read: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
149 if (exists $ENV{MOD_PERL}) {
150 print STDOUT "Status: 403 Forbidden";
153 PLP::error(undef, 403);
159 qw(PATH_TRANSLATED SCRIPT_NAME SCRIPT_FILENAME PATH_INFO),
160 grep { /^REDIRECT_/ } keys %ENV
163 $ENV{PATH_INFO} = $path_info if defined $path_info;
164 $ENV{PLP_FILENAME} = $file;
165 (my $dir = $file) =~ s{/[^/]+$}[];
168 $PLP::code = PLP::source($file, 0);
169 tie *PLPOUT, 'PLP::Tie::Print';