PLP.pm

   1 package PLP;
   2
   3 # Not to be used without the CGI script;
   4
   5 our $VERSION = '3.01';
   6
   7 use PLP::Functions ();
   8 use PLP::Fields;
   9 use PLP::Tie::Headers;
  10 use PLP::Tie::Delay;
  11 use PLP::Tie::Print;
  12
  13 sub SendHeaders () {
  14     our $sentheaders = 1;
  15     print STDOUT "Content-Type: text/plain\n\n" if $DEBUG & 2;
  16     print STDOUT map("$_: $PLP::Script::header{$_}\n", keys %PLP::Script::header), "\n";
  17 };
  18
  19 sub source {
  20     my ($path, $level, $linespec) = @_;
  21     $level = 0 if not defined $level;
  22     $linespec = '1' if not defined $linespec;
  23     our ($inA, $inB);
  24     (my $file = $path) =~ s[.*/][];
  25     my $source = $level
  26         ? qq/\cQ;\n#line 1 "$file"\nprint q\cQ/
  27         : qq/\n#line 1 "$file"\nprint q\cQ/;
  28     my $linenr = 0;
  29     local *SOURCE;
  30     open SOURCE, $path or return $level
  31         ? qq{\cQ; die qq[Can't open "\Q$path\E" (\Q$!\E)]; print q\cQ}
  32         : qq{\n#line $linespec\ndie qq[Can't open "\Q$path\E" (\Q$!\E)];};
  33     LINE: while (defined (my $line = <SOURCE>)) {
  34         $linenr++;
  35         for (;;) {
  36             $line =~ /
  37                 \G                  # Begin where left off
  38                 ( \z                # End
  39                 | <:=? | :>         # PLP tags     <:=? ... :>
  40                 | <\(.*?\)>         # Include tags <(...)>
  41                 | <[^:(][^<:]*      # Normal text
  42                 | :[^>][^<:]*       # Normal text
  43                 | [^<:]*            # Normal text
  44                 )
  45             /gxs;
  46             next LINE unless length $1;
  47             my $part = $1;
  48             if ($part eq '<:=' and not $inA || $inB) {
  49                 $inA = 1;
  50                 $source .= "\cQ, ";
  51             } elsif ($part eq '<:' and not $inA || $inB) {
  52                 $inB = 1;
  53                 $source .= "\cQ; ";
  54             } elsif ($part eq ':>' and $inA) {
  55                 $inA = 0;
  56                 $source .= ", q\cQ";
  57             } elsif ($part eq ':>' and $inB) {
  58                 $inB = 0;
  59                 $source .= "; print q\cQ";
  60             } elsif ($part =~ /^<\((.*?)\)>\z/ and not $inA || $inB) {
  61                 $source .= source($1, $level + 1) .
  62                            qq/\cQ, \n#line $linenr "$file"\nq\cQ/;
  63             } else {
  64                 $part =~ s/\\/\\\\/ if not $inA || $inB;
  65                 $source .= $part;
  66             }
  67         }
  68     }
  69     $source .= "\cQ" unless $level;
  70     return $source;
  71 }
  72
  73 sub error {
  74     my ($error, $type) = @_;
  75     if (not defined $type or $type < 100) {
  76         PLP::sendheaders unless $PLP::sentheaders;
  77         $error =~ s/([<&>])/'&#' . ord($1) . ';'/ge;
  78         print qq{<table border=1 class="PLPerror"><tr><td>},
  79               qq{<span><b>Debug information:</b><BR>$error</td></tr></table>};
  80     } else {
  81         select STDOUT;
  82         my ($short, $long) = @{ +{
  83             404 => [ 'Not Found', "The requested URL $ENV{REQUEST_URI} was not found on this server." ],
  84             403 => [ 'Forbidden', "You don't have permission to access $ENV{REQUEST_URI} on this server." ],
  85         }->{$type} };
  86         print "Status: $type\nContent-Type: text/html\n\n",
  87               qq{<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">\n},
  88               "<html><head>\n<title>--$type $short</title>\n</head></body>\n",
  89               "<h1>$short</h1>\n$long<p>\n<hr>\n$ENV{SERVER_SIGNATURE}</body></html>";
  90     }
  91 }
  92
  93 1;
  94