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