From 1376138c9392575534de671ce7b6fbb05a578e19 Mon Sep 17 00:00:00 2001 From: Juerd Waalboer Date: Thu, 22 Aug 2002 13:06:02 +0000 Subject: [PATCH] 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() --- Changes | 9 + PLP.pm | 431 ++++++++++++++++++++++++--------------------- PLP/FAQ.pod | 4 +- PLP/Fields.pm | 77 ++++---- PLP/Tie/Delay.pm | 23 ++- PLP/Tie/Headers.pm | 13 +- PLP/Tie/Print.pm | 18 +- 7 files changed, 319 insertions(+), 256 deletions(-) diff --git a/Changes b/Changes index cd5c76d..486947f 100644 --- 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 01f95ec..2f9db4d 100644 --- 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{
}, + qq{Debug information:
$html
}; +} + +# 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{\n}, + "\n$type $short\n\n

$short", + "

\n$long

\n

\n$ENV{SERVER_SIGNATURE}"; + } +} + +# 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{\n}, - "\n--$type $short\n\n", - "

$short

\n$long

\n

\n$ENV{SERVER_SIGNATURE}"; - } -} - -# This gets referenced as the initial $PLP::ERROR -sub _default_error { - my ($plain, $html) = @_; - print qq{
}, - qq{Debug information:
$html
}; -} - -# 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, L, L, L =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 da4fbe7..91965cb 100644 --- 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 function (not C, but C, 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 7120c06..c19ac6c 100644 --- 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. 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 +%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 and just never access C<%post> to avoid its building. With a query string of C, 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 automatically url-decoded. =item C<%header>, C<%headers> diff --git a/PLP/Tie/Delay.pm b/PLP/Tie/Delay.pm index 1200651..423bfc8 100644 --- 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 f6c4319..163ce54 100644 --- 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 3d5027a..8ec4e4a 100644 --- 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; -- 2.30.0