PLP.pm

   1 package PLP;
   2
   3 # Not to be used without the CGI script;
   4
   5 our $VERSION = '3.06';
   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 =head1 PLP
  14
  15 None of the functions in this module should be called by PLP scripts.
  16
  17 Functions:
  18
  19 =over 10
  20
  21 =item sendheaders
  22
  23 Sends the headers waiting in %PLP::Script::header
  24
  25 =item source
  26
  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.
  30
  31 =item error
  32
  33 Given a description OR number, returns a piece of HTML, OR prints error headers.
  34
  35 =item start
  36
  37 Inits everything, reads the first file, sets environment.
  38
  39 =cut
  40
  41 sub sendheaders () {
  42     our $sentheaders = 1;
  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";
  45 };
  46
  47 sub source {
  48     my ($path, $level, $linespec) = @_;
  49     $level = 0 if not defined $level;
  50     $linespec = '1' if not defined $linespec;
  51     our ($inA, $inB);
  52     (my $file = $path) =~ s[.*/][];
  53     my $source = $level
  54         ? qq/\cQ;\n#line 1 "$file"\nprint q\cQ/
  55         : qq/\n#line 1 "$file"\nprint q\cQ/;
  56     my $linenr = 0;
  57     local *SOURCE;
  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>)) {
  62         $linenr++;
  63         for (;;) {
  64             $line =~ /
  65                 \G                  # Begin where left off
  66                 ( \z                # End
  67                 | <:=? | :>         # PLP tags     <:=? ... :>
  68                 | <\(.*?\)>         # Include tags <(...)>
  69                 | <[^:(][^<:]*      # Normal text
  70                 | :[^>][^<:]*       # Normal text
  71                 | [^<:]*            # Normal text
  72                 )
  73             /gxs;
  74             next LINE unless length $1;
  75             my $part = $1;
  76             if ($part eq '<:=' and not $inA || $inB) {
  77                 $inA = 1;
  78                 $source .= "\cQ, ";
  79             } elsif ($part eq '<:' and not $inA || $inB) {
  80                 $inB = 1;
  81                 $source .= "\cQ; ";
  82             } elsif ($part eq ':>' and $inA) {
  83                 $inA = 0;
  84                 $source .= ", q\cQ";
  85             } elsif ($part eq ':>' and $inB) {
  86                 $inB = 0;
  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/;
  91             } else {
  92                 $part =~ s/\\/\\\\/ if not $inA || $inB;
  93                 $source .= $part;
  94             }
  95         }
  96     }
  97     $source .= "\cQ" unless $level;
  98     return $source;
  99 }
 100
 101 sub error {
 102     my ($error, $type) = @_;
 103     if (not defined $type or $type < 100) {
 104         return undef unless $PLP::DEBUG & 1;
 105         my $plain = $error;
 106         (my $html = $plain) =~ s/([<&>])/'&#' . ord($1) . ';'/ge;
 107         PLP::sendheaders unless $PLP::sentheaders;
 108         $PLP::ERROR->($plain, $html);
 109     } else {
 110         select STDOUT;
 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." ],
 114         }->{$type} };
 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>";
 119     }
 120 }
 121
 122 sub _default_error {
 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>};
 126 }
 127
 128 sub start {
 129     my $file = $ENV{PATH_TRANSLATED};
 130     $ENV{PLP_NAME} = $ENV{PATH_INFO};
 131     my $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";
 135
 136             if (exists $ENV{MOD_PERL}) {
 137                 Apache->request->uri($ENV{REQUEST_URI});
 138                 print STDOUT "Status: 404 Not Found";
 139                 Apache::exit();
 140             } else {
 141                 PLP::error(undef, 404);
 142                 exit;
 143             }
 144         }
 145         my $pi = $1;
 146         $ENV{PLP_NAME} =~ s/\Q$pi\E$//;
 147         $path_info = $pi . $path_info;
 148     }
 149
 150     if (exists $ENV{MOD_PERL}) {
 151         Apache->request->uri($ENV{REQUEST_URI});
 152     }
 153
 154     if (not -r $file) {
 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";
 158             Apache::exit();
 159         } else {
 160             PLP::error(undef, 403);
 161             exit;
 162         }
 163     }
 164
 165     delete @ENV{
 166         qw(PATH_TRANSLATED SCRIPT_NAME SCRIPT_FILENAME PATH_INFO),
 167         grep { /^REDIRECT_/ } keys %ENV
 168     };
 169
 170     $ENV{PATH_INFO} = $path_info if defined $path_info;
 171     $ENV{PLP_FILENAME} = $file;
 172     (my $dir = $file) =~ s{/[^/]+$}[];
 173     chdir $dir;
 174
 175     $PLP::code = PLP::source($file, 0);
 176
 177     tie *PLPOUT, 'PLP::Tie::Print';
 178     select PLPOUT;
 179     $PLP::ERROR = \&_default_error;
 180 }
 181
 182 1;
 183