-
-# 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
-{
- my %cached; # Conceal cached sources
-
- # %cached = (
- # $filename => [
- # [ dependency, dependency, dependency ], # <(...)>
- # 'source',
- # -M
- # ]
- # );
-
- sub source {
- my ($file, $level, $linespec, $path) = @_;
- $level = 0 if not defined $level;
- $linespec = '1' if not defined $linespec;
-
- if ($level > 128) {
- %cached = ();
- return $level
- ? qq{\cQ; die qq[Include recursion detected]; print q\cQ}
- : qq{\n#line $linespec\ndie qq[Include recursion detected];};
- }
-
- our ($inA, $inB, $use_cache);
- $path ||= File::Spec->rel2abs($file);
-
- my $source_start = $level
- ? qq/\cQ;\n#line 1 "$file"\nprint q\cQ/
- : qq/\n#line 1 "$file"\nprint q\cQ/;
-
- if ($use_cache and exists $cached{$path}) {
- BREAKOUT: {
- my @checkstack = ($path);
- my $item;
- my %checked;
- while (defined(my $item = shift @checkstack)) {
- next if $checked{$item};
- last BREAKOUT if $cached{$item}[2] > -M $item;
- $checked{$item} = 1;
- push @checkstack, @{ $cached{$item}[0] }
- if @{ $cached{$item}[0] };
- }
- return $level
- ? $source_start . $cached{$path}[1]
- : $source_start . $cached{$path}[1] . "\cQ";
- }
- }
-
- $cached{$path} = [ [ ], undef, undef ] if $use_cache;
-
- my $linenr = 0;
- my $source = '';
-
- 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)];};
-
- LINE:
- while (defined (my $line = <SOURCE>)) {
- $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) {
- my $ipath = File::Spec->rel2abs($1);
- $source .= source($1, $level + 1, undef, $ipath) .
- qq/\cQ, \n#line $linenr "$file"\nq\cQ/;
- push @{ $cached{$path}[0] }, $ipath;
- } else {
- $part =~ s/\\/\\\\/ if not $inA || $inB;
- $source .= $part;
- }
- }
- }
-
- if ($use_cache) {
- $cached{$path}[1] = $source;
- $cached{$path}[2] = -M $path;
- }
-
- return $level
- ? $source_start . $source
- : $source_start . $source . "\cQ";
- }
-}
-
-# 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
-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>";
- }
-}