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