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 return undef unless $PLP::DEBUG & 1;
106 (my $html = $plain) =~ s/([<&>])/'&#' . ord($1) . ';'/ge;
107 PLP::sendheaders unless $PLP::sentheaders;
108 $PLP::ERROR->($plain, $html);
111 my ($short, $long) = @{ +{
112 404 => [ 'Not Found', "The requested URL $ENV{REQUEST_URI} was not found on this server." ],
113 403 => [ 'Forbidden', "You don't have permission to access $ENV{REQUEST_URI} on this server." ],
115 print "Status: $type\nContent-Type: text/html\n\n",
116 qq{<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">\n},
117 "<html><head>\n<title>--$type $short</title>\n</head></body>\n",
118 "<h1>$short</h1>\n$long<p>\n<hr>\n$ENV{SERVER_SIGNATURE}</body></html>";
123 my ($plain, $html) = @_;
124 print qq{<table border=1 class="PLPerror"><tr><td>},
125 qq{<span><b>Debug information:</b><BR>$html</td></tr></table>};
129 my $file = $ENV{PATH_TRANSLATED};
130 $ENV{PLP_NAME} = $ENV{PATH_INFO};
132 while (not -f $file) {
133 if (not $file =~ s/(\/+[^\/]*)$//) {
134 print STDERR "PLP: Not found: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
136 if (exists $ENV{MOD_PERL}) {
137 Apache->request->uri($ENV{REQUEST_URI});
138 print STDOUT "Status: 404 Not Found";
141 PLP::error(undef, 404);
146 $ENV{PLP_NAME} =~ s/\Q$pi\E$//;
147 $path_info = $pi . $path_info;
150 if (exists $ENV{MOD_PERL}) {
151 Apache->request->uri($ENV{REQUEST_URI});
155 print STDERR "PLP: Can't read: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
156 if (exists $ENV{MOD_PERL}) {
157 print STDOUT "Status: 403 Forbidden";
160 PLP::error(undef, 403);
166 qw(PATH_TRANSLATED SCRIPT_NAME SCRIPT_FILENAME PATH_INFO),
167 grep { /^REDIRECT_/ } keys %ENV
170 $ENV{PATH_INFO} = $path_info if defined $path_info;
171 $ENV{PLP_FILENAME} = $file;
172 (my $dir = $file) =~ s{/[^/]+$}[];
175 $PLP::code = PLP::source($file, 0);
177 tie *PLPOUT, 'PLP::Tie::Print';
179 $PLP::ERROR = \&_default_error;