PLP.pm

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