v3.17 release

- More cleanups
- %get is now built on script start, no longer on first access
- Apache->request->print is used now under mod_perl, not print (faster)
- Small documentation fixes
- Setting a header when headers are already sent now tells you where output
  started
- Speedup in source()

diff --git a/Changes b/Changes
index cd5c76dc8ae7639225625cb6f641928fc9ba693a..486947ffb41c681933fe48a7b3591bd2e37335b6 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,3 +1,12 @@
+3.17 - August 21, 2002:
+- More cleanups
+- %get is now built on script start, no longer on first access
+- Apache->request->print is used now under mod_perl, not print (faster)
+- Small documentation fixes
+- Setting a header when headers are already sent now tells you where output
+  started
+- Speedup in source()
+
 3.16 - May 21, 2002:
 - Clean up a little
 - Changed compile-time <(...)> includes to use paths relative to the file they

diff --git a/PLP.pm b/PLP.pm
index 01f95ecd30e577d1499346bf1f0b366e45b337b2..2f9db4d6ea3a832c62e091f237168626d2ae8a0e 100644 (file)
--- a/PLP.pm
+++ b/PLP.pm
@@ -1,6 +1,6 @@
 package PLP;
 
-use v5.6;
+use 5.006;
 
 use PLP::Functions ();
 use PLP::Fields;
@@ -14,30 +14,172 @@ use Cwd ();
 
 use strict;
 
-our $VERSION = '3.16';
+our $VERSION = '3.17';
 
-# subs in this package:
-#  sendheaders                      Send headers
-#  source($path, $level, $linespec) Read and parse .plp files
-#  error($error, $type)             Handle errors
+# Subs in this package:
 #  _default_error($plain, $html)    Default error handler
-#  clean                            Reset variables
 #  cgi_init                         Initialization for CGI
-#  mod_perl_init($r)                Initialization for mod_perl
-#  start                            Start the initialized PLP script
+#  clean                            Reset variables
+#  error($error, $type)             Handle errors
 #  everything                       Do everything: CGI
 #  handler($r)                      Do everything: mod_perl
+#  mod_perl_init($r)                Initialization for mod_perl
+#  mod_perl_print                  Faster printing for mod_perl
+#  sendheaders                      Send headers
+#  source($path, $level, $linespec) Read and parse .plp files
+#  start                            Start the initialized PLP script
 
-# About the #S lines:
-# I wanted to implement Safe.pm so that scripts were run inside a
-# configurable compartment. This needed for XS modules to be pre-loaded,
-# hence the PLPsafe_* Apache directives. However, $safe->reval() lets
-# Apache segfault. End of fun. The lines are still here so that I can
-# s/^#S //m to re-implement them whenever this has been fixed.
+# The _init subs do the following:
+#  Set $PLP::code to the initial code
+#  Set $ENV{PLP_*} and makes PATH_INFO if needed
+#  Change the CWD
+
+# This gets referenced as the initial $PLP::ERROR
+sub _default_error {
+    my ($plain, $html) = @_; 
+    print qq{<table border=1 class="PLPerror"><tr><td>},
+         qq{<span><b>Debug information:</b><BR>$html</td></tr></table>};
+}
+
+# CGI initializer: parses PATH_TRANSLATED
+sub cgi_init {
+
+    $PLP::print = 'print';
+    
+    my $path = $ENV{PATH_TRANSLATED};
+    $ENV{PLP_NAME} = $ENV{PATH_INFO};
+    my $path_info;
+    while (not -f $path) {
+        if (not $path =~ s/(\/+[^\/]*)$//) {
+           print STDERR "PLP: Not found: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
+           PLP::error(undef, 404);
+           exit;
+       }
+       my $pi = $1;
+       $ENV{PLP_NAME} =~ s/\Q$pi\E$//;
+       $path_info = $pi . $path_info;
+    }
+    
+    if (not -r $path) {
+       print STDERR "PLP: Can't read: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
+       PLP::error(undef, 403);
+       exit;
+    }
+
+    delete @ENV{
+       qw(PATH_TRANSLATED SCRIPT_NAME SCRIPT_FILENAME PATH_INFO),
+        grep { /^REDIRECT_/ } keys %ENV
+    };
+
+    $ENV{PATH_INFO} = $path_info if defined $path_info;
+    $ENV{PLP_FILENAME} = $path;
+    my ($file, $dir) = File::Basename::fileparse($path);
+    chdir $dir;
+
+    $PLP::code = PLP::source($file, 0, undef, $path);
+}
+
+# This cleans up from previous requests, and sets the default $PLP::DEBUG
+sub clean {
+    @PLP::END = ();
+    $PLP::code = '';
+    $PLP::sentheaders = 0;
+    $PLP::DEBUG = 1;
+    $PLP::print = '';
+    $PLP::r = undef;
+    delete @ENV{ grep /^PLP_/, keys %ENV };
+}
+
+# Handles errors, uses subref $PLP::ERROR (default: \&_default_error)
+sub error {
+    my ($error, $type) = @_;
+    if (not defined $type or $type < 100) {
+       return undef unless $PLP::DEBUG & 1;
+       my $plain = $error;
+       (my $html = $plain) =~ s/([<&>])/'&#' . ord($1) . ';'/ge;
+       PLP::sendheaders() unless $PLP::sentheaders;
+       $PLP::ERROR->($plain, $html);
+    } else {
+       select STDOUT;
+       my ($short, $long) = @{
+           +{
+               404 => [
+                   'Not Found',
+                   "The requested URL $ENV{REQUEST_URI} was not found " .
+                   "on this server."
+               ],
+               403 => [
+                   'Forbidden',
+                   "You don't have permission to access $ENV{REQUEST_URI} " .
+                   "on this server."
+               ],
+           }->{$type}
+       };
+       print "Status: $type\nContent-Type: text/html\n\n",
+             qq{<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">\n<html>},
+             "<head>\n<title>$type $short</title>\n</head></body>\n<h1>$short",
+             "</h1>\n$long<p>\n<hr>\n$ENV{SERVER_SIGNATURE}</body></html>";
+    }
+}
+
+# This is run by the CGI script. (#!perl \n use PLP; PLP::everything;)
+sub everything {
+    clean();
+    cgi_init();
+    start();
+}
+
+# This is the mod_perl handler.
+sub handler {
+    require Apache::Constants;
+    clean();
+    if (my $ret = mod_perl_init($_[0])) {
+       return $ret;
+    }
+    #S start($_[0]);
+    start();
+    no strict 'subs';
+    return Apache::Constants::OK();
+}
+
+# mod_perl initializer: returns 0 on success, Apache error code on failure
+sub mod_perl_init {
+    our $r = shift;
+
+    $PLP::print = 'PLP::mod_perl_print';
+    
+    $ENV{PLP_FILENAME} = my $filename = $r->filename;
+    
+    unless (-f $filename) {
+       return Apache::Constants::NOT_FOUND();
+    }
+    unless (-r _) {
+       return Apache::Constants::FORBIDDEN();
+    }
+    
+    $ENV{PLP_NAME} = $r->uri;
+
+    our $use_cache = $r->dir_config('PLPcache') !~ /^off$/i;
+#S  our $use_safe  = $r->dir_config('PLPsafe')  =~ /^on$/i;
+    my $path = $r->filename();
+    my ($file, $dir) = File::Basename::fileparse($path);
+    chdir $dir;
+
+    $PLP::code = PLP::source($file, 0, undef, $path);
+
+    return 0; # OK
+}
+
+# FAST printing under mod_perl
+sub mod_perl_print {
+    return if @_ == 1 and not length $_[0];
+    PLP::sendheaders() unless $PLP::sentheaders;
+    $PLP::r->print(@_);
+}
 
 # Sends the headers waiting in %PLP::Script::header
 sub sendheaders () {
-    our $sentheaders = 1;
+    $PLP::sentheaders ||= [ caller 1 ? (caller 1)[1, 2] : (caller)[1, 2] ];
     print STDOUT "Content-Type: text/plain\n\n" if $PLP::DEBUG & 2;
     print STDOUT map("$_: $PLP::Script::header{$_}\n", keys %PLP::Script::header), "\n";
 }
@@ -50,10 +192,13 @@ sub sendheaders () {
     # this function parses a PLP file and returns Perl code, ready to be eval'ed
     sub source {
        my ($file, $level, $linespec, $path) = @_;
+       our $use_cache;
+
        # $file is displayed, $path is used. $path is constructed from $file if
        # not given.
-       $level = 0      if not defined $level;
-       $linespec = '1' if not defined $linespec;
+
+       $level = 0      unless defined $level;
+       $linespec = '1' unless defined $linespec;
        
        if ($level > 128) {
            %cached = ();
@@ -62,12 +207,13 @@ sub sendheaders () {
                : qq{\n#line $linespec\ndie qq[Include recursion detected];};
        }
 
-       our ($inA, $inB, $use_cache);
+       my $in_block = 0;   # 1 => "<:", 2 => "<:="
+       
        $path ||= File::Spec->rel2abs($file);
        
        my $source_start = $level
-           ? qq/\cQ;\n#line 1 "$file"\nprint q\cQ/
-           : qq/\n#line 1 "$file"\nprint q\cQ/;
+           ? qq/\cQ;\n#line 1 "$file"\n$PLP::print q\cQ/
+           : qq/\n#line 1 "$file"\n$PLP::print q\cQ/;
        
        if ($use_cache and exists $cached{$path}) {
            BREAKOUT: {
@@ -105,7 +251,7 @@ sub sendheaders () {
                    \G                  # Begin where left off
                    ( \z                # End
                    | <:=? | :>         # PLP tags     <:= ... :> <: ... :>
-                   | <\(.*?\)>         # Include tags <(...)>
+                   | <\([^)]*\)>         # Include tags <(...)>
                    | <[^:(][^<:]*      # Normal text
                    | :[^>][^<:]*       # Normal text
                    | [^<:]*            # Normal text
@@ -113,25 +259,28 @@ sub sendheaders () {
                /gxs;
                next LINE unless length $1;
                my $part = $1;
-               if ($part eq '<:=' and not $inA || $inB) {
-                   $inA = 1;
+               if ($part eq '<:=' and not $in_block) {
+                   $in_block = 2;
                    $source .= "\cQ, ";
-               } elsif ($part eq '<:' and not $inA || $inB) {
-                   $inB = 1;
+               } elsif ($part eq '<:' and not $in_block) {
+                   $in_block = 1;
                    $source .= "\cQ; ";
-               } elsif ($part eq ':>' and $inA) {
-                   $inA = 0;
-                   $source .= ", q\cQ";
-               } elsif ($part eq ':>' and $inB) {
-                   $inB = 0;
-                   $source .= "; print q\cQ";
-               } elsif ($part =~ /^<\((.*?)\)>\z/ and not $inA || $inB) {
-                   my $ipath = File::Spec->rel2abs($1, File::Basename::dirname($path));
+               } elsif ($part eq ':>' and $in_block) {
+                   $source .= (
+                         $in_block == 2
+                       ? ", q\cQ"               # 2
+                       : "; $PLP::print q\cQ"   # 1
+                   );
+                   $in_block = 0;
+               } elsif ($part =~ /^<\((.*?)\)>\z/ and not $in_block) {
+                   my $ipath = File::Spec->rel2abs(
+                       $1, File::Basename::dirname($path)
+                   );
                    $source .= source($1, $level + 1, undef, $ipath) .
                               qq/\cQ, \n#line $linenr "$file"\nq\cQ/;
                    push @{ $cached{$path}[0] }, $ipath;
                } else {
-                   $part =~ s/\\/\\\\/ if not $inA || $inB;
+                   $part =~ s/\\/\\\\/ unless $in_block;
                    $source .= $part;
                }
            }
@@ -148,141 +297,9 @@ sub sendheaders () {
     }
 }
 
-# Handles errors, uses subref $PLP::ERROR (default: \&_default_error)
-sub error {
-    my ($error, $type) = @_;
-    if (not defined $type or $type < 100) {
-       return undef unless $PLP::DEBUG & 1;
-       my $plain = $error;
-       (my $html = $plain) =~ s/([<&>])/'&#' . ord($1) . ';'/ge;
-       PLP::sendheaders unless $PLP::sentheaders;
-       $PLP::ERROR->($plain, $html);
-    } else {
-       select STDOUT;
-       my ($short, $long) = @{
-           +{
-               404 => [
-                   'Not Found',
-                   "The requested URL $ENV{REQUEST_URI} was not found on this server."
-               ],
-               403 => [
-                   'Forbidden',
-                   "You don't have permission to access $ENV{REQUEST_URI} on this server."
-               ],
-           }->{$type}
-       };
-       print "Status: $type\nContent-Type: text/html\n\n",
-             qq{<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">\n},
-             "<html><head>\n<title>--$type $short</title>\n</head></body>\n",
-             "<h1>$short</h1>\n$long<p>\n<hr>\n$ENV{SERVER_SIGNATURE}</body></html>";
-    }
-}
-
-# This gets referenced as the initial $PLP::ERROR
-sub _default_error {
-    my ($plain, $html) = @_; 
-    print qq{<table border=1 class="PLPerror"><tr><td>},
-         qq{<span><b>Debug information:</b><BR>$html</td></tr></table>};
-}
-
-# This cleans up from previous requests, and sets the default $PLP::DEBUG
-sub clean {
-    @PLP::END = ();
-    $PLP::code = '';
-    $PLP::sentheaders = 0;
-    $PLP::inA = 0;
-    $PLP::inB = 0;
-    $PLP::DEBUG = 1;
-    delete @ENV{ grep /^PLP_/, keys %ENV };
-}
-
-# The *_init subs do the following:
-#  o  Set $PLP::code to the initial code
-#  o  Set $ENV{PLP_*} and makes PATH_INFO if needed
-#  o  Change the CWD
-
-# CGI initializer: parses PATH_TRANSLATED
-sub cgi_init {
-    my $path = $ENV{PATH_TRANSLATED};
-    $ENV{PLP_NAME} = $ENV{PATH_INFO};
-    my $path_info;
-    while (not -f $path) {
-        if (not $path =~ s/(\/+[^\/]*)$//) {
-           print STDERR "PLP: Not found: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
-           PLP::error(undef, 404);
-           exit;
-       }
-       my $pi = $1;
-       $ENV{PLP_NAME} =~ s/\Q$pi\E$//;
-       $path_info = $pi . $path_info;
-    }
-    
-    if (not -r $path) {
-       print STDERR "PLP: Can't read: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
-       PLP::error(undef, 403);
-       exit;
-    }
-
-    delete @ENV{
-       qw(PATH_TRANSLATED SCRIPT_NAME SCRIPT_FILENAME PATH_INFO),
-        grep { /^REDIRECT_/ } keys %ENV
-    };
-
-    $ENV{PATH_INFO} = $path_info if defined $path_info;
-    $ENV{PLP_FILENAME} = $path;
-    my ($file, $dir) = File::Basename::fileparse($path);
-    chdir $dir;
-
-    $PLP::code = PLP::source($file, 0, undef, $path);
-}
-
-# mod_perl initializer: returns 0 on success, Apache error code on failure
-sub mod_perl_init {
-    my $r = shift;
-    
-    $ENV{PLP_FILENAME} = my $filename = $r->filename;
-    
-    unless (-f $filename) {
-       return Apache::Constants::NOT_FOUND();
-    }
-    unless (-r _) {
-       return Apache::Constants::FORBIDDEN();
-    }
-    
-    $ENV{PLP_NAME} = $r->uri;
-
-    our $use_cache = $r->dir_config('PLPcache') !~ /^off$/i;
-#S  our $use_safe  = $r->dir_config('PLPsafe')  =~ /^on$/i;
-    my $path = $r->filename();
-    my ($file, $dir) = File::Basename::fileparse($path);
-    chdir $dir;
-
-    $PLP::code = PLP::source($file, 0, undef, $path);
-
-    return 0; # OK
-}
-
-#S # For PLPsafe scripts
-#S sub safe_eval {
-#S     my ($r, $code) = @_;
-#S     $r->send_http_header('text/plain');
-#S     require Safe;
-#S     unless ($PLP::safe) {
-#S     $PLP::safe = Safe->new('PLP::Script');
-#S     for ( map split, $r->dir_config->get('PLPsafe_module') ) {
-#S         $PLP::safe->share('*' . $_ . '::');
-#S         s!::!/!g;
-#S         require $_ . '.pm';
-#S     }
-#S     $PLP::safe->permit(Opcode::full_opset());
-#S     $PLP::safe->deny(Opcode::opset(':dangerous'));
-#S     }
-#S     $PLP::safe->reval($code);
-#S }
 
 # Let the games begin! No lexicals may exist at this point.
 sub start {
-#S  my ($r) = @_;
     no strict;
     tie *PLPOUT, 'PLP::Tie::Print';
     select PLPOUT;
@@ -295,47 +312,20 @@ sub start {
        *headers = \%header;
        *cookies = \%cookie;
        PLP::Functions->import();
+
        # No lexicals may exist at this point.
        
-#S     if ($PLP::use_safe) {
-#S         PLP::safe_eval($r, $PLP::code);
-#S     } else {
-           eval qq{ package PLP::Script; $PLP::code; };
-#S     }
+       eval qq{ package PLP::Script; $PLP::code; };
        PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/;
 
-#S     if ($PLP::use_safe) {
-#S         PLP::safe_eval($r, '$_->() for reverse @PLP::END');
-#S     } else {
-           eval   { package PLP::Script; $_->() for reverse @PLP::END };
-#S     }
+       eval   { package PLP::Script; $_->() for reverse @PLP::END };
        PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/;
     }
     PLP::sendheaders() unless $PLP::sentheaders;
     select STDOUT;
     undef *{"PLP::Script::$_"} for keys %PLP::Script::;
-#    Symbol::delete_package('PLP::Script');
-#    The above does not work. TODO - find out why not.
-}
-
-# This is run by the CGI script. (#!perl \n use PLP; PLP::everything;)
-sub everything {
-    clean();
-    cgi_init();
-    start();
-}
-
-# This is the mod_perl handler.
-sub handler {
-    require Apache::Constants;
-    clean();
-    if (my $ret = mod_perl_init($_[0])) {
-       return $ret;
-    }
-#S  start($_[0]);
-    start();
-    no strict 'subs';
-    return Apache::Constants::OK();
+    # Symbol::delete_package('PLP::Script');
+    # The above does not work. TODO - find out why not.
 }
 
 1;
@@ -545,3 +535,46 @@ L<PLP::Functions>, L<PLP::Fields>, L<PLP::FAQ>, L<PLP::HowTo>
 
 =cut
 
+### Garbage bin
+
+# About the #S lines:
+# I wanted to implement Safe.pm so that scripts were run inside a
+# configurable compartment. This needed for XS modules to be pre-loaded,
+# hence the PLPsafe_* Apache directives. However, $safe->reval() lets
+# Apache segfault. End of fun. The lines are still here so that I can
+# s/^#S //g to re-implement them whenever this has been fixed.
+
+#S # For PLPsafe scripts
+#S sub safe_eval {
+#S     my ($r, $code) = @_;
+#S     $r->send_http_header('text/plain');
+#S     require Safe;
+#S     unless ($PLP::safe) {
+#S     $PLP::safe = Safe->new('PLP::Script');
+#S     for ( map split, $r->dir_config->get('PLPsafe_module') ) {
+#S         $PLP::safe->share('*' . $_ . '::');
+#S         s!::!/!g;
+#S         require $_ . '.pm';
+#S     }
+#S     $PLP::safe->permit(Opcode::full_opset());
+#S     $PLP::safe->deny(Opcode::opset(':dangerous'));
+#S     }
+#S     $PLP::safe->reval($code);
+#S }
+#S  my ($r) = @_;
+
+# start()
+#S     if ($PLP::use_safe) {
+#S         PLP::safe_eval($r, $PLP::code);
+#S     } else {
+#          eval qq{ package PLP::Script; $PLP::code; };
+#S     }
+#      PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/;
+#S     if ($PLP::use_safe) {
+#S         PLP::safe_eval($r, '$_->() for reverse @PLP::END');
+#S     } else {
+#          eval   { package PLP::Script; $_->() for reverse @PLP::END };
+#S     }
+#      PLP::error($@, 1) if $@ and $@ !~ /\cS\cT\cO\cP/;
+
+###

diff --git a/PLP/FAQ.pod b/PLP/FAQ.pod
index da4fbe7e6d6622eb4f004219e43096e9a7ab43ab..91965cb6ac6859b35bf874c31cb5b46cdb094f21 100644 (file)
--- a/PLP/FAQ.pod
+++ b/PLP/FAQ.pod
@@ -94,7 +94,7 @@ run-time errors. To do so, set the 0-bit (1) of C<$PLP::DEBUG> off. If you only
 want error reporting disabled for a single command, use Perl's C<eval BLOCK>
 function (not C<eval "">, but C<eval {}>, which is not slow or insecure.).
 
-    <: $PLP::DEBUG ^= 1 if $PLP::DEBUG & 1; :>
+    <: $PLP::DEBUG &= ~1; :>
 
 =item Can I have my own error messages?
 
@@ -115,7 +115,7 @@ version.
 There is. Set C<$PLP::DEBUG>'s 1-bit (2), and it will output a plain text header
 before outputting the other one.
 
-    <: $PLP::DEBUG ^= 2 unless $PLP::DEBUG & 2 :>
+    <: $PLP::DEBUG |= 2; :>
 
 =back
 

diff --git a/PLP/Fields.pm b/PLP/Fields.pm
index 7120c06215a3f1d1910178c811ea93b453747aa9..c19ac6cb5ccdc556ee918104982da73bdb52f387 100644 (file)
--- a/PLP/Fields.pm
+++ b/PLP/Fields.pm
@@ -2,62 +2,69 @@ package PLP::Fields;
 
 use strict;
 
-# Has only one function: doit(), which ties the hashes %get, %post, %fields and %header in
-# PLP::Script. Also generates %cookie immediately.
+# Has only one function: doit(), which ties the hashes %get, %post, %fields
+# and %header in PLP::Script. Also generates %cookie immediately.
 sub doit {
-    tie %PLP::Script::get, 'PLP::Tie::Delay', 'PLP::Script::get', sub {
-       my %get;
-       my $get = $ENV{QUERY_STRING};
-       if ($get ne ''){
-           for (split /[&;]/, $get) {
-               my @keyval = split /=/, $_, 2;
-               PLP::Functions::DecodeURI(@keyval);
-               $get{$keyval[0]} = $keyval[1] unless $keyval[0] =~ /^\@/;
-               push @{ $get{'@' . $keyval[0]} }, $keyval[1];
-           }
+
+    # %get
+    
+    my $get = \%PLP::Script::get;
+    if (length $ENV{QUERY_STRING}){
+       for (split /[&;]/, $ENV{QUERY_STRING}) {
+           my @keyval = split /=/, $_, 2;
+           PLP::Functions::DecodeURI(@keyval);
+           $get->{$keyval[0]} = $keyval[1] unless $keyval[0] =~ /^\@/;
+           push @{ $get->{ '@' . $keyval[0] } }, $keyval[1];
        }
-       return \%get;
-    };
+    }
+
+    # %post
 
     tie %PLP::Script::post, 'PLP::Tie::Delay', 'PLP::Script::post', sub {
        my %post;
        my $post;
+       
+       return \%post if $ENV{CONTENT_TYPE} !~
+           m!^(?:application/x-www-form-urlencoded|$)!;
+       
        if ($ENV{MOD_PERL}) {
            $post = Apache->request->content;
        } else {
-           read(*STDIN, $post, $ENV{CONTENT_LENGTH});
+           read *STDIN, $post, $ENV{CONTENT_LENGTH};
        }
-       if (defined $post
-           and $post ne ''
-           and $ENV{CONTENT_TYPE} =~ m!^(?:application/x-www-form-urlencoded|$)!
-       ){
-           for (split /&/, $post) {
-               my @keyval = split /=/, $_, 2;
-               PLP::Functions::DecodeURI(@keyval);
-               $post{$keyval[0]} = $keyval[1] unless $keyval[0] =~ /^\@/;
-               push @{ $post{'@' . $keyval[0]} }, $keyval[1];
-           }
+       
+       return \%post unless defined $post and length $post;
+       
+       for (split /&/, $post) {
+           my @keyval = split /=/, $_, 2;
+           PLP::Functions::DecodeURI(@keyval);
+           $post{$keyval[0]} = $keyval[1] unless $keyval[0] =~ /^\@/;
+           push @{ $post{ '@' . $keyval[0] } }, $keyval[1];
        }
+       
        return \%post;
     };
 
+    # %fields
+
     tie %PLP::Script::fields, 'PLP::Tie::Delay', 'PLP::Script::fields', sub {
-#      $PLP::Script::get{PLPdummy}, $PLP::Script::post{PLPdummy}; # Trigger creation
-#      No longer necessary, as PLP::Tie::Delay has been fixed since 3.00
-#      And fixed even more in 3.13
        return { %PLP::Script::get, %PLP::Script::post };
     };
 
+    # %header
+
     tie %PLP::Script::header, 'PLP::Tie::Headers';
 
-    if (defined($ENV{HTTP_COOKIE}) && $ENV{HTTP_COOKIE} ne ''){
+    # %cookie
+
+    if (defined $ENV{HTTP_COOKIE} and length $ENV{HTTP_COOKIE}) {
        for (split /; ?/, $ENV{HTTP_COOKIE}) {
            my @keyval = split /=/, $_, 2;
            $PLP::Script::cookie{$keyval[0]} ||= $keyval[1];
        }
     }
-
 }
+
 1;
 
 =head1 NAME
@@ -79,8 +86,8 @@ strings in query string and post content. C<%post> is not built if the content
 type is not C<application/x-www-form-urlencoded>. In post content, the
 semi-colon is not a valid separator.
 
-These hashes aren't built until they are used, to speed up your script if you
-don't use them. Because POST content can only be read once, you can C<use CGI;>
+%post isn't built until it is used, to speed up your script if you
+don't use it. Because POST content can only be read once, you can C<use CGI;>
 and just never access C<%post> to avoid its building.
 
 With a query string of C<key=firstvalue&key=secondvalue>, C<$get{key}> will
@@ -90,13 +97,15 @@ reference C<$get{'@key'}>, which will contain C<[ 'firstvalue', 'secondvalue'
 
 =item C<%fields>
 
-This hash combines %get and %post, and triggers creation of both. POST gets
+This hash combines %get and %post, and triggers creation of %post. POST gets
 precedence over GET (note: not even the C<@>-keys contain both values).
 
+This hash is built on first use, just like %post.
+
 =item C<%cookie>, C<%cookies>
 
 This is built immediately, because cookies are usually short in length. Cookies
-are not automatically url-decoded.
+are B<not> automatically url-decoded.
 
 =item C<%header>, C<%headers>
 

diff --git a/PLP/Tie/Delay.pm b/PLP/Tie/Delay.pm
index 1200651590552bfe9051b5ffe4f30316475079b2..423bfc8e6504e6e3d1c89b1a813c7ca9cc1d53b7 100644 (file)
--- a/PLP/Tie/Delay.pm
+++ b/PLP/Tie/Delay.pm
@@ -17,30 +17,37 @@ This module is part of the PLP internals and probably not of any use to others.
 sub _replace {
     my ($self) = @_;
     untie %{ $self->[0] };
-    %{ $self->[0] } = %{ $self->[1]->() };
+
+    # I'd like to use *{ $self->[0] } = $self->[1]->(); here,
+    # but that causes all sorts of problems. The hash is accessible from
+    # within this sub, but not where its creation was triggered.
+    # Immediately after the triggering statement, the hash becomes available
+    # to all: even the scope where the previous access attempt failed.
+    
+    %{ $self->[0] } = %{ $self->[1]->() }
 }
 
 sub TIEHASH {
-    my ($class, $hash, $source) = @_;
-    return bless [ $hash, $source ], $class;
+    # my ($class, $hash, $source) = @_;
+    return bless [ @_[1, 2] ], $_[0];
 }
 
 sub FETCH {
     my ($self, $key) = @_;
     $self->_replace;
-    return ${ $self->[0] }{$key};
+    return $self->[0]->{$key};
 }
 
 sub STORE {
     my ($self, $key, $value) = @_;
     $self->_replace;
-    return ${ $self->[0] }{$key} = $value;
+    return $self->[0]->{$key} = $value;
 }
 
 sub DELETE {
     my ($self, $key) = @_;
     $self->_replace;
-    return delete ${ $self->[0] }{$key};
+    return delete $self->[0]->{$key};
 }
 
 sub CLEAR {
@@ -52,7 +59,7 @@ sub CLEAR {
 sub EXISTS {
     my ($self, $key) = @_;
     $self->_replace;
-    return exists ${ $self->[0] }{$key};
+    return exists $self->[0]->{$key};
 }
 
 sub FIRSTKEY {
@@ -62,12 +69,12 @@ sub FIRSTKEY {
 }
 
 sub NEXTKEY {
-    my ($self) = @_;
     # Let's hope this never happens. (It's shouldn't.)
     return undef;
 }
 
 sub UNTIE   { }
+
 sub DESTROY { } 
 
 1;

diff --git a/PLP/Tie/Headers.pm b/PLP/Tie/Headers.pm
index f6c4319827f55a95a233c8d6afd579839510cb90..163ce5424ba968f234958989e4b6fe6f7ee29ac2 100644 (file)
--- a/PLP/Tie/Headers.pm
+++ b/PLP/Tie/Headers.pm
@@ -14,14 +14,14 @@ This module is part of the PLP internals and probably not of much use to others.
 
 =cut
 
-sub _lc($) {
+sub _lc ($) {
     local $_ = $_[0];
     tr/_/-/;
     return lc;
 }
 
 sub TIEHASH {
-    return bless [ # Defaults.
+    return bless [ # Defaults
         {
            'Content-Type'  => 'text/html',
            'X-PLP-Version' => $PLP::VERSION,
@@ -40,10 +40,15 @@ sub FETCH {
 
 sub STORE {
     my ($self, $key, $value) = @_;
-    croak 'Can\'t set headers after sending them!' if $PLP::sentheaders;
+    if ($PLP::sentheaders) {
+       my @caller = caller;
+       die "Can't set headers after sending them at " .
+           "$caller[1] line $caller[2].\n(Output started at " .
+           "$PLP::sentheaders->[0] line $PLP::sentheaders->[1].)\n"
+    }
     if (defined $self->[1]->{_lc $key}){
         $key = $self->[1]->{_lc $key};
-    }else{
+    } else {
         $self->[1]->{lc $key} = $key;
     }
     return ($self->[0]->{$key} = $value);

diff --git a/PLP/Tie/Print.pm b/PLP/Tie/Print.pm
index 3d5027a187dc2a1835190d46da87d40530975550..8ec4e4a389fd30c8636366ec1198364806fe4aca 100644 (file)
--- a/PLP/Tie/Print.pm
+++ b/PLP/Tie/Print.pm
@@ -12,23 +12,21 @@ This module is part of the PLP Internals and probably not of much use to others.
 
 =cut
 
-sub TIEHANDLE {
-    return bless {}, $_[0];
-}
+sub TIEHANDLE { bless \my $dummy, $_[0] }
 
-sub WRITE { undef; }
+sub WRITE { undef }
 
 sub PRINT {
-    my ($self, @param) = @_;
-    return if @param == 1 and not length $param[0];
+    shift;
+    return if @_ == 1 and not length $_[0];
     PLP::sendheaders() unless $PLP::sentheaders;
-    print STDOUT @param;
+    print STDOUT @_;
     select STDOUT;
 }
 
 sub PRINTF {
-    my ($self, @param) = @_;
-    printf STDOUT @param;
+    shift;
+    printf STDOUT @_;
     select STDOUT;
 }
 
@@ -42,5 +40,7 @@ sub CLOSE { undef }
 
 sub UNTIE { undef }
 
+sub DESTROY { undef }
+
 1;