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     our $use_safe  = $r->dir_config('PLPsafe')  =~ /^on$/i;
 250     my $path = $r->filename();
 251     my ($file, $dir) = File::Basename::fileparse($path);
 252     chdir $dir;
 253
 254     $PLP::code = PLP::source($file, 0, undef, $path);
 255
 256     return 0; # OK
 257 }
 258
 259 # For PLPsafe scripts
 260 sub safe_eval {
 261     my ($r, $code) = @_;
 262     $r->send_http_header('text/plain');
 263     require Safe;
 264     unless ($PLP::safe) {
 265         $PLP::safe = Safe->new('PLP::Script');
 266         for ( map split, $r->dir_config->get('PLPsafe_module') ) {
 267             $PLP::safe->share('*' . $_ . '::');
 268             s!::!/!g;
 269             require $_ . '.pm';
 270         }
 271         $PLP::safe->permit(Opcode::full_opset());
 272         $PLP::safe->deny(Opcode::opset(':dangerous'));
 273     }
 274     $PLP::safe->reval($code);
 275 }
 276
 277 # Let the games begin!
 278 # No lexicals may exist at this point.
 279 sub start {
 280     my ($r) = @_;
 281     no strict;
 282     tie *PLPOUT, 'PLP::Tie::Print';
 283     select PLPOUT;
 284     $PLP::ERROR = \&_default_error;
 285
 286     PLP::Fields::doit();
 287     {
 288         package PLP::Script;
 289         use vars qw(%headers %header %cookies %cookie %get %post %fields);
 290         *headers = \%header;
 291         *cookies = \%cookie;
 292         PLP::Functions->import();
 293         # No lexicals may exist at this point.
 294
 295         if ($PLP::use_safe) {
 296             PLP::safe_eval($r, $PLP::code);
 297         } else {
 298             eval qq{ package PLP::Script; $PLP::code; };
 299         }
 300         PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/;
 301         if ($PLP::use_safe) {
 302             PLP::safe_eval($r, '$_->() for reverse @PLP::END');
 303         } else {
 304             eval   { package PLP::Script; $_->() for reverse @PLP::END };
 305         }
 306         PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/;
 307     }
 308     PLP::sendheaders() unless $PLP::sentheaders;
 309     select STDOUT;
 310     undef *{"PLP::Script::$_"} for keys %PLP::Script::;
 311 #    Symbol::delete_package('PLP::Script');
 312 #    The above does not work. TODO - find out why not.
 313 }
 314
 315 # This is run by the CGI script. (#!perl \n use PLP; PLP::everything;)
 316 sub everything {
 317     clean();
 318     cgi_init();
 319     start();
 320 }
 321
 322 # This is the mod_perl handler.
 323 sub handler {
 324     require Apache::Constants;
 325     clean();
 326     if (my $ret = mod_perl_init($_[0])) {
 327         return $ret;
 328     }
 329     start($_[0]);
 330     no strict 'subs';
 331     return Apache::Constants::OK();
 332 }
 333
 334 1;
 335
 336 =head1 NAME
 337
 338 PLP - Perl in HTML pages
 339
 340 =head1 SYNOPSIS
 341
 342 =head2 mod_perl installation
 343
 344 =over 10
 345
 346 =item * httpd.conf (for mod_perl setup)
 347
 348     <Files *.plp>
 349         SetHandler perl-script
 350         PerlHandler PLP
 351         PerlSendHeader On
 352         PerlSetVar PLPcache On
 353     </Files>
 354
 355     # Who said CGI was easier to set up? :)
 356
 357 =back
 358
 359 =head2 CGI installation
 360
 361 =over 10
 362
 363 =item * /foo/bar/plp.cgi (local filesystem address)
 364
 365     #!/usr/bin/perl
 366     use PLP;
 367     PLP::everything();
 368
 369 =item * httpd.conf (for CGI setup)
 370
 371     ScriptAlias /foo/bar/ /PLP_COMMON/
 372     <Directory /foo/bar/>
 373         AllowOverride None
 374         Options +ExecCGI
 375         Order allow,deny
 376         Allow from all
 377     </Directory>
 378     AddHandler plp-document plp
 379     Action plp-document /PLP_COMMON/plp.cgi
 380
 381 =back
 382
 383 =head2 Test script (test.plp)
 384
 385     <html><body>
 386     <:
 387         print "Hurrah, it works!<br>" for 1..10;
 388     :>
 389     </body></html>
 390
 391 =head1 DESCRIPTION
 392
 393 PLP is yet another Perl embedder, primarily for HTML documents. Unlike with
 394 other Perl embedders, there is no need to learn a meta-syntax or object
 395 model: one can just use the normal Perl constructs. PLP runs under mod_perl
 396 for speeds comparable to those of PHP, but can also be run as a CGI script.
 397
 398 =head2 PLP Syntax
 399
 400 =over 22
 401
 402 =item C<< <: perl_code(); :> >>
 403
 404 With C<< <: >> and C<< :> >>, you can add Perl code to your document. This is
 405 what PLP is all about. All code outside of these tags is printed. It is
 406 possible to mix perl language constructs with normal HTML parts of the document:
 407
 408     <: unless ($ENV{REMOTE_USER}) { :>
 409         You are not logged in.
 410     <: } :>
 411
 412 C<< :> >> always stops a code block, even when it is found in a string literal.
 413
 414 =item C<< <:= $expression :> >>
 415
 416 Includes a dynamic expression in your document. The expression is evaluated in
 417 list context. Please note that the expression should not end a statement: avoid
 418 semi-colons. No whitespace may be between C<< <: >> and the equal sign.
 419
 420 C<< foo <:= $bar :> $baz >> is like C<< <: print 'foo ', $bar, ' baz'; :> >>.
 421
 422 =item C<< <(filename)> >>
 423
 424 Includes another file before the PLP code is executed. The file is included
 425 literally, so it shares lexical variables. Because this is a compile-time tag,
 426 it's fast, but you can't use a variable as the filename. You can create
 427 recursive includes, so beware! (PLP will catch simple recursion: the maximum
 428 depth is 128.) Whitespace in the filename is not ignored so C<< <( foo.txt)> >>
 429 includes the file named C< foo.txt>, including the space in its name. A
 430 compile-time alternative is include(), which is described in L<PLP::Functions>.
 431
 432 =back
 433
 434 =head2 PLP Functions
 435
 436 These are described in L<PLP::Functions>.
 437
 438 =head2 PLP Variables
 439
 440 =over 22
 441
 442 =item $ENV{PLP_NAME}
 443
 444 The URI of the PLP document, without the query string. (Example: C</foo.plp>)
 445
 446 =item $ENV{PLP_FILENAME}
 447
 448 The filename of the PLP document. (Example: C</var/www/index.plp>)
 449
 450 =item $PLP::VERSION
 451
 452 The version of PLP.
 453
 454 =item $PLP::DEBUG
 455
 456 Controls debugging output, and should be treated as a bitmask. The least
 457 significant bit (1) controls if run-time error messages are reported to the
 458 browser, the second bit (2) controls if headers are sent twice, so they get
 459 displayed in the browser. A value of 3 means both features are enabled. The
 460 default value is 1.
 461
 462 =item $PLP::ERROR
 463
 464 Contains a reference to the code that is used to report run-time errors. You
 465 can override this to have it in your own design, and you could even make it
 466 report errors by e-mail. The sub reference gets two arguments: the error message
 467 as plain text and the error message with special characters encoded with HTML
 468 entities.
 469
 470 =item %header, %cookie, %get, %post, %fields
 471
 472 These are described in L<PLP::Fields>.
 473
 474 =back
 475
 476 =head2 (mod_perl only) PerlSetVar configuration directives
 477
 478 =over 22
 479
 480 =item PLPcache
 481
 482 Sets caching B<On>/B<Off>. When caching, PLP saves your script in memory and
 483 doesn't re-read and re-parse it if it hasn't changed. PLP will use more memory,
 484 but will also run 50% faster.
 485
 486 B<On> is default, anything that isn't =~ /^off$/i is considered On.
 487
 488 =back
 489
 490 =head2 Things that you should know about
 491
 492 Not only syntax is important, you should also be aware of some other important
 493 features. Your script runs inside the package C<PLP::Script> and shouldn't
 494 leave it. This is because when your script ends, all global variables in the
 495 C<PLP::Script> package are destroyed, which is very important if you run under
 496 mod_perl (they would retain their values if they weren't explicitly destroyed).
 497
 498 Until your first output, you are printing to a tied filehandle C<PLPOUT>. On
 499 first output, headers are sent to the browser and C<STDOUT> is selected for
 500 efficiency. To set headers, you must assign to C<$header{ $header_name}> before
 501 any output. This means the opening C<< <: >> have to be the first characters in
 502 your document, without any whitespace in front of them. If you start output and
 503 try to set headers later, an error message will appear telling you on which
 504 line your output started. An alternative way of setting headers is using Perl's
 505 BEGIN blocks. BEGIN blocks are executed as soon as possible, before anything
 506 else.
 507
 508 Because the interpreter that mod_perl uses never ends, C<END { }> blocks won't
 509 work properly. You should use C<PLP_END { };> instead. Note that this is a not
 510 a built-in construct, so it needs proper termination with a semi-colon (as do
 511 <eval> and <do>).
 512
 513 Under mod_perl, modules are loaded only once. A good modular design can improve
 514 performance because of this, but you will have to B<reload> the modules
 515 yourself when there are newer versions.
 516
 517 The special hashes are tied hashes and do not always behave the way you expect,
 518 especially when mixed with modules that expect normal CGI environments, like
 519 CGI.pm. Read L<PLP::Fields> for information more about this.
 520
 521 =head1 FAQ and HowTo
 522
 523 A lot of questions are asked often, so before asking yours, please read the
 524 FAQ at L<PLP::FAQ>. Some examples can be found at L<PLP::HowTo>.
 525
 526 =head1 NO WARRANTY
 527
 528 No warranty, no guarantees. Use PLP at your own risk, as I disclaim all
 529 responsibility.
 530
 531 =head1 AUTHOR
 532
 533 Juerd Waalboer <juerd@cpan.org>
 534
 535 =head1 SEE ALSO
 536
 537 L<PLP::Functions>, L<PLP::Fields>, L<PLP::FAQ>, L<PLP::HowTo>
 538
 539 =cut
 540