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