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