PLP.pm

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