From 0f5e78a789961923b45cae1a881c655fff9e7283 Mon Sep 17 00:00:00 2001 From: Juerd Waalboer Date: Tue, 9 Apr 2002 20:06:55 +0000 Subject: [PATCH] v3.00 release --- PLP.pm | 72 +++++++++++++++ PLP/Fields.pm | 59 ++++++++++++ plpfunc.pm => PLP/Functions.pm | 77 +++++++++------- PLP/Tie/Delay.pm | 73 +++++++++++++++ PLP/Tie/Headers.pm | 78 ++++++++++++++++ PLP/Tie/Print.pm | 44 +++++++++ plp.cgi | 152 ++++++++++++++---------------- plp.pm | 4 - plpfields.pm | 50 ---------- plptie.pm | 164 --------------------------------- 10 files changed, 442 insertions(+), 331 deletions(-) create mode 100644 PLP.pm create mode 100644 PLP/Fields.pm rename plpfunc.pm => PLP/Functions.pm (72%) create mode 100644 PLP/Tie/Delay.pm create mode 100644 PLP/Tie/Headers.pm create mode 100644 PLP/Tie/Print.pm delete mode 100644 plp.pm delete mode 100644 plpfields.pm delete mode 100644 plptie.pm diff --git a/PLP.pm b/PLP.pm new file mode 100644 index 0000000..7d3bf99 --- /dev/null +++ b/PLP.pm @@ -0,0 +1,72 @@ +package PLP; + +# Not to be used without the CGI script; + +our $VERSION = '3.00'; + +use PLP::Functions (); +use PLP::Fields; +use PLP::Tie::Headers; +use PLP::Tie::Delay; +use PLP::Tie::Print; + +sub SendHeaders () { + our $sentheaders = 1; + print STDOUT "Content-Type: text/plain\n\n" if $DEBUG & 2; + print STDOUT map("$_: $PLP::Script::header{$_}\n", keys %PLP::Script::header), "\n"; +}; + +sub source { + my ($path, $level) = @_; + our ($inA, $inB); + (my $file = $path) =~ s[.*/][]; + my $source = $level + ? qq/\cQ;\n#line 1 "$file"\nprint q\cQ/ + : qq/\n#line 1 "$file"\nprint q\cQ/; + my $linenr = 0; + local *SOURCE; + open SOURCE, $path or return $level + ? qq{\cQ; die qq[Can't open "\Q$path\E" (\Q$!\E)]; print q\cQ} + : qq{\ndie qq[Can't open "\Q$path\e" (\Q$!\E)];}; + LINE: while (defined (my $line = )) { + $linenr++; + for (;;) { + $line =~ / + \G # Begin where left off + ( \z # End + | <:=? | :> # PLP tags <:=? ... :> + | <\(.*?\)> # Include tags <(...)> + | <[^:(][^<:]* # Normal text + | :[^>][^<:]* # Normal text + | [^<:]* # Normal text + ) + /gxs; + next LINE unless length $1; + my $part = $1; + if ($part eq '<:=' and not $inA || $inB) { + $inA = 1; + $source .= "\cQ, "; + } elsif ($part eq '<:' and not $inA || $inB) { + $inB = 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) { + $source .= source($1, $level + 1) . + qq/\cQ, \n#line $linenr "$file"\nq\cQ/; + } else { + $part =~ s/\\/\\\\/ if not $inA || $inB; + $source .= $part; + } + } + } + $source .= "\cQ" unless $level; + return $source; +} + +1; + diff --git a/PLP/Fields.pm b/PLP/Fields.pm new file mode 100644 index 0000000..9945511 --- /dev/null +++ b/PLP/Fields.pm @@ -0,0 +1,59 @@ +#----------------------# + package PLP::Fields; +#----------------------# +use strict; + +=head1 PLP::Fields + +Has only one function: doit(), which ties the hashes %get, %post, %fields and %header in +PLP::Script. Also generates %cookie immediately. + + PLP::Fields::doit(); + +=cut + +sub doit { + tie %PLP::Script::get, 'PLP::Tie::Delay', 'PLP::Script::get', sub { + my %get; + if ($ENV{QUERY_STRING} ne ''){ + for (split /[&;]/, $ENV{QUERY_STRING}) { + my @keyval = split /=/; + PLP::Functions::DecodeURI(@keyval); + $get{$keyval[0]} = $keyval[1] unless $keyval[0] =~ /^\@/; + push @{ $get{'@' . $keyval[0]} }, $keyval[1]; + } + } + return \%get; + }; + + tie %PLP::Script::post, 'PLP::Tie::Delay', 'PLP::Script::post', sub { + my %post; + our $post = ; + if (defined($post) && $post ne '' && + ($ENV{CONTENT_TYPE} eq '' || $ENV{CONTENT_TYPE} eq 'application/x-www-form-urlencoded')){ + for (split /[&;]/, $post) { + my @keyval = split /=/; + PLP::Functions::DecodeURI(@keyval); + $post{$keyval[0]} = $keyval[1] unless $keyval[0] =~ /^\@/; + push @{ $post{'@' . $keyval[0]} }, $keyval[1]; + } + } + return \%post; + }; + + tie %PLP::Script::fields, 'PLP::Tie::Delay', 'PLP::Script::fields', sub { + $PLP::Script::get{PLPdummy}, $PLP::Script::post{PLPdummy}; # Trigger creation + return {%PLP::Script::get, %PLP::Script::post} + }; + + tie %PLP::Script::header, 'PLP::Tie::Headers'; + + if (defined($ENV{HTTP_COOKIE}) && $ENV{HTTP_COOKIE} ne ''){ + for (split /; ?/, $ENV{HTTP_COOKIE}) { + my @keyval = split /=/; + $PLP::Script::cookie{$keyval[0]} ||= $keyval[1]; + } + } + +} +1; diff --git a/plpfunc.pm b/PLP/Functions.pm similarity index 72% rename from plpfunc.pm rename to PLP/Functions.pm index 6d78066..9d7b33c 100644 --- a/plpfunc.pm +++ b/PLP/Functions.pm @@ -1,32 +1,43 @@ -#!/usr/bin/perl -# The shebang is only there for mcedit syntax highlights, as I'm too lazy to -# change the configfile. It won't hurt performance +#-------------------------# + package PLP::Functions; +#-------------------------# +use base 'Exporter'; +use strict; -#use URI::Escape; +our @EXPORT = qw/HiddenFields Entity DecodeURI EncodeURI Entity include + AddCookie ReadFile WriteFile AutoURL Counter Include/; -use strict; -use vars qw(%header); +sub Include ($) { + my ($file) = $_[0]; + $PLP::inA = 0; + $PLP::inB = 0; + eval PLP::source($file, 0); +} + +sub include ($) { + goto &Include; +} -sub HiddenFields($@){ +sub HiddenFields ($@) { my $hash = shift; my %saves; @saves{@_} = (); - for (keys %$hash){ + for (keys %$hash) { print qq{} unless exists $saves{$_}; } } -sub Entity(@){ +sub Entity (@) { my $ref; my @copy; - if (defined wantarray){ + if (defined wantarray) { @copy = @_; $ref = \@copy; - }else{ + } else { $ref = \@_; } - for (@$ref){ + for (@$ref) { eval { s/&/&/g; s/\"/"/g; @@ -43,36 +54,36 @@ sub Entity(@){ # Browsers do s/ /+/ - I don't care about RFC's, but I do care about real-life # situations. -sub DecodeURI(@){ +sub DecodeURI (@) { my @r; local $_; - for (@_){ + for (@_) { s/\+/%20/g; my $dec = $_; $dec =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr hex $1/ge; - if (defined wantarray){ + if (defined wantarray) { push @r, $dec; - }else{ + } else { eval {$_ = $dec}; # return undef if $@; # ;DecodeURI("foo"); } } return defined wantarray ? (wantarray ? @r : "@r") : undef; } -sub EncodeURI(@){ +sub EncodeURI (@) { my @r; local $_; - for (@_){ + for (@_) { my $esc = $_; $esc =~ s{ - ([^;\/?:@&=\$,A-Za-z0-9\-_.!~*\'()]) + ([^\/?:@\$,A-Za-z0-9\-_.!~*\'()]) }{ sprintf("%%%02x", ord($1)) }xge; - if (defined wantarray){ + if (defined wantarray) { push @r, $esc; - }else{ + } else { eval {$_ = $esc}; # return undef if $@; # ;EncodeURI("foo"); } @@ -80,32 +91,32 @@ sub EncodeURI(@){ return defined wantarray ? (wantarray ? @r : "@r") : undef; } -sub AddCookie($){ - if ($header{'Set-Cookie'}){ - $header{'Set-Cookie'} .= "\nSet-Cookie: $_[0]"; - }else{ - $header{'Set-Cookie'} = $_[0]; +sub AddCookie ($) { + if ($PLP::Script::header{'Set-Cookie'}) { + $PLP::Script::header{'Set-Cookie'} .= "\nSet-Cookie: $_[0]"; + } else { + $PLP::Script::header{'Set-Cookie'} = $_[0]; } } -sub ReadFile($){ +sub ReadFile ($) { local *READFILE; local $/ = undef; - open (READFILE, "<$_[0]"); + open (READFILE, '<', $_[0]); my $r = ; close READFILE; return $r; } -sub WriteFile($$){ +sub WriteFile ($$) { local *WRITEFILE; - open (WRITEFILE, ">$_[0]"); + open (WRITEFILE, '>', $_[0]); flock WRITEFILE, 2; print WRITEFILE $_[1]; close WRITEFILE; } -sub Counter($){ +sub Counter ($) { local *COUNTER; local $/ = undef; open COUNTER, "+<$_[0]" or @@ -120,7 +131,7 @@ sub Counter($){ return $counter; } -sub AutoURL($){ +sub AutoURL ($) { # This sub assumes your string does not match /(["<>])\cC\1/ my $ref; if (defined wantarray){ @@ -151,4 +162,6 @@ sub AutoURL($){ if ($@){ return defined wantarray ? @_ : undef } return defined wantarray ? $$ref : undef; } + + 1; diff --git a/PLP/Tie/Delay.pm b/PLP/Tie/Delay.pm new file mode 100644 index 0000000..022f424 --- /dev/null +++ b/PLP/Tie/Delay.pm @@ -0,0 +1,73 @@ +#--------------------------# + package PLP::Tie::Delay; +#--------------------------# +use strict; +no strict 'refs'; + +=head1 PLP::Tie::Delay + +Delays hash generation. Unties the hash on first access, and replaces it by the generated one. +Uses symbolic references, because circular ties make Perl go nuts :) + + tie %Some::hash, 'PLP::Tie::Delay', 'Some::hash', sub { \%generated_hash }; + +=cut + +sub _replace { + my ($self) = @_; + untie %{$self->[0]}; + %{$self->[0]} = %{ $self->[1]->() }; +} + +sub TIEHASH { + my ($class, $hash, $source) = @_; + return bless [$hash, $source], $class; +} + +sub FETCH { + my ($self, $key) = @_; + $self->_replace; + return ${$self->[0]}{$key}; +} + +sub STORE { + my ($self, $key, $value) = @_; + $self->_replace; + return ${$self->[0]}{$key} = $value; +} + +sub DELETE { + my ($self, $key) = @_; + $self->_replace; + return delete ${$self->[0]}{key}; +} + +sub CLEAR { + my ($self) = @_; + $self->_replace; + return %{$self->[0]}; +} + +sub EXISTS { + my ($self, $key) = @_; + $self->_replace; + return exists ${$self->[0]}{key}; +} + +sub FIRSTKEY { + my ($self) = @_; + $self->_replace; + return exists ${$self->[0]}{key}; +} + +sub NEXTKEY { + my ($self) = @_; + $self->_replace; + return each %$$self; +} + +sub UNTIE { } +sub DESTORY { } + +1; + diff --git a/PLP/Tie/Headers.pm b/PLP/Tie/Headers.pm new file mode 100644 index 0000000..e5f79a8 --- /dev/null +++ b/PLP/Tie/Headers.pm @@ -0,0 +1,78 @@ +#----------------------------# + package PLP::Tie::Headers; +#----------------------------# +use strict; +use Carp; + +=head1 PLP::Tie::Headers + +Makes a hash case insensitive, and sets some headers. <_> equals <->, so C<$foo{CONTENT_TYPE}> is +the same as C<$foo{'Content-Type'}>. + + tie %somehash, 'PLP::Tie::Headers'; + +=cut + +sub _lc($) { + local $_ = $_[0]; + tr/_/-/; + return lc; +} + +sub TIEHASH { + return bless [ # Defaults. + { + 'Content-Type' => 'text/html', + 'X-PLP-Version' => $PLP::VERSION, + }, + { + 'content-type' => 'Content-Type', + 'x-plp-version' => 'X-PLP-Version', + } + ], $_[0]; +} + +sub FETCH { + my ($self, $key) = @_; + return $self->[0]->{ $self->[1]->{_lc $key} }; +} + +sub STORE { + my ($self, $key, $value) = @_; + croak 'Can\'t set headers after sending them!' if $PLP::sentheaders; + if (defined $self->[1]->{_lc $key}){ + $key = $self->[1]->{_lc $key}; + }else{ + $self->[1]->{lc $key} = $key; + } + return ($self->[0]->{$key} = $value); +} + +sub DELETE { + my ($self, $key) = @_; + delete $self->[0]->{$key}; + return delete $self->[1]->{_lc $key}; +} + +sub CLEAR { + my $self = $_[0]; + return (@$self = ()); +} + +sub EXISTS { + my ($self, $key) = @_; + return exists $self->[1]->{_lc $key}; +} + +sub FIRSTKEY { + my $self = $_[0]; + keys %{$self->[0]}; + return each %{ $self->[0] }; # Key only, Tie::Hash doc is wrong. +} + +sub NEXTKEY { + return each %{ $_[0]->[0] }; +} + +1; + diff --git a/PLP/Tie/Print.pm b/PLP/Tie/Print.pm new file mode 100644 index 0000000..7563ba5 --- /dev/null +++ b/PLP/Tie/Print.pm @@ -0,0 +1,44 @@ +#--------------------# + package PLP::Tie::Print; +#--------------------# +use strict; + +=head1 PLP::Tie::Print + +Just prints to stdout, but sends headers if not sent before. + + tie *HANDLE, 'PLP::Tie::Print'; + +=cut + +sub TIEHANDLE { + return bless {}, $_[0]; +} + +sub WRITE { undef; } + +sub PRINT { + my ($self, @param) = @_; + PLP::SendHeaders() unless $PLP::sentheaders; + print STDOUT @param; + select STDOUT; +} + +sub PRINTF { + my ($self, @param) = @_; + printf STDOUT @param; + select STDOUT; +} + +sub READ { undef } + +sub READLINE { undef } + +sub GETC { '%' } + +sub CLOSE { undef } + +sub UNTIE { undef } + +1; + diff --git a/plp.cgi b/plp.cgi index 2158b60..6dbcee9 100755 --- a/plp.cgi +++ b/plp.cgi @@ -1,101 +1,91 @@ #!/usr/local/bin/perl +use v5.6.0; +use PLP; -use vars qw(%INTERNAL %get %post %fields %header %cookie %BLOCK $DEBUG $output); -use strict; +die 'Wrong module version' if $PLP::VERSION ne '3.00'; -sub SendHeaders(){ - $INTERNAL{sentheaders} = 1; - print STDOUT "Content-Type: text/plain\n\n" if $DEBUG & 2; - print STDOUT map("$_: $header{$_}\n", keys %header), "\n"; -}; +use vars qw($DEBUG); -sub rawprint(@){ - print STDOUT (@_); +use strict; +{ + $PLP::code = ''; + $PLP::sentheaders = 0; + $PLP::inA = 0; + $PLP::inB = 0; } - -$ENV{PLP_VERSION} = '2.40'; $DEBUG = 1; +our $mod_perl = exists $ENV{MOD_PERL}; -# We put most everything in %INTERNAL, just so the user won't screw it. -# We could also have used packages, but let's keep it simple. - -$INTERNAL{file} = $ENV{PATH_TRANSLATED}; -unless (-e $INTERNAL{file}){ - $ENV{REDIRECT_STATUS} = '404'; - print STDERR "PLP: Not found: $INTERNAL{file}\n"; - - #Change this if you have an error handling script. - print `/vhost/COMMON/err.cgi` || "Status: 404 Not found\n\nFile not found"; +{ + my $file = $ENV{PATH_TRANSLATED}; + $ENV{PLP_NAME} = $ENV{PATH_INFO}; + my $path_info; + while (not -f $file) { + if (not $file =~ s/(\/+[^\/]*)$//) { + $ENV{REDIRECT_STATUS} = '404'; + print STDERR "PLP: Not found: $file\n"; + + if ($mod_perl) { + Apache->request->uri($ENV{REQUEST_URI}); + print STDOUT "Status: 404 Not Found"; + Apache::exit(); + } else { + print STDOUT "Status: 404 Not Found\n\nNot found: $ENV{REQUEST_URI}"; + exit; + } + } + my $pi = $1; + $ENV{PLP_NAME} =~ s/\Q$pi\E$//; + $path_info = $pi . $path_info; + } - exit; -} - -require plp; - -($INTERNAL{dir} = $INTERNAL{file}) =~ s{^(.*)/(.*?)$}[$1]; -$ENV{FILE_NAME} = $2; -chdir $INTERNAL{dir}; - -($ENV{PLP_NAME} = $ENV{REQUEST_URI}) =~ s/\?.*$//; - - -$INTERNAL{qq} = ""; #^P -$INTERNAL{q} = ""; #^Q - -$INTERNAL{code} = ReadFile($INTERNAL{file}); - -while ($INTERNAL{code} =~ /<\((.*?)\)>/ ){ - (my $file = $1) =~ tr/[<>|//d; - $INTERNAL{code} =~ s//ReadFile($file)/e; -} - -$INTERNAL{code} =~ s(<:)($INTERNAL{q};)g; -$INTERNAL{code} =~ s(:>)(;\nprint q$INTERNAL{q})g; - -while ($INTERNAL{code} =~ /(<\[1(.*?)\]>(.*?)<\[2\]>(.*?)<\[3\]>)/s){ - $BLOCK{"$2-1"} = $3; - $BLOCK{"$2-2"} = $4; - $INTERNAL{code} =~ s///; #Redo last match -} -$INTERNAL{code} =~ s(\\\\\r?\n)()g; - -# This is bad and subject to removal. -$INTERNAL{code} =~ s(<\[([^>]*?):(.*?)\]>)($BLOCK{"${1}-1"}$2$BLOCK{"${1}-2"})g; -$INTERNAL{code} =~ s(<\[(?!/)(.*?)\]>)($BLOCK{"${1}-1"})g; -$INTERNAL{code} =~ s(<\[/(.*?)\]>)($BLOCK{"${1}-2"})g; + if ($mod_perl) { + Apache->request->uri($ENV{REQUEST_URI}); + } -# This too is bad and subject to removal. -$INTERNAL{code} =~ s(<{[ \08\09]*)($INTERNAL{q};print qq$INTERNAL{qq})g; -$INTERNAL{code} =~ s([ \08\09]*}>)($INTERNAL{qq};print q$INTERNAL{q})g; -$INTERNAL{code} = "print q$INTERNAL{q}$INTERNAL{code}$INTERNAL{q};"; + if (not -r $file) { + if (exists $ENV{MOD_PERL}) { + print STDOUT "Status: 403 Forbidden"; + Apache::exit(); + } else { + print STDOUT "Status: 403 Forbidden\n\nForbidden: $ENV{REQUEST_URI}"; + exit; + } + } -$INTERNAL{code} =~ s{print qq$INTERNAL{qq}$INTERNAL{qq};}[]g; -$INTERNAL{code} =~ s{print q$INTERNAL{q}$INTERNAL{q};}[]g; + delete @ENV{ + qw(PATH_TRANSLATED SCRIPT_NAME SCRIPT_FILENAME PATH_INFO), + grep { /^REDIRECT_/ } keys %ENV + }; -tie %header, 'PLP::Headers'; -tie *PLPOUT, 'PLP::Print'; + $ENV{PATH_INFO} = $path_info if defined $path_info; + $ENV{PLP_FILENAME} = $file; + (my $dir = $file) =~ s{/[^/]+$}[]; + chdir $dir; -# This is VERY bad, and will probably be removed. Use <: BEGIN { ... } -# :> instead -while ($INTERNAL{code} =~ s/<_(.*?)_>//s){ - $INTERNAL{pre} = $1; - { - no strict; - eval $INTERNAL{pre}; - if ($@ && $DEBUG & 1){ - print "\nDebug:\n $@"; - } - } + $PLP::code = PLP::source($file, 0); + tie *PLPOUT, 'PLP::Tie::Print'; + select PLPOUT; } -#$INTERNAL{headers}->(); -select PLPOUT; { no strict; - eval $INTERNAL{code}; - SendHeaders() unless $INTERNAL{sentheaders}; + PLP::Fields::doit(); + { + package PLP::Script; + *headers = \%header; + *cookies = \%cookie; + PLP::Functions->import(); + eval qq{package PLP::Script; $PLP::code}; + } + select STDOUT; + undef *{"PLP::Script::$_"} for keys %PLP::Script::; + PLP::SendHeaders() unless $PLP::sentheaders; if ($@ && $DEBUG & 1){ - print "
Debug
", Entity($@); + print $header{'Content-Type'} =~ m!^text/html!i + ? ("
Debug
", Entity($@)) + : ("[Debug]\n", $@); } } + diff --git a/plp.pm b/plp.pm deleted file mode 100644 index 52ce3e6..0000000 --- a/plp.pm +++ /dev/null @@ -1,4 +0,0 @@ -use plpfunc; -use plptie; -use plpfields; -1; \ No newline at end of file diff --git a/plpfields.pm b/plpfields.pm deleted file mode 100644 index 5325d69..0000000 --- a/plpfields.pm +++ /dev/null @@ -1,50 +0,0 @@ -#!/usr/bin/perl -# shebang only for color coding, just ignore it m'kay? -use strict; -use vars qw(%get %post %fields %cookie %INTERNAL); - -$INTERNAL{getsub} = sub { - my %get; - if ($ENV{QUERY_STRING} ne ''){ - for (split /&/, $ENV{QUERY_STRING}) { - my @keyval = split /=/; - DecodeURI(@keyval); - $get{$keyval[0]} = $keyval[1]; - } - } - return \%get; -}; - -$INTERNAL{postsub} = sub { - my %post; - $INTERNAL{post} = ; - if (defined($INTERNAL{post}) && $INTERNAL{post} ne '' && - ($ENV{CONTENT_TYPE} eq '' || $ENV{CONTENT_TYPE} eq 'application/x-www-form-urlencoded')){ - for (split /&/, $INTERNAL{post}) { - my @keyval = split /=/; - DecodeURI(@keyval); - $post{$keyval[0]} = $keyval[1]; - } - } - return \%post; -}; - -$INTERNAL{fieldssub} = sub { - $get{PLPdummy}, $post{PLPdummy}; # Trigger creation - return {%get, %post} -}; - -tie %get, 'PLP::Delay', 'main::get', $INTERNAL{getsub}; -tie %post, 'PLP::Delay', 'main::post', $INTERNAL{postsub}; -tie %fields, 'PLP::Delay', 'main::fields', $INTERNAL{fieldssub}; - -#%fields = (%get, %post); - -if (defined($ENV{HTTP_COOKIE}) && $ENV{HTTP_COOKIE} ne ''){ - for (split /; ?/, $ENV{HTTP_COOKIE}) { - my @keyval = split /=/; - $cookie{$keyval[0]} ||= $keyval[1]; - } -} - -1; diff --git a/plptie.pm b/plptie.pm deleted file mode 100644 index d96846e..0000000 --- a/plptie.pm +++ /dev/null @@ -1,164 +0,0 @@ -#!/usr/bin/perl -- Just for the fscking colors. - -package PLP::Headers; # Who cares. -use strict; -use Carp; - -sub _lc($){ - local $_ = $_[0]; - tr/_/-/; - return lc; -} - -sub TIEHASH { - return bless [ # Defaults. - { - 'Content-Type' => 'text/html', - 'X-PLP-Version' => $ENV{PLP_VERSION}, - }, - { - 'content-type' => 'Content-Type', - 'x-plp-version' => 'X-PLP-Version', - } - ], $_[0]; -} - -sub FETCH { - my ($self, $key) = @_; - return $self->[0]->{ $self->[1]->{_lc $key} }; -} - -sub STORE { - my ($self, $key, $value) = @_; - croak 'Can\'t set headers after sending them!' if $main::INTERNAL{sentheaders}; - if (defined $self->[1]->{_lc $key}){ - $key = $self->[1]->{_lc $key}; - }else{ - $self->[1]->{lc $key} = $key; - } - return ($self->[0]->{$key} = $value); -} - -sub DELETE { - my ($self, $key) = @_; - delete $self->[0]->{$key}; - return delete $self->[1]->{_lc $key}; -} - -sub CLEAR { - my $self = $_[0]; - return (@$self = ()); -} - -sub EXISTS { - my ($self, $key) = @_; - return exists $self->[1]->{_lc $key}; -} - -sub FIRSTKEY { - my $self = $_[0]; - keys %{$self->[0]}; - return each %{ $self->[0] }; # Key only, Tie::Hash doc is wrong. -} - -sub NEXTKEY { - return each %{ $_[0]->[0] }; -} - -package PLP::Print; -use strict; - -sub TIEHANDLE { - return bless {}, $_[0]; -} - -sub WRITE { undef; } - -sub PRINT { - my ($self, @param) = @_; - main::SendHeaders() unless $main::INTERNAL{sentheaders}; - print STDOUT @param; -} - -sub PRINTF { - my ($self, @param) = @_; - printf STDOUT @param; -} - -sub READ { undef } - -sub READLINE { undef } - -sub GETC { '%' } - -sub CLOSE { undef } - -sub UNTIE { undef } - -package PLP::Delay; -use strict; -no strict 'refs'; - -sub _replace { - my ($self) = @_; - untie %{$self->[0]}; - %{$self->[0]} = %{ $self->[1]->() }; -} - -sub TIEHASH { - my ($class, $hash, $source) = @_; - return bless [$hash, $source], $class; -} - -sub FETCH { - my ($self, $key) = @_; - $self->_replace; - return ${$self->[0]}{$key}; -} - -sub STORE { - my ($self, $key, $value) = @_; - $self->_replace; - return ${$self->[0]}{$key} = $value; -} - -sub DELETE { - my ($self, $key) = @_; - $self->_replace; - return delete ${$self->[0]}{key}; -} - -sub CLEAR { - my ($self) = @_; - $self->_replace; - return %{$self->[0]}; -} - -sub EXISTS { - my ($self, $key) = @_; - $self->_replace; - return exists ${$self->[0]}{key}; -} - -sub FIRSTKEY { - my ($self) = @_; - $self->_replace; - return exists ${$self->[0]}{key}; -} - -sub FIRSTKEY { - my ($self) = @_; - $self->_replace; - return 'PLPdummy'; # perl won't use the first key's value, - # damnit -} - -sub NEXTKEY { - my ($self) = @_; - $self->_replace; - return each %$$self; -} - -sub UNTIE { undef } - -1; -- 2.30.0