PLP.pm

   1 package PLP;
   2
   3 use v5.6;
   4
   5 use PLP::Functions ();
   6 use PLP::Fields;
   7 use PLP::Tie::Headers;
   8 use PLP::Tie::Delay;
   9 use PLP::Tie::Print;
  10
  11 use Symbol ();
  12 #use strict;
  13
  14 our $VERSION = '3.10';
  15
  16 # subs in this package:
  17 #  sendheaders                      Send headers
  18 #  source($path, $level, $linespec) Read and parse .plp files
  19 #  error($error, $type)             Handle errors
  20 #  _default_error($plain, $html)    Default error handler
  21 #  clean                            Reset variables
  22 #  cgi_init                         Initialization for CGI
  23 #  mod_perl_init($r)                Initialization for mod_perl
  24 #  start                            Start the initialized PLP script
  25 #  everything                       Do everything: CGI
  26 #  handler($r)                      Do everything: mod_perl
  27
  28
  29 # Sends the headers waiting in %PLP::Script::header
  30 sub sendheaders () {
  31     our $sentheaders = 1;
  32     print STDOUT "Content-Type: text/plain\n\n" if $PLP::DEBUG & 2;
  33     print STDOUT map("$_: $PLP::Script::header{$_}\n", keys %PLP::Script::header), "\n";
  34 };
  35
  36 # Given a filename and optional level (level should be 0 if the caller isn't
  37 # source() itself), and optional linespec (used by PLP::Functions::Include),
  38 # this function parses a PLP file and returns Perl code, ready to be eval'ed
  39 sub source {
  40     my ($path, $level, $linespec) = @_;
  41     $level = 0      if not defined $level;
  42     $linespec = '1' if not defined $linespec;
  43
  44     our ($inA, $inB);
  45
  46     (my $file = $path) =~ s[.*/][];
  47
  48     my $source = $level
  49         ? qq/\cQ;\n#line 1 "$file"\nprint q\cQ/
  50         : qq/\n#line 1 "$file"\nprint q\cQ/;
  51     my $linenr = 0;
  52
  53     local *SOURCE;
  54     open SOURCE, '<', $path or return $level
  55         ? qq{\cQ; die qq[Can't open "\Q$path\E" (\Q$!\E)]; print q\cQ}
  56         : qq{\n#line $linespec\ndie qq[Can't open "\Q$path\E" (\Q$!\E)];};
  57
  58     LINE:
  59     while (defined (my $line = <SOURCE>)) {
  60         $linenr++;
  61         for (;;) {
  62             $line =~ /
  63                 \G                  # Begin where left off
  64                 ( \z                # End
  65                 | <:=? | :>         # PLP tags     <:= ... :> <: ... :>
  66                 | <\(.*?\)>         # Include tags <(...)>
  67                 | <[^:(][^<:]*      # Normal text
  68                 | :[^>][^<:]*       # Normal text
  69                 | [^<:]*            # Normal text
  70                 )
  71             /gxs;
  72             next LINE unless length $1;
  73             my $part = $1;
  74             if ($part eq '<:=' and not $inA || $inB) {
  75                 $inA = 1;
  76                 $source .= "\cQ, ";
  77             } elsif ($part eq '<:' and not $inA || $inB) {
  78                 $inB = 1;
  79                 $source .= "\cQ; ";
  80             } elsif ($part eq ':>' and $inA) {
  81                 $inA = 0;
  82                 $source .= ", q\cQ";
  83             } elsif ($part eq ':>' and $inB) {
  84                 $inB = 0;
  85                 $source .= "; print q\cQ";
  86             } elsif ($part =~ /^<\((.*?)\)>\z/ and not $inA || $inB) {
  87                 $source .= source($1, $level + 1) .
  88                            qq/\cQ, \n#line $linenr "$file"\nq\cQ/;
  89             } else {
  90                 $part =~ s/\\/\\\\/ if not $inA || $inB;
  91                 $source .= $part;
  92             }
  93         }
  94     }
  95     $source .= "\cQ" unless $level;
  96
  97     return $source;
  98 }
  99
 100 # Handles errors, uses the sub reference $PLP::ERROR that gets two arguments:
 101 # the error message in plain text, and the error message with html entities
 102 sub error {
 103     my ($error, $type) = @_;
 104     if (not defined $type or $type < 100) {
 105         return undef unless $PLP::DEBUG & 1;
 106         my $plain = $error;
 107         (my $html = $plain) =~ s/([<&>])/'&#' . ord($1) . ';'/ge;
 108         PLP::sendheaders unless $PLP::sentheaders;
 109         $PLP::ERROR->($plain, $html);
 110     } else {
 111         select STDOUT;
 112         my ($short, $long) = @{
 113             +{
 114                 404 => [
 115                     'Not Found',
 116                     "The requested URL $ENV{REQUEST_URI} was not found on this server."
 117                 ],
 118                 403 => [
 119                     'Forbidden',
 120                     "You don't have permission to access $ENV{REQUEST_URI} on this server."
 121                 ],
 122             }->{$type}
 123         };
 124         print "Status: $type\nContent-Type: text/html\n\n",
 125               qq{<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">\n},
 126               "<html><head>\n<title>--$type $short</title>\n</head></body>\n",
 127               "<h1>$short</h1>\n$long<p>\n<hr>\n$ENV{SERVER_SIGNATURE}</body></html>";
 128     }
 129 }
 130
 131 # This gets referenced as the initial $PLP::ERROR
 132 sub _default_error {
 133     my ($plain, $html) = @_;
 134     print qq{<table border=1 class="PLPerror"><tr><td>},
 135           qq{<span><b>Debug information:</b><BR>$html</td></tr></table>};
 136 }
 137
 138 # This cleans up from previous requests, and sets the default $PLP::DEBUG
 139 sub clean {
 140     @PLP::END = ();
 141     $PLP::code = '';
 142     $PLP::sentheaders = 0;
 143     $PLP::inA = 0;
 144     $PLP::inB = 0;
 145     $PLP::DEBUG = 1;
 146     delete @ENV{ grep /^PLP_/, keys %ENV };
 147 }
 148
 149 # The *_init subs do the following:
 150 #  o  Set $PLP::code to the initial code
 151 #  o  Set $ENV{PLP_*} and makes PATH_INFO if needed
 152 #  o  Change the CWD
 153
 154 # This sub is meant for CGI requests only, and takes apart PATH_TRANSLATED
 155 # to find the file.
 156 sub cgi_init {
 157     my $file = defined $_[0] ? $_[0] : $ENV{PATH_TRANSLATED};
 158     $ENV{PLP_NAME} = $ENV{PATH_INFO};
 159     my $path_info;
 160     while (not -f $file) {
 161         if (not $file =~ s/(\/+[^\/]*)$//) {
 162             print STDERR "PLP: Not found: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
 163             PLP::error(undef, 404);
 164             exit;
 165         }
 166         my $pi = $1;
 167         $ENV{PLP_NAME} =~ s/\Q$pi\E$//;
 168         $path_info = $pi . $path_info;
 169     }
 170
 171     if (not -r $file) {
 172         print STDERR "PLP: Can't read: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
 173         PLP::error(undef, 403);
 174         exit;
 175     }
 176
 177     delete @ENV{
 178         qw(PATH_TRANSLATED SCRIPT_NAME SCRIPT_FILENAME PATH_INFO),
 179         grep { /^REDIRECT_/ } keys %ENV
 180     };
 181
 182     $ENV{PATH_INFO} = $path_info if defined $path_info;
 183     $ENV{PLP_FILENAME} = $file;
 184     (my $dir = $file) =~ s{/[^/]+$}[];
 185     chdir $dir;
 186
 187     $PLP::code = PLP::source($file, 0);
 188 }
 189
 190 # This is the mod_perl initializer.
 191 # Returns 0 on success.
 192 sub mod_perl_init {
 193     my $r = shift;
 194
 195     $ENV{PLP_FILENAME} = my $filename = $r->filename;
 196
 197     unless (-f $filename) {
 198         return Apache::Constants::NOT_FOUND;
 199     }
 200     unless (-r _) {
 201         return Apache::Constants::FORBIDDEN;
 202     }
 203
 204     (my $dir) = $filename =~ m!(.*)/!s;
 205     chdir $dir;
 206     $ENV{PLP_NAME} = $r->uri;
 207     $PLP::code = PLP::source($r->filename);
 208
 209     return 0; # OK
 210 }
 211
 212 # Let the games begin!
 213 # No lexicals may exist at this point.
 214 sub start {
 215     no strict;
 216     tie *PLPOUT, 'PLP::Tie::Print';
 217     select PLPOUT;
 218     $PLP::ERROR = \&_default_error;
 219
 220     PLP::Fields::doit();
 221     {
 222         package PLP::Script;
 223         *headers = \%header;
 224         *cookies = \%cookie;
 225         PLP::Functions->import();
 226         # No lexicals may exist at this point.
 227         eval qq{ package PLP::Script; $PLP::code; };
 228         PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/;
 229         eval   { package PLP::Script; $_->() for reverse @PLP::END };
 230         PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/;
 231     }
 232     PLP::sendheaders() unless $PLP::sentheaders;
 233     select STDOUT;
 234     # undef *{"PLP::Script::$_"} for keys %PLP::Script::;
 235     Symbol::delete_package('PLP::Script');
 236 }
 237
 238 # This is run by the CGI script.
 239 # The CGI script is just:
 240 #   #!/usr/bin/perl
 241 #   use PLP;
 242 #   PLP::everything();
 243 sub everything {
 244     clean();
 245     cgi_init();
 246     start();
 247 }
 248
 249 # This is the mod_perl handler.
 250 sub handler {
 251     require Apache::Constants;
 252     clean();
 253     if (my $ret = mod_perl_init(shift)) {
 254         return $ret;
 255     }
 256     start();
 257     return Apache::Constants::OK;
 258 }
 259
 260 1;
 261
 262 =head1 NAME
 263
 264 PLP - Perl in HTML pages
 265
 266 =head1 SYNOPSIS
 267
 268 =head2 mod_perl installation
 269
 270 =over 10
 271
 272 =item * httpd.conf (for mod_perl setup)
 273
 274     <Files *.plp>
 275         SetHandler perl-script
 276         PerlHandler PLP
 277         PerlSendHeader On
 278     </Files>
 279
 280     # Who said CGI was easier to set up? :)
 281
 282 =back
 283
 284 =head2 CGI installation
 285
 286 =over 10
 287
 288 =item * /foo/bar/plp.cgi (local filesystem address)
 289
 290     #!/usr/bin/perl
 291     use PLP;
 292     PLP::everything();
 293
 294 =item * httpd.conf (for CGI setup)
 295
 296     ScriptAlias /foo/bar/ /PLP_COMMON/
 297     <Directory /foo/bar/>
 298         AllowOverride None
 299         Options +ExecCGI
 300         Order allow,deny
 301         Allow from all
 302     </Directory>
 303     AddHandler plp-document plp
 304     Action plp-document /PLP_COMMON/plp.cgi
 305
 306 =back
 307
 308 =head2 Test script (test.plp)
 309
 310     <html><body>
 311     <:
 312         print "Hurrah, it works!<br>" for 1..10;
 313     :>
 314     </body></html>
 315
 316 =head1 DESCRIPTION
 317
 318 PLP is yet another Perl embedder, primarily for HTML documents. Unlike with
 319 other Perl embedders, there is no need to learn a meta-syntax or object
 320 model: one can just use the normal Perl constructs. PLP runs under mod_perl
 321 for speeds comparable to those of PHP, but can also be run as a CGI script.
 322
 323 =head1 WEBSITE
 324
 325 For now, all documentation is on the website. Everything will be POD one day,
 326 but until that day, you will need to visit http://plp.juerd.nl/
 327
 328 =head1 NO WARRANTY
 329
 330 No warranty, no guarantees. Use PLP at your own risk, as I disclaim all
 331 responsibility.
 332
 333 =head1 AUTHOR
 334
 335 Juerd Waalboer <juerd@juerd.nl>
 336
 337 =cut
 338