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