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