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