11 use File::Basename ();
17 our $VERSION = '3.18';
19 # Subs in this package:
20 # _default_error($plain, $html) Default error handler
21 # cgi_init Initialization for CGI
22 # clean Reset variables
23 # error($error, $type) Handle errors
24 # everything Do everything: CGI
25 # handler($r) Do everything: mod_perl
26 # mod_perl_init($r) Initialization for mod_perl
27 # mod_perl_print Faster printing for mod_perl
28 # sendheaders Send headers
29 # source($path, $level, $linespec) Read and parse .plp files
30 # start Start the initialized PLP script
32 # The _init subs do the following:
33 # Set $PLP::code to the initial code
34 # Set $ENV{PLP_*} and makes PATH_INFO if needed
37 # This gets referenced as the initial $PLP::ERROR
39 my ($plain, $html) = @_;
40 print qq{<table border=1 class="PLPerror"><tr><td>},
41 qq{<span><b>Debug information:</b><BR>$html</td></tr></table>};
44 # CGI initializer: parses PATH_TRANSLATED
47 $PLP::print = 'print';
49 my $path = $ENV{PATH_TRANSLATED};
50 $ENV{PLP_NAME} = $ENV{PATH_INFO};
52 while (not -f $path) {
53 if (not $path =~ s/(\/+[^\/]*)$//) {
54 print STDERR "PLP: Not found: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
55 PLP::error(undef, 404);
59 $ENV{PLP_NAME} =~ s/\Q$pi\E$//;
60 $path_info = $pi . $path_info;
64 print STDERR "PLP: Can't read: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
65 PLP::error(undef, 403);
70 qw(PATH_TRANSLATED SCRIPT_NAME SCRIPT_FILENAME PATH_INFO),
71 grep /^REDIRECT_/, keys %ENV
74 $ENV{PATH_INFO} = $path_info if defined $path_info;
75 $ENV{PLP_FILENAME} = $path;
76 my ($file, $dir) = File::Basename::fileparse($path);
79 $PLP::code = PLP::source($file, 0, undef, $path);
82 # This cleans up from previous requests, and sets the default $PLP::DEBUG
86 $PLP::sentheaders = 0;
90 delete @ENV{ grep /^PLP_/, keys %ENV };
93 # Handles errors, uses subref $PLP::ERROR (default: \&_default_error)
95 my ($error, $type) = @_;
96 if (not defined $type or $type < 100) {
97 return undef unless $PLP::DEBUG & 1;
99 (my $html = $plain) =~ s/([<&>])/'&#' . ord($1) . ';'/ge;
100 PLP::sendheaders() unless $PLP::sentheaders;
101 $PLP::ERROR->($plain, $html);
104 my ($short, $long) = @{
108 "The requested URL $ENV{REQUEST_URI} was not found " .
113 "You don't have permission to access $ENV{REQUEST_URI} " .
118 print "Status: $type\nContent-Type: text/html\n\n",
119 qq{<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">\n<html>},
120 "<head>\n<title>$type $short</title>\n</head></body>\n<h1>$short",
121 "</h1>\n$long<p>\n<hr>\n$ENV{SERVER_SIGNATURE}</body></html>";
125 # This is run by the CGI script. (#!perl \n use PLP; PLP::everything;)
132 # This is the mod_perl handler.
134 require Apache::Constants;
136 if (my $ret = mod_perl_init($_[0])) {
142 return Apache::Constants::OK();
145 # mod_perl initializer: returns 0 on success, Apache error code on failure
149 $PLP::print = 'PLP::mod_perl_print';
151 $ENV{PLP_FILENAME} = my $filename = $r->filename;
153 unless (-f $filename) {
154 return Apache::Constants::NOT_FOUND();
157 return Apache::Constants::FORBIDDEN();
160 $ENV{PLP_NAME} = $r->uri;
162 our $use_cache = $r->dir_config('PLPcache') !~ /^off$/i;
163 #S our $use_safe = $r->dir_config('PLPsafe') =~ /^on$/i;
164 my $path = $r->filename();
165 my ($file, $dir) = File::Basename::fileparse($path);
168 $PLP::code = PLP::source($file, 0, undef, $path);
173 # FAST printing under mod_perl
175 return unless grep length, @_;
176 PLP::sendheaders() unless $PLP::sentheaders;
180 # Sends the headers waiting in %PLP::Script::header
182 $PLP::sentheaders ||= [ caller 1 ? (caller 1)[1, 2] : (caller)[1, 2] ];
183 print STDOUT "Content-Type: text/plain\n\n" if $PLP::DEBUG & 2;
184 print STDOUT map("$_: $PLP::Script::header{$_}\n", keys %PLP::Script::header), "\n";
188 my %cached; # Conceal cached sources: ( path => [ [ deps ], source, -M ] )
190 # Given a filename and optional level (level should be 0 if the caller isn't
191 # source() itself), and optional linespec (used by PLP::Functions::Include),
192 # this function parses a PLP file and returns Perl code, ready to be eval'ed
194 my ($file, $level, $linespec, $path) = @_;
197 # $file is displayed, $path is used. $path is constructed from $file if
200 $level = 0 unless defined $level;
201 $linespec = '1' unless defined $linespec;
206 ? qq{\cQ; die qq[Include recursion detected]; print q\cQ}
207 : qq{\n#line $linespec\ndie qq[Include recursion detected];};
210 my $in_block = 0; # 1 => "<:", 2 => "<:="
212 $path ||= File::Spec->rel2abs($file);
214 my $source_start = $level
215 ? qq/\cQ;\n#line 1 "$file"\n$PLP::print q\cQ/
216 : qq/\n#line 1 "$file"\n$PLP::print q\cQ/;
218 if ($use_cache and exists $cached{$path}) {
220 my @checkstack = ($path);
223 while (defined(my $item = shift @checkstack)) {
224 next if $checked{$item};
225 last BREAKOUT if $cached{$item}[2] > -M $item;
227 push @checkstack, @{ $cached{$item}[0] }
228 if @{ $cached{$item}[0] };
231 ? $source_start . $cached{$path}[1]
232 : $source_start . $cached{$path}[1] . "\cQ";
236 $cached{$path} = [ [ ], undef, undef ] if $use_cache;
242 open SOURCE, '<', $path or return $level
243 ? qq{\cQ; die qq[Can't open "\Q$path\E" (\Q$!\E)]; print q\cQ}
244 : qq{\n#line $linespec\ndie qq[Can't open "\Q$path\E" (\Q$!\E)];};
247 while (defined (my $line = <SOURCE>)) {
251 \G # Begin where left off
253 | <:=? | :> # PLP tags <:= ... :> <: ... :>
254 | <\([^)]*\)> # Include tags <(...)>
255 | <[^:(][^<:]* # Normal text
256 | :[^>][^<:]* # Normal text
257 | [^<:]* # Normal text
260 next LINE unless length $1;
262 if ($part eq '<:=' and not $in_block) {
265 } elsif ($part eq '<:' and not $in_block) {
268 } elsif ($part eq ':>' and $in_block) {
272 : "; $PLP::print q\cQ" # 1
275 } elsif ($part =~ /^<\((.*?)\)>\z/ and not $in_block) {
276 my $ipath = File::Spec->rel2abs(
277 $1, File::Basename::dirname($path)
279 $source .= source($1, $level + 1, undef, $ipath) .
280 qq/\cQ, \n#line $linenr "$file"\nq\cQ/;
281 push @{ $cached{$path}[0] }, $ipath;
283 $part =~ s/\\/\\\\/ unless $in_block;
293 : "; $PLP::print q\cQ" # 1
298 $cached{$path}[1] = $source;
299 $cached{$path}[2] = -M $path;
303 ? $source_start . $source
304 : $source_start . $source . "\cQ";
309 # Let the games begin! No lexicals may exist at this point.
312 tie *PLPOUT, 'PLP::Tie::Print';
314 $PLP::ERROR = \&_default_error;
319 use vars qw(%headers %header %cookies %cookie %get %post %fields);
322 PLP::Functions->import();
324 # No lexicals may exist at this point.
326 eval qq{ package PLP::Script; $PLP::code; };
327 PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/;
329 eval { package PLP::Script; $_->() for reverse @PLP::END };
330 PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/;
332 PLP::sendheaders() unless $PLP::sentheaders;
334 undef *{"PLP::Script::$_"} for keys %PLP::Script::;
335 # Symbol::delete_package('PLP::Script');
336 # The above does not work. TODO - find out why not.
343 PLP - Perl in HTML pages
347 =head2 mod_perl installation
351 =item * httpd.conf (for mod_perl setup)
354 SetHandler perl-script
357 PerlSetVar PLPcache On
360 # Who said CGI was easier to set up? :)
364 =head2 CGI installation
368 =item * /foo/bar/plp.cgi (local filesystem address)
374 =item * httpd.conf (for CGI setup)
376 ScriptAlias /foo/bar/ /PLP_COMMON/
377 <Directory /foo/bar/>
383 AddHandler plp-document plp
384 Action plp-document /PLP_COMMON/plp.cgi
388 =head2 Test script (test.plp)
392 print "Hurrah, it works!<br>" for 1..10;
398 PLP is yet another Perl embedder, primarily for HTML documents. Unlike with
399 other Perl embedders, there is no need to learn a meta-syntax or object
400 model: one can just use the normal Perl constructs. PLP runs under mod_perl
401 for speeds comparable to those of PHP, but can also be run as a CGI script.
407 =item C<< <: perl_code(); :> >>
409 With C<< <: >> and C<< :> >>, you can add Perl code to your document. This is
410 what PLP is all about. All code outside of these tags is printed. It is
411 possible to mix perl language constructs with normal HTML parts of the document:
413 <: unless ($ENV{REMOTE_USER}) { :>
414 You are not logged in.
417 C<< :> >> always stops a code block, even when it is found in a string literal.
419 =item C<< <:= $expression :> >>
421 Includes a dynamic expression in your document. The expression is evaluated in
422 list context. Please note that the expression should not end a statement: avoid
423 semi-colons. No whitespace may be between C<< <: >> and the equal sign.
425 C<< foo <:= $bar :> $baz >> is like C<< <: print 'foo ', $bar, ' baz'; :> >>.
427 =item C<< <(filename)> >>
429 Includes another file before the PLP code is executed. The file is included
430 literally, so it shares lexical variables. Because this is a compile-time tag,
431 it's fast, but you can't use a variable as the filename. You can create
432 recursive includes, so beware! (PLP will catch simple recursion: the maximum
433 depth is 128.) Whitespace in the filename is not ignored so C<< <( foo.txt)> >>
434 includes the file named C< foo.txt>, including the space in its name. A
435 compile-time alternative is include(), which is described in L<PLP::Functions>.
441 These are described in L<PLP::Functions>.
449 The URI of the PLP document, without the query string. (Example: C</foo.plp>)
451 =item $ENV{PLP_FILENAME}
453 The filename of the PLP document. (Example: C</var/www/index.plp>)
461 Controls debugging output, and should be treated as a bitmask. The least
462 significant bit (1) controls if run-time error messages are reported to the
463 browser, the second bit (2) controls if headers are sent twice, so they get
464 displayed in the browser. A value of 3 means both features are enabled. The
469 Contains a reference to the code that is used to report run-time errors. You
470 can override this to have it in your own design, and you could even make it
471 report errors by e-mail. The sub reference gets two arguments: the error message
472 as plain text and the error message with special characters encoded with HTML
475 =item %header, %cookie, %get, %post, %fields
477 These are described in L<PLP::Fields>.
481 =head2 (mod_perl only) PerlSetVar configuration directives
487 Sets caching B<On>/B<Off>. When caching, PLP saves your script in memory and
488 doesn't re-read and re-parse it if it hasn't changed. PLP will use more memory,
489 but will also run 50% faster.
491 B<On> is default, anything that isn't =~ /^off$/i is considered On.
495 =head2 Things that you should know about
497 Not only syntax is important, you should also be aware of some other important
498 features. Your script runs inside the package C<PLP::Script> and shouldn't
499 leave it. This is because when your script ends, all global variables in the
500 C<PLP::Script> package are destroyed, which is very important if you run under
501 mod_perl (they would retain their values if they weren't explicitly destroyed).
503 Until your first output, you are printing to a tied filehandle C<PLPOUT>. On
504 first output, headers are sent to the browser and C<STDOUT> is selected for
505 efficiency. To set headers, you must assign to C<$header{ $header_name}> before
506 any output. This means the opening C<< <: >> have to be the first characters in
507 your document, without any whitespace in front of them. If you start output and
508 try to set headers later, an error message will appear telling you on which
509 line your output started. An alternative way of setting headers is using Perl's
510 BEGIN blocks. BEGIN blocks are executed as soon as possible, before anything
513 Because the interpreter that mod_perl uses never ends, C<END { }> blocks won't
514 work properly. You should use C<PLP_END { };> instead. Note that this is a not
515 a built-in construct, so it needs proper termination with a semi-colon (as do
518 Under mod_perl, modules are loaded only once. A good modular design can improve
519 performance because of this, but you will have to B<reload> the modules
520 yourself when there are newer versions.
522 The special hashes are tied hashes and do not always behave the way you expect,
523 especially when mixed with modules that expect normal CGI environments, like
524 CGI.pm. Read L<PLP::Fields> for information more about this.
528 A lot of questions are asked often, so before asking yours, please read the
529 FAQ at L<PLP::FAQ>. Some examples can be found at L<PLP::HowTo>.
533 No warranty, no guarantees. Use PLP at your own risk, as I disclaim all
538 Currently maintained by Mischa POSLAWSKY <perl@shiar.org>
540 Originally by Juerd Waalboer <juerd@cpan.org>
544 L<PLP::Functions>, L<PLP::Fields>, L<PLP::FAQ>, L<PLP::HowTo>
550 # About the #S lines:
551 # I wanted to implement Safe.pm so that scripts were run inside a
552 # configurable compartment. This needed for XS modules to be pre-loaded,
553 # hence the PLPsafe_* Apache directives. However, $safe->reval() lets
554 # Apache segfault. End of fun. The lines are still here so that I can
555 # s/^#S //g to re-implement them whenever this has been fixed.
557 #S # For PLPsafe scripts
559 #S my ($r, $code) = @_;
560 #S $r->send_http_header('text/plain');
562 #S unless ($PLP::safe) {
563 #S $PLP::safe = Safe->new('PLP::Script');
564 #S for ( map split, $r->dir_config->get('PLPsafe_module') ) {
565 #S $PLP::safe->share('*' . $_ . '::');
567 #S require $_ . '.pm';
569 #S $PLP::safe->permit(Opcode::full_opset());
570 #S $PLP::safe->deny(Opcode::opset(':dangerous'));
572 #S $PLP::safe->reval($code);
577 #S if ($PLP::use_safe) {
578 #S PLP::safe_eval($r, $PLP::code);
580 # eval qq{ package PLP::Script; $PLP::code; };
582 # PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/;
583 #S if ($PLP::use_safe) {
584 #S PLP::safe_eval($r, '$_->() for reverse @PLP::END');
586 # eval { package PLP::Script; $_->() for reverse @PLP::END };
588 # PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/;