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