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