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