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