From b7a10718f1c1e5d0028cd367c337e9f85dc56618 Mon Sep 17 00:00:00 2001 From: Juerd Waalboer Date: Tue, 1 Jan 2002 13:29:37 +0000 Subject: [PATCH] v2.40 release --- .htaccess | 2 - INSTALL | 9 --- plp.cgi | 69 +++++++++++----------- plp.pm | 1 + plpfields.pm | 49 +++++++++------ plpfunc.pm | 49 +++++++++------ plptie.pm | 164 +++++++++++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 264 insertions(+), 79 deletions(-) delete mode 100644 .htaccess delete mode 100644 INSTALL create mode 100644 plptie.pm diff --git a/.htaccess b/.htaccess deleted file mode 100644 index 1d3d6e5..0000000 --- a/.htaccess +++ /dev/null @@ -1,2 +0,0 @@ -RemoveHandler .cgi -ForceType text/plain \ No newline at end of file diff --git a/INSTALL b/INSTALL deleted file mode 100644 index b34f4bf..0000000 --- a/INSTALL +++ /dev/null @@ -1,9 +0,0 @@ -# httpd.conf += - -AddHandler plp-document .plp -Action plp-document /cgi-bin/plp.cgi - -# /cgi-bin/ can be any globaly existing directory (I use /COMMON/ because -# cgi-bin's are local (mod_vhost_alias)) - -# read http://plp.juerd.nl/ \ No newline at end of file diff --git a/plp.cgi b/plp.cgi index 4c6e41e..2158b60 100755 --- a/plp.cgi +++ b/plp.cgi @@ -1,8 +1,20 @@ -#!/usr/bin/perl +#!/usr/local/bin/perl + +use vars qw(%INTERNAL %get %post %fields %header %cookie %BLOCK $DEBUG $output); use strict; -use vars qw($VERSION %INTERNAL %get %post %fields %header %cookie %BLOCK $DEBUG $output); -$VERSION = '2.22'; +sub SendHeaders(){ + $INTERNAL{sentheaders} = 1; + print STDOUT "Content-Type: text/plain\n\n" if $DEBUG & 2; + print STDOUT map("$_: $header{$_}\n", keys %header), "\n"; +}; + +sub rawprint(@){ + print STDOUT (@_); +} + + +$ENV{PLP_VERSION} = '2.40'; $DEBUG = 1; # We put most everything in %INTERNAL, just so the user won't screw it. @@ -11,7 +23,7 @@ $DEBUG = 1; $INTERNAL{file} = $ENV{PATH_TRANSLATED}; unless (-e $INTERNAL{file}){ $ENV{REDIRECT_STATUS} = '404'; - print STDERR "htmpl: Not found: $INTERNAL{file}\n"; + 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"; @@ -19,41 +31,41 @@ unless (-e $INTERNAL{file}){ exit; } -($INTERNAL{dir} = $INTERNAL{file}) =~ s{^(.*)/.*?$}[$1]; +require plp; + +($INTERNAL{dir} = $INTERNAL{file}) =~ s{^(.*)/(.*?)$}[$1]; +$ENV{FILE_NAME} = $2; chdir $INTERNAL{dir}; ($ENV{PLP_NAME} = $ENV{REQUEST_URI}) =~ s/\?.*$//; -use plp; $INTERNAL{qq} = ""; #^P $INTERNAL{q} = ""; #^Q -$header{'Content-Type'} = 'text/html'; -$header{Status} = '200 OK'; - $INTERNAL{code} = ReadFile($INTERNAL{file}); while ($INTERNAL{code} =~ /<\((.*?)\)>/ ){ - ($INTERNAL{file} = $1) =~ s/[<>\|]//g; - $INTERNAL{code} =~ s//ReadFile($INTERNAL{file})/e; + (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){ - $INTERNAL{naam} = $2; - $BLOCK{"$INTERNAL{naam}-1"} = $3; - $BLOCK{"$INTERNAL{naam}-2"} = $4; + $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; - +# 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};"; @@ -61,38 +73,29 @@ $INTERNAL{code} = "print q$INTERNAL{q}$INTERNAL{code}$INTERNAL{q};"; $INTERNAL{code} =~ s{print qq$INTERNAL{qq}$INTERNAL{qq};}[]g; $INTERNAL{code} =~ s{print q$INTERNAL{q}$INTERNAL{q};}[]g; +tie %header, 'PLP::Headers'; +tie *PLPOUT, 'PLP::Print'; +# 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){ + if ($@ && $DEBUG & 1){ print "\nDebug:\n $@"; } } } -print "\n\n" if $DEBUG == 2; - -{ - my %HEADER; - for (sort keys %header){ # Sort, so lowercase and underscores come first) - my $copy = $_; - tr/_/-/; - s/\b(\w)(\w*)/\U$1\E\L$2\E/g; - $HEADER{$_} = $header{$copy}; - } - for (keys %HEADER){ - print "$_: $HEADER{$_}\n"; - } - print "\n"; -} - +#$INTERNAL{headers}->(); +select PLPOUT; { no strict; eval $INTERNAL{code}; - if ($@ && $DEBUG){ + SendHeaders() unless $INTERNAL{sentheaders}; + if ($@ && $DEBUG & 1){ print "
Debug
", Entity($@); } } diff --git a/plp.pm b/plp.pm index 2d6f512..52ce3e6 100644 --- a/plp.pm +++ b/plp.pm @@ -1,3 +1,4 @@ use plpfunc; +use plptie; use plpfields; 1; \ No newline at end of file diff --git a/plpfields.pm b/plpfields.pm index 8f566a2..5325d69 100644 --- a/plpfields.pm +++ b/plpfields.pm @@ -3,29 +3,44 @@ use strict; use vars qw(%get %post %fields %cookie %INTERNAL); -if ($ENV{QUERY_STRING} ne ''){ - for (split /&/, $ENV{QUERY_STRING}) { - my @keyval = split /=/; - DecodeURI(@keyval); - $get{$keyval[0]} = $keyval[1]; +$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{post} = ; -if ($INTERNAL{post} ne ''){ - for (split /&/, $INTERNAL{post}) { - my @keyval = split /=/; - DecodeURI(@keyval); - $post{$keyval[0]} = $keyval[1]; +$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; -@fields{keys %post} = values %post; #%fields = (%get, %post); -if ($ENV{HTTP_COOKIE} ne ''){ +if (defined($ENV{HTTP_COOKIE}) && $ENV{HTTP_COOKIE} ne ''){ for (split /; ?/, $ENV{HTTP_COOKIE}) { my @keyval = split /=/; $cookie{$keyval[0]} ||= $keyval[1]; diff --git a/plpfunc.pm b/plpfunc.pm index a113c76..6d78066 100644 --- a/plpfunc.pm +++ b/plpfunc.pm @@ -1,14 +1,16 @@ #!/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 -use URI::Escape; + +#use URI::Escape; + use strict; use vars qw(%header); sub HiddenFields($@){ my $hash = shift; my %saves; - $saves{@_} = (); + @saves{@_} = (); for (keys %$hash){ print qq{} unless exists $saves{$_}; @@ -34,7 +36,7 @@ sub Entity(@){ s/\t/        /g; s/ /  /g; }; - if ($@){ return defined wantarray ? @_ : undef } +# if ($@){ return defined wantarray ? @_ : undef } } return defined wantarray ? (wantarray ? @$ref : "@$ref") : undef; } @@ -42,51 +44,61 @@ sub Entity(@){ # Browsers do s/ /+/ - I don't care about RFC's, but I do care about real-life # situations. sub DecodeURI(@){ - my @r; + my @r; + local $_; for (@_){ s/\+/%20/g; - my $dec = uri_unescape($_); + my $dec = $_; + $dec =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr hex $1/ge; if (defined wantarray){ push @r, $dec; }else{ eval {$_ = $dec}; - return undef if $@; # ;DecodeURI("foo"); +# return undef if $@; # ;DecodeURI("foo"); } } return defined wantarray ? (wantarray ? @r : "@r") : undef; } sub EncodeURI(@){ my @r; + local $_; for (@_){ - my $esc = uri_escape($_, '^;\/?:@&=\$,A-Za-z0-9\-_.!~*\'()'); + my $esc = $_; + $esc =~ + s{ + ([^;\/?:@&=\$,A-Za-z0-9\-_.!~*\'()]) + }{ + sprintf("%%%02x", ord($1)) + }xge; if (defined wantarray){ push @r, $esc; }else{ eval {$_ = $esc}; - return undef if $@; # ;EncodeURI("foo"); +# return undef if $@; # ;EncodeURI("foo"); } } return defined wantarray ? (wantarray ? @r : "@r") : undef; } sub AddCookie($){ - if ($header{'set-cookie'}){ - $header{'set-cookie'} .= "\nset-cookie: $_[0]"; + if ($header{'Set-Cookie'}){ + $header{'Set-Cookie'} .= "\nSet-Cookie: $_[0]"; }else{ - $header{'set-cookie'} = $_[0]; + $header{'Set-Cookie'} = $_[0]; } } sub ReadFile($){ - my $o = $/; undef $/; - open (READFILE, $_[0]); + local *READFILE; + local $/ = undef; + open (READFILE, "<$_[0]"); my $r = ; close READFILE; - $/ = $o; return $r; } sub WriteFile($$){ + local *WRITEFILE; open (WRITEFILE, ">$_[0]"); flock WRITEFILE, 2; print WRITEFILE $_[1]; @@ -94,8 +106,10 @@ sub WriteFile($$){ } sub Counter($){ - my $o = $/; undef $/; - open COUNTER, "+<$_[0]"; + local *COUNTER; + local $/ = undef; + open COUNTER, "+<$_[0]" or + open COUNTER, ">$_[0]" or return undef; flock COUNTER, 2; seek COUNTER, 0, 0; my $counter = ; @@ -103,7 +117,6 @@ sub Counter($){ truncate COUNTER, 0; print COUNTER ++$counter; close COUNTER; - $/ = $o; return $counter; } @@ -138,4 +151,4 @@ sub AutoURL($){ if ($@){ return defined wantarray ? @_ : undef } return defined wantarray ? $$ref : undef; } -1; \ No newline at end of file +1; diff --git a/plptie.pm b/plptie.pm new file mode 100644 index 0000000..d96846e --- /dev/null +++ b/plptie.pm @@ -0,0 +1,164 @@ +#!/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