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