PLP.pm

   1 #--------------#
   2   package PLP;
   3 #--------------#
   4
   5 use v5.6;
   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 use strict;
  14
  15 our $VERSION = '3.14';
  16
  17 # subs in this package:
  18 #  sendheaders                      Send headers
  19 #  source($path, $level, $linespec) Read and parse .plp files
  20 #  error($error, $type)             Handle errors
  21 #  _default_error($plain, $html)    Default error handler
  22 #  clean                            Reset variables
  23 #  cgi_init                         Initialization for CGI
  24 #  mod_perl_init($r)                Initialization for mod_perl
  25 #  start                            Start the initialized PLP script
  26 #  everything                       Do everything: CGI
  27 #  handler($r)                      Do everything: mod_perl
  28
  29
  30 # Sends the headers waiting in %PLP::Script::header
  31 sub sendheaders () {
  32     our $sentheaders = 1;
  33     print STDOUT "Content-Type: text/plain\n\n" if $PLP::DEBUG & 2;
  34     print STDOUT map("$_: $PLP::Script::header{$_}\n", keys %PLP::Script::header), "\n";
  35 };
  36
  37 # Given a filename and optional level (level should be 0 if the caller isn't
  38 # source() itself), and optional linespec (used by PLP::Functions::Include),
  39 # this function parses a PLP file and returns Perl code, ready to be eval'ed
  40 sub source {
  41     my ($path, $level, $linespec) = @_;
  42     $level = 0      if not defined $level;
  43     $linespec = '1' if not defined $linespec;
  44
  45     our ($inA, $inB);
  46
  47     (my $file = $path) =~ s[.*/][];
  48
  49     my $source = $level
  50         ? qq/\cQ;\n#line 1 "$file"\nprint q\cQ/
  51         : qq/\n#line 1 "$file"\nprint q\cQ/;
  52     my $linenr = 0;
  53
  54     local *SOURCE;
  55     open SOURCE, '<', $path or return $level
  56         ? qq{\cQ; die qq[Can't open "\Q$path\E" (\Q$!\E)]; print q\cQ}
  57         : qq{\n#line $linespec\ndie qq[Can't open "\Q$path\E" (\Q$!\E)];};
  58
  59     LINE:
  60     while (defined (my $line = <SOURCE>)) {
  61         $linenr++;
  62         for (;;) {
  63             $line =~ /
  64                 \G                  # Begin where left off
  65                 ( \z                # End
  66                 | <:=? | :>         # PLP tags     <:= ... :> <: ... :>
  67                 | <\(.*?\)>         # Include tags <(...)>
  68                 | <[^:(][^<:]*      # Normal text
  69                 | :[^>][^<:]*       # Normal text
  70                 | [^<:]*            # Normal text
  71                 )
  72             /gxs;
  73             next LINE unless length $1;
  74             my $part = $1;
  75             if ($part eq '<:=' and not $inA || $inB) {
  76                 $inA = 1;
  77                 $source .= "\cQ, ";
  78             } elsif ($part eq '<:' and not $inA || $inB) {
  79                 $inB = 1;
  80                 $source .= "\cQ; ";
  81             } elsif ($part eq ':>' and $inA) {
  82                 $inA = 0;
  83                 $source .= ", q\cQ";
  84             } elsif ($part eq ':>' and $inB) {
  85                 $inB = 0;
  86                 $source .= "; print q\cQ";
  87             } elsif ($part =~ /^<\((.*?)\)>\z/ and not $inA || $inB) {
  88                 $source .= source($1, $level + 1) .
  89                            qq/\cQ, \n#line $linenr "$file"\nq\cQ/;
  90             } else {
  91                 $part =~ s/\\/\\\\/ if not $inA || $inB;
  92                 $source .= $part;
  93             }
  94         }
  95     }
  96     $source .= "\cQ" unless $level;
  97
  98     return $source;
  99 }
 100
 101 # Handles errors, uses the sub reference $PLP::ERROR that gets two arguments:
 102 # the error message in plain text, and the error message with html entities
 103 sub error {
 104     my ($error, $type) = @_;
 105     if (not defined $type or $type < 100) {
 106         return undef unless $PLP::DEBUG & 1;
 107         my $plain = $error;
 108         (my $html = $plain) =~ s/([<&>])/'&#' . ord($1) . ';'/ge;
 109         PLP::sendheaders unless $PLP::sentheaders;
 110         $PLP::ERROR->($plain, $html);
 111     } else {
 112         select STDOUT;
 113         my ($short, $long) = @{
 114             +{
 115                 404 => [
 116                     'Not Found',
 117                     "The requested URL $ENV{REQUEST_URI} was not found on this server."
 118                 ],
 119                 403 => [
 120                     'Forbidden',
 121                     "You don't have permission to access $ENV{REQUEST_URI} on this server."
 122                 ],
 123             }->{$type}
 124         };
 125         print "Status: $type\nContent-Type: text/html\n\n",
 126               qq{<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">\n},
 127               "<html><head>\n<title>--$type $short</title>\n</head></body>\n",
 128               "<h1>$short</h1>\n$long<p>\n<hr>\n$ENV{SERVER_SIGNATURE}</body></html>";
 129     }
 130 }
 131
 132 # This gets referenced as the initial $PLP::ERROR
 133 sub _default_error {
 134     my ($plain, $html) = @_;
 135     print qq{<table border=1 class="PLPerror"><tr><td>},
 136           qq{<span><b>Debug information:</b><BR>$html</td></tr></table>};
 137 }
 138
 139 # This cleans up from previous requests, and sets the default $PLP::DEBUG
 140 sub clean {
 141     @PLP::END = ();
 142     $PLP::code = '';
 143     $PLP::sentheaders = 0;
 144     $PLP::inA = 0;
 145     $PLP::inB = 0;
 146     $PLP::DEBUG = 1;
 147     delete @ENV{ grep /^PLP_/, keys %ENV };
 148 }
 149
 150 # The *_init subs do the following:
 151 #  o  Set $PLP::code to the initial code
 152 #  o  Set $ENV{PLP_*} and makes PATH_INFO if needed
 153 #  o  Change the CWD
 154
 155 # This sub is meant for CGI requests only, and takes apart PATH_TRANSLATED
 156 # to find the file.
 157 sub cgi_init {
 158     my $file = defined $_[0] ? $_[0] : $ENV{PATH_TRANSLATED};
 159     $ENV{PLP_NAME} = $ENV{PATH_INFO};
 160     my $path_info;
 161     while (not -f $file) {
 162         if (not $file =~ s/(\/+[^\/]*)$//) {
 163             print STDERR "PLP: Not found: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
 164             PLP::error(undef, 404);
 165             exit;
 166         }
 167         my $pi = $1;
 168         $ENV{PLP_NAME} =~ s/\Q$pi\E$//;
 169         $path_info = $pi . $path_info;
 170     }
 171
 172     if (not -r $file) {
 173         print STDERR "PLP: Can't read: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
 174         PLP::error(undef, 403);
 175         exit;
 176     }
 177
 178     delete @ENV{
 179         qw(PATH_TRANSLATED SCRIPT_NAME SCRIPT_FILENAME PATH_INFO),
 180         grep { /^REDIRECT_/ } keys %ENV
 181     };
 182
 183     $ENV{PATH_INFO} = $path_info if defined $path_info;
 184     $ENV{PLP_FILENAME} = $file;
 185     (my $dir = $file) =~ s{/[^/]+$}[];
 186     chdir $dir;
 187
 188     $PLP::code = PLP::source($file, 0);
 189 }
 190
 191 # This is the mod_perl initializer.
 192 # Returns 0 on success.
 193 sub mod_perl_init {
 194     my $r = shift;
 195
 196     $ENV{PLP_FILENAME} = my $filename = $r->filename;
 197
 198     unless (-f $filename) {
 199         return Apache::Constants::NOT_FOUND();
 200     }
 201     unless (-r _) {
 202         return Apache::Constants::FORBIDDEN();
 203     }
 204
 205     (my $dir) = $filename =~ m!(.*)/!s;
 206     chdir $dir;
 207     $ENV{PLP_NAME} = $r->uri;
 208     $PLP::code = PLP::source($r->filename);
 209
 210     return 0; # OK
 211 }
 212
 213 # Let the games begin!
 214 # No lexicals may exist at this point.
 215 sub start {
 216     no strict;
 217     tie *PLPOUT, 'PLP::Tie::Print';
 218     select PLPOUT;
 219     $PLP::ERROR = \&_default_error;
 220
 221     PLP::Fields::doit();
 222     {
 223         package PLP::Script;
 224         use vars qw(%headers %header %cookies %cookie %get %post %fields);
 225         *headers = \%header;
 226         *cookies = \%cookie;
 227         PLP::Functions->import();
 228         # No lexicals may exist at this point.
 229         eval qq{ package PLP::Script; $PLP::code; };
 230         PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/;
 231         eval   { package PLP::Script; $_->() for reverse @PLP::END };
 232         PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/;
 233     }
 234     PLP::sendheaders() unless $PLP::sentheaders;
 235     select STDOUT;
 236     undef *{"PLP::Script::$_"} for keys %PLP::Script::;
 237 #    Symbol::delete_package('PLP::Script');
 238 #    The above does not work. TODO - find out why not.
 239 }
 240
 241 # This is run by the CGI script.
 242 # The CGI script is just:
 243 #   #!/usr/bin/perl
 244 #   use PLP;
 245 #   PLP::everything();
 246 sub everything {
 247     clean();
 248     cgi_init();
 249     start();
 250 }
 251
 252 # This is the mod_perl handler.
 253 sub handler {
 254     require Apache::Constants;
 255     clean();
 256     if (my $ret = mod_perl_init(shift)) {
 257         return $ret;
 258     }
 259     start();
 260     no strict 'subs';
 261     return Apache::Constants::OK();
 262 }
 263
 264 1;
 265
 266 =head1 NAME
 267
 268 PLP - Perl in HTML pages
 269
 270 =head1 SYNOPSIS
 271
 272 =head2 mod_perl installation
 273
 274 =over 10
 275
 276 =item * httpd.conf (for mod_perl setup)
 277
 278     <Files *.plp>
 279         SetHandler perl-script
 280         PerlHandler PLP
 281         PerlSendHeader On
 282     </Files>
 283
 284     # Who said CGI was easier to set up? :)
 285
 286 =back
 287
 288 =head2 CGI installation
 289
 290 =over 10
 291
 292 =item * /foo/bar/plp.cgi (local filesystem address)
 293
 294     #!/usr/bin/perl
 295     use PLP;
 296     PLP::everything();
 297
 298 =item * httpd.conf (for CGI setup)
 299
 300     ScriptAlias /foo/bar/ /PLP_COMMON/
 301     <Directory /foo/bar/>
 302         AllowOverride None
 303         Options +ExecCGI
 304         Order allow,deny
 305         Allow from all
 306     </Directory>
 307     AddHandler plp-document plp
 308     Action plp-document /PLP_COMMON/plp.cgi
 309
 310 =back
 311
 312 =head2 Test script (test.plp)
 313
 314     <html><body>
 315     <:
 316         print "Hurrah, it works!<br>" for 1..10;
 317     :>
 318     </body></html>
 319
 320 =head1 DESCRIPTION
 321
 322 PLP is yet another Perl embedder, primarily for HTML documents. Unlike with
 323 other Perl embedders, there is no need to learn a meta-syntax or object
 324 model: one can just use the normal Perl constructs. PLP runs under mod_perl
 325 for speeds comparable to those of PHP, but can also be run as a CGI script.
 326
 327 =head2 PLP Syntax
 328
 329 =over 22
 330
 331 =item C<< <: perl_code(); :> >>
 332
 333 With C<< <: >> and C<< :> >>, you can add Perl code to your document. This is
 334 what PLP is all about. All code outside of these tags is printed. It is
 335 possible to mix perl language constructs with normal HTML parts of the document:
 336
 337     <: unless ($ENV{REMOTE_USER}) { :>
 338         You are not logged in.
 339     <: } :>
 340
 341 C<< :> >> always stops a code block, even when it is found in a string literal.
 342
 343 =item C<< <:= $expression :> >>
 344
 345 Includes a dynamic expression in your document. The expression is evaluated in
 346 list context. Please note that the expression should not end a statement: avoid
 347 semi-colons. No whitespace may be between C<< <: >> and the equal sign.
 348
 349 C<< foo <:= $bar :> $baz >> is like C<< <: print 'foo ', $bar, ' baz'; :> >>.
 350
 351 =item C<< <(filename)> >>
 352
 353 Includes another file before the PLP code is executed. The file is included
 354 literally, so it shares lexical variables. Because this is a compile-time tag,
 355 it's fast, but you can't use a variable as the filename. You can create
 356 recursive includes, so beware! (PLP will catch simple recursion: the maximum
 357 depth is 128.) Whitespace in the filename is not ignored so C<< <( foo.txt)> >>
 358 includes the file named C< foo.txt>, including the space in its name. A
 359 compile-time alternative is include(), which is described in L<PLP::Functions>.
 360
 361 =back
 362
 363 =head2 PLP Functions
 364
 365 These are described in L<PLP::Functions>.
 366
 367 =head2 PLP Variables
 368
 369 =over 22
 370
 371 =item $ENV{PLP_NAME}
 372
 373 The URI of the PLP document, without the query string. (Example: C</foo.plp>)
 374
 375 =item $ENV{PLP_FILENAME}
 376
 377 The filename of the PLP document. (Example: C</var/www/index.plp>)
 378
 379 =item $PLP::VERSION
 380
 381 The version of PLP.
 382
 383 =item $PLP::DEBUG
 384
 385 Controls debugging output, and should be treated as a bitmask. The least
 386 significant bit (1) controls if run-time error messages are reported to the
 387 browser, the second bit (2) controls if headers are sent twice, so they get
 388 displayed in the browser. A value of 3 means both features are enabled. The
 389 default value is 1.
 390
 391 =item $PLP::ERROR
 392
 393 Contains a reference to the code that is used to report run-time errors. You
 394 can override this to have it in your own design, and you could even make it
 395 report errors by e-mail. The sub reference gets two arguments: the error message
 396 as plain text and the error message with special characters encoded with HTML
 397 entities.
 398
 399 =item %header, %cookie, %get, %post, %fields
 400
 401 These are described in L<PLP::Fields>.
 402
 403 =back
 404
 405 =head2 (mod_perl only) PerlSetVar configuration directives
 406
 407 =over 22
 408
 409 =item PLPcache
 410
 411 Sets caching B<On>/B<Off>. When caching, PLP saves your script in memory and
 412 doesn't re-read and re-parse it if it hasn't changed. PLP will use more memory,
 413 but will also run 50% faster.
 414
 415 B<On> is default, anything that isn't =~ /^off$/i is considered On.
 416
 417 =back
 418
 419 =head2 Things that you should know about
 420
 421 Not only syntax is important, you should also be aware of some other important
 422 features. Your script runs inside the package C<PLP::Script> and shouldn't
 423 leave it. This is because when your script ends, all global variables in the
 424 C<PLP::Script> package are destroyed, which is very important if you run under
 425 mod_perl (they would retain their values if they weren't explicitly destroyed).
 426
 427 Until your first output, you are printing to a tied filehandle C<PLPOUT>. On
 428 first output, headers are sent to the browser and C<STDOUT> is selected for
 429 efficiency. To set headers, you must assign to C<$header{ $header_name}> before
 430 any output. This means the opening C<< <: >> have to be the first characters in
 431 your document, without any whitespace in front of them. If you start output and
 432 try to set headers later, an error message will appear telling you on which
 433 line your output started.
 434
 435 Because the interpreter that mod_perl uses never ends, C<END { }> blocks won't
 436 work properly. You should use C<PLP_END { };> instead. Note that this is a not
 437 a built-in construct, so it needs proper termination with a semi-colon (as do
 438 <eval> and <do>).
 439
 440 Under mod_perl, modules are loaded only once. A good modular design can improve
 441 performance because of this, but you will have to B<reload> the modules
 442 yourself when there are newer versions.
 443
 444 The special hashes are tied hashes and do not always behave the way you expect,
 445 especially when mixed with modules that expect normal CGI environments, like
 446 CGI.pm. Read L<PLP::Fields> for information more about this.
 447
 448 =head1 FAQ
 449
 450 A lot of questions are asked often, so before asking yours, please read the
 451 FAQ at L<PLP::FAQ>.
 452
 453 =head1 NO WARRANTY
 454
 455 No warranty, no guarantees. Use PLP at your own risk, as I disclaim all
 456 responsibility.
 457
 458 =head1 AUTHOR
 459
 460 Juerd Waalboer <juerd@juerd.nl>
 461
 462 =head1 SEE ALSO
 463
 464 L<PLP::Functions>, L<PLP::Fields>, L<PLP::FAQ>
 465
 466 =cut
 467