From: Juerd Waalboer Date: Thu, 11 Apr 2002 08:57:15 +0000 (+0000) Subject: v3.02 release X-Git-Tag: 3.06~4 X-Git-Url: http://git.shiar.net/perl/plp/.git/commitdiff_plain/ef6d542255046b6f50d7047d8e5a1d85b9f01042 v3.02 release --- diff --git a/PLP.pm b/PLP.pm index 704870c..78e0dac 100644 --- a/PLP.pm +++ b/PLP.pm @@ -2,7 +2,7 @@ package PLP; # Not to be used without the CGI script; -our $VERSION = '3.01'; +our $VERSION = '3.02'; use PLP::Functions (); use PLP::Fields; @@ -10,7 +10,35 @@ use PLP::Tie::Headers; use PLP::Tie::Delay; use PLP::Tie::Print; -sub SendHeaders () { +=head1 PLP + +None of the functions in this module should be called by PLP scripts. + +Functions: + +=over 10 + +=item sendheaders + +Sends the headers waiting in %PLP::Script::header + +=item source + +Given a filename and optional level (level should be C<0> if it isn't called +by C itself), and optional linespec (used by C), +parses a PLP file and returns Perl code, ready to be eval'ed. + +=item error + +Given a description OR number, returns a piece of HTML, OR prints error headers. + +=item start + +Inits everything, reads the first file, sets environment. + +=cut + +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"; @@ -90,5 +118,57 @@ sub error { } } +sub start { + my $file = $ENV{PATH_TRANSLATED}; + $ENV{PLP_NAME} = $ENV{PATH_INFO}; + my $path_info; + while (not -f $file) { + if (not $file =~ s/(\/+[^\/]*)$//) { + print STDERR "PLP: Not found: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n"; + + if (exists $ENV{MOD_PERL}) { + Apache->request->uri($ENV{REQUEST_URI}); + print STDOUT "Status: 404 Not Found"; + Apache::exit(); + } else { + PLP::error(undef, 404); + exit; + } + } + my $pi = $1; + $ENV{PLP_NAME} =~ s/\Q$pi\E$//; + $path_info = $pi . $path_info; + } + + if (exists $ENV{MOD_PERL}) { + Apache->request->uri($ENV{REQUEST_URI}); + } + + if (not -r $file) { + print STDERR "PLP: Can't read: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n"; + if (exists $ENV{MOD_PERL}) { + print STDOUT "Status: 403 Forbidden"; + Apache::exit(); + } else { + 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} = $file; + (my $dir = $file) =~ s{/[^/]+$}[]; + chdir $dir; + + $PLP::code = PLP::source($file, 0); + tie *PLPOUT, 'PLP::Tie::Print'; + select PLPOUT; +} + 1; diff --git a/PLP/Fields.pm b/PLP/Fields.pm index 9945511..a14f038 100644 --- a/PLP/Fields.pm +++ b/PLP/Fields.pm @@ -17,7 +17,7 @@ sub doit { my %get; if ($ENV{QUERY_STRING} ne ''){ for (split /[&;]/, $ENV{QUERY_STRING}) { - my @keyval = split /=/; + my @keyval = split /=/, $_, 2; PLP::Functions::DecodeURI(@keyval); $get{$keyval[0]} = $keyval[1] unless $keyval[0] =~ /^\@/; push @{ $get{'@' . $keyval[0]} }, $keyval[1]; @@ -31,8 +31,8 @@ sub doit { 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 /=/; + 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]; @@ -50,7 +50,7 @@ sub doit { if (defined($ENV{HTTP_COOKIE}) && $ENV{HTTP_COOKIE} ne ''){ for (split /; ?/, $ENV{HTTP_COOKIE}) { - my @keyval = split /=/; + my @keyval = split /=/, $_, 2; $PLP::Script::cookie{$keyval[0]} ||= $keyval[1]; } } diff --git a/PLP/Tie/Print.pm b/PLP/Tie/Print.pm index 7563ba5..9d0c0a9 100644 --- a/PLP/Tie/Print.pm +++ b/PLP/Tie/Print.pm @@ -19,7 +19,7 @@ sub WRITE { undef; } sub PRINT { my ($self, @param) = @_; - PLP::SendHeaders() unless $PLP::sentheaders; + PLP::sendheaders() unless $PLP::sentheaders; print STDOUT @param; select STDOUT; } diff --git a/plp.cgi b/plp.cgi index 85d8210..850e305 100755 --- a/plp.cgi +++ b/plp.cgi @@ -2,7 +2,7 @@ use v5.6.0; use PLP; -die 'Wrong module version' if $PLP::VERSION ne '3.01'; +die 'Wrong module version' if $PLP::VERSION ne '3.02'; use vars qw($DEBUG); @@ -12,62 +12,12 @@ use strict; $PLP::sentheaders = 0; $PLP::inA = 0; $PLP::inB = 0; + delete @ENV{ grep /^PLP_/, keys %ENV }; } $DEBUG = 1; -our $mod_perl = exists $ENV{MOD_PERL}; -{ - my $file = $ENV{PATH_TRANSLATED}; - $ENV{PLP_NAME} = $ENV{PATH_INFO}; - my $path_info; - while (not -f $file) { - if (not $file =~ s/(\/+[^\/]*)$//) { - print STDERR "PLP: Not found: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n"; - - if ($mod_perl) { - Apache->request->uri($ENV{REQUEST_URI}); - print STDOUT "Status: 404 Not Found"; - Apache::exit(); - } else { - PLP::error(undef, 404); - exit; - } - } - my $pi = $1; - $ENV{PLP_NAME} =~ s/\Q$pi\E$//; - $path_info = $pi . $path_info; - } - - if ($mod_perl) { - Apache->request->uri($ENV{REQUEST_URI}); - } - - if (not -r $file) { - print STDERR "PLP: Can't read: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n"; - if (exists $ENV{MOD_PERL}) { - print STDOUT "Status: 403 Forbidden"; - Apache::exit(); - } else { - 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} = $file; - (my $dir = $file) =~ s{/[^/]+$}[]; - chdir $dir; - - $PLP::code = PLP::source($file, 0); - tie *PLPOUT, 'PLP::Tie::Print'; - select PLPOUT; -} +PLP::start(); { no strict; @@ -77,11 +27,12 @@ our $mod_perl = exists $ENV{MOD_PERL}; *headers = \%header; *cookies = \%cookie; PLP::Functions->import(); + # No lexicals may exist at this point. eval qq{package PLP::Script; $PLP::code}; } PLP::error($@, 1) if $@; select STDOUT; undef *{"PLP::Script::$_"} for keys %PLP::Script::; - PLP::SendHeaders() unless $PLP::sentheaders; + PLP::sendheaders() unless $PLP::sentheaders; }