X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCGI.pm;h=c0cb5fd518a75113f1dae6241becdbf216b0dcac;hb=9bea678f36dc293400ada67aa122ef456a9dcf74;hp=2ae635ead24a11eaf77344aae4a1da9180b138cc;hpb=47e3cabda9bbdb8cfcaa856cd58b1452b57cb369;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/CGI.pm b/lib/CGI.pm index 2ae635e..c0cb5fd 100644 --- a/lib/CGI.pm +++ b/lib/CGI.pm @@ -1,5 +1,5 @@ package CGI; -require 5.001; +require 5.004; # See the bottom of this file for the POD documentation. Search for the # string '=head'. @@ -8,42 +8,80 @@ require 5.001; # documentation in manual or html file format (these utilities are part of the # Perl 5 distribution). -# Copyright 1995-1997 Lincoln D. Stein. All rights reserved. +# Copyright 1995-1998 Lincoln D. Stein. All rights reserved. # It may be used and modified freely, but I do request that this copyright # notice remain attached to the file. You may modify this module as you # wish, but if you redistribute a modified version, please attach a note # listing the modifications you have made. # The most recent version and complete docs are available at: -# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html -# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ +# http://stein.cshl.org/WWW/software/CGI/ -# Set this to 1 to enable copious autoloader debugging messages -$AUTOLOAD_DEBUG=0; - -# Set this to 1 to enable NPH scripts -# or: -# 1) use CGI qw(:nph) -# 2) $CGI::nph(1) -# 3) print header(-nph=>1) -$NPH=0; - -$CGI::revision = '$Id: CGI.pm,v 2.35 1997/4/20 20:19 lstein Exp $'; -$CGI::VERSION='2.35'; - -# OVERRIDE THE OS HERE IF CGI.pm GUESSES WRONG -# $OS = 'UNIX'; -# $OS = 'MACINTOSH'; -# $OS = 'WINDOWS'; -# $OS = 'VMS'; -# $OS = 'OS2'; +$CGI::revision = '$Id: CGI.pm,v 1.18 1999/06/09 14:52:45 lstein Exp $'; +$CGI::VERSION='2.53'; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. # $TempFile::TMPDIRECTORY = '/usr/tmp'; +# >>>>> Here are some globals that you might want to adjust <<<<<< +sub initialize_globals { + # Set this to 1 to enable copious autoloader debugging messages + $AUTOLOAD_DEBUG = 0; + + # Change this to the preferred DTD to print in start_html() + # or use default_dtd('text of DTD to use'); + $DEFAULT_DTD = '-//IETF//DTD HTML//EN'; + + # Set this to 1 to enable NPH scripts + # or: + # 1) use CGI qw(-nph) + # 2) $CGI::nph(1) + # 3) print header(-nph=>1) + $NPH = 0; + + # Set this to 1 to disable debugging from the + # command line + $NO_DEBUG = 0; + + # Set this to 1 to make the temporary files created + # during file uploads safe from prying eyes + # or do... + # 1) use CGI qw(:private_tempfiles) + # 2) $CGI::private_tempfiles(1); + $PRIVATE_TEMPFILES = 0; + + # Set this to a positive value to limit the size of a POSTing + # to a certain number of bytes: + $POST_MAX = -1; + + # Change this to 1 to disable uploads entirely: + $DISABLE_UPLOADS = 0; + + # Automatically determined -- don't change + $EBCDIC = 0; + + # Change this to 1 to suppress redundant HTTP headers + $HEADERS_ONCE = 0; + + # separate the name=value pairs by semicolons rather than ampersands + $USE_PARAM_SEMICOLONS = 0; + + # Other globals that you shouldn't worry about. + undef $Q; + $BEEN_THERE = 0; + undef @QUERY_PARAM; + undef %EXPORT; + + # prevent complaints by mod_perl + 1; +} + # ------------------ START OF THE LIBRARY ------------ +# make mod_perlhappy +initialize_globals(); + # FIGURE OUT THE OS WE'RE RUNNING UNDER # Some systems support the $^O variable. If not # available then require() the Config library @@ -54,10 +92,12 @@ unless ($OS) { } } if ($OS=~/Win/i) { - $OS = 'WINDOWS'; + $OS = 'WINDOWS'; } elsif ($OS=~/vms/i) { - $OS = 'VMS'; -} elsif ($OS=~/Mac/i) { + $OS = 'VMS'; +} elsif ($OS=~/dos/i) { + $OS = 'DOS'; +} elsif ($OS=~/^MacOS$/i) { $OS = 'MACINTOSH'; } elsif ($OS=~/os2/i) { $OS = 'OS2'; @@ -66,80 +106,117 @@ if ($OS=~/Win/i) { } # Some OS logic. Binary mode enabled on DOS, NT and VMS -$needs_binmode = $OS=~/^(WINDOWS|VMS|OS2)/; +$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin)/; # This is the default class for the CGI object to use when all else fails. $DefaultClass = 'CGI' unless defined $CGI::DefaultClass; + # This is where to look for autoloaded routines. $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass; # The path separator is a slash, backslash or semicolon, depending # on the paltform. $SL = { - UNIX=>'/', - OS2=>'\\', - WINDOWS=>'\\', - MACINTOSH=>':', - VMS=>'\\' + UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/' }->{$OS}; +# This no longer seems to be necessary # Turn on NPH scripts by default when running under IIS server! -$NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; +# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; +$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; # Turn on special checking for Doug MacEachern's modperl -if (defined($ENV{'GATEWAY_INTERFACE'}) && ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/)) { - $NPH++; +if (exists $ENV{'GATEWAY_INTERFACE'} + && + ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//)) +{ $| = 1; - $SEQNO = 1; + require Apache; +} +# Turn on special checking for ActiveState's PerlEx +$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/; + +# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning +# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF +# and sometimes CR). The most popular VMS web server +# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't +# use ASCII, so \015\012 means something different. I find this all +# really annoying. +$EBCDIC = "\t" ne "\011"; +if ($OS eq 'VMS') { + $CRLF = "\n"; +} elsif ($EBCDIC) { + $CRLF= "\r\n"; +} else { + $CRLF = "\015\012"; +} + +if ($EBCDIC) { +@A2E = ( + 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31, + 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97, +240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111, +124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214, +215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109, +121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150, +151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7, + 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27, + 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255, + 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188, +144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171, +100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119, +172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89, + 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87, +140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223 + ); } -# This is really "\r\n", but the meaning of \n is different -# in MacPerl, so we resort to octal here. -$CRLF = "\015\012"; - if ($needs_binmode) { $CGI::DefaultClass->binmode(main::STDOUT); $CGI::DefaultClass->binmode(main::STDIN); $CGI::DefaultClass->binmode(main::STDERR); } -# Cute feature, but it broke when the overload mechanism changed... -# %OVERLOAD = ('""'=>'as_string'); - %EXPORT_TAGS = ( - ':html2'=>[h1..h6,qw/p br hr ol ul li dl dt dd menu code var strong em - tt i b blockquote pre img a address cite samp dfn html head - base body link nextid title meta kbd start_html end_html - input Select option/], - ':html3'=>[qw/div table caption th td TR Tr super sub strike applet PARAM embed basefont/], - ':netscape'=>[qw/blink frameset frame script font fontsize center/], - ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group - submit reset defaults radio_group popup_menu button autoEscape - scrolling_list image_button start_form end_form startform endform - start_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/], - ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump - raw_cookie request_method query_string accept user_agent remote_host - remote_addr referer server_name server_software server_port server_protocol - virtual_host remote_ident auth_type http - remote_user user_name header redirect import_names put/], - ':ssl' => [qw/https/], - ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/], - ':html' => [qw/:html2 :html3 :netscape/], - ':standard' => [qw/:html2 :form :cgi/], - ':all' => [qw/:html2 :html3 :netscape :form :cgi/] - ); + ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em + tt u i b blockquote pre img a address cite samp dfn html head + base body Link nextid title meta kbd start_html end_html + input Select option comment/], + ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param + embed basefont style span layer ilayer font frameset frame script small big/], + ':netscape'=>[qw/blink fontsize center/], + ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group + submit reset defaults radio_group popup_menu button autoEscape + scrolling_list image_button start_form end_form startform endform + start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/], + ':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump + raw_cookie request_method query_string Accept user_agent remote_host content_type + remote_addr referer server_name server_software server_port server_protocol + virtual_host remote_ident auth_type http use_named_parameters + save_parameters restore_parameters param_fetch + remote_user user_name header redirect import_names put + Delete Delete_all url_param cgi_error/], + ':ssl' => [qw/https/], + ':imagemap' => [qw/Area Map/], + ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/], + ':html' => [qw/:html2 :html3 :netscape/], + ':standard' => [qw/:html2 :html3 :form :cgi/], + ':push' => [qw/multipart_init multipart_start multipart_end/], + ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal/] + ); # to import symbols into caller sub import { my $self = shift; + +# This causes modules to clash. +# undef %EXPORT_OK; +# undef %EXPORT; + + $self->_setup_symbols(@_); my ($callpack, $callfile, $callline) = caller; - foreach (@_) { - $NPH++, next if $_ eq ':nph'; - foreach (&expand_tags($_)) { - tr/a-zA-Z0-9_//cd; # don't allow weird function names - $EXPORT{$_}++; - } - } + # To allow overriding, search through the packages # Till we find one in which the correct subroutine is defined. my @packages = ($self,@{"$self\:\:ISA"}); @@ -156,8 +233,14 @@ sub import { } } +sub compile { + my $pack = shift; + $pack->_setup_symbols('-compile',@_); +} + sub expand_tags { my($tag) = @_; + return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/; my(@r); return ($tag) unless $EXPORT_TAGS{$tag}; foreach (@{$EXPORT_TAGS{$tag}}) { @@ -174,8 +257,11 @@ sub new { my($class,$initializer) = @_; my $self = {}; bless $self,ref $class || $class || $DefaultClass; - $CGI::DefaultClass->_reset_globals() if $MOD_PERL; - $initializer = to_filehandle($initializer) if $initializer; + if ($MOD_PERL) { + Apache->request->register_cleanup(\&CGI::_reset_globals); + undef $NPH; + } + $self->_reset_globals if $PERLEX; $self->init($initializer); return $self; } @@ -222,98 +308,32 @@ sub param { $name = $p[0]; } - return () unless defined($name) && $self->{$name}; + return unless defined($name) && $self->{$name}; return wantarray ? @{$self->{$name}} : $self->{$name}->[0]; } -#### Method: delete -# Deletes the named parameter entirely. -#### -sub delete { - my($self,$name) = self_or_default(@_); - delete $self->{$name}; - delete $self->{'.fieldnames'}->{$name}; - @{$self->{'.parameters'}}=grep($_ ne $name,$self->param()); - return wantarray ? () : undef; -} - sub self_or_default { - return @_ if defined($_[0]) && !ref($_[0]) && ($_[0] eq 'CGI'); + return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI'); unless (defined($_[0]) && - ref($_[0]) && - (ref($_[0]) eq 'CGI' || - eval "\$_[0]->isaCGI()")) { # optimize for the common case - $CGI::DefaultClass->_reset_globals() - if defined($Q) && $MOD_PERL && $CGI::DefaultClass->_new_request(); + (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case + ) { $Q = $CGI::DefaultClass->new unless defined($Q); unshift(@_,$Q); } return @_; } -sub _new_request { - return undef unless (defined(Apache->seqno()) or eval { require Apache }); - if (Apache->seqno() != $SEQNO) { - $SEQNO = Apache->seqno(); - return 1; - } else { - return undef; - } -} - -sub _reset_globals { - undef $Q; - undef @QUERY_PARAM; -} - sub self_or_CGI { local $^W=0; # prevent a warning if (defined($_[0]) && (substr(ref($_[0]),0,3) eq 'CGI' - || eval "\$_[0]->isaCGI()")) { + || UNIVERSAL::isa($_[0],'CGI'))) { return @_; } else { return ($DefaultClass,@_); } } -sub isaCGI { - return 1; -} - -#### Method: import_names -# Import all parameters into the given namespace. -# Assumes namespace 'Q' if not specified -#### -sub import_names { - my($self,$namespace) = self_or_default(@_); - $namespace = 'Q' unless defined($namespace); - die "Can't import names into 'main'\n" - if $namespace eq 'main'; - my($param,@value,$var); - foreach $param ($self->param) { - # protect against silly names - ($var = $param)=~tr/a-zA-Z0-9_/_/c; - $var = "${namespace}::$var"; - @value = $self->param($param); - @{$var} = @value; - ${$var} = $value[0]; - } -} - -#### Method: use_named_parameters -# Force CGI.pm to use named parameter-style method calls -# rather than positional parameters. The same effect -# will happen automatically if the first parameter -# begins with a -. -sub use_named_parameters { - my($self,$use_named) = self_or_default(@_); - return $self->{'.named'} unless defined ($use_named); - - # stupidity to avoid annoying warnings - return $self->{'.named'}=$use_named; -} - ######################################## # THESE METHODS ARE MORE OR LESS PRIVATE # GO TO THE __DATA__ SECTION TO SEE MORE @@ -329,14 +349,13 @@ sub use_named_parameters { sub init { my($self,$initializer) = @_; - my($query_string,@lines); - my($meth) = ''; + my($query_string,$meth,$content_length,$fh,@lines) = ('','','',''); + local($/) = "\n"; # if we get called more than once, we want to initialize # ourselves from the original query (which may be gone # if it was read from STDIN originally.) - if (defined(@QUERY_PARAM) && !defined($initializer)) { - + if (@QUERY_PARAM && !defined($initializer)) { foreach (@QUERY_PARAM) { $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_}); } @@ -344,12 +363,37 @@ sub init { } $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'}); + $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0; + + $fh = to_filehandle($initializer) if $initializer; - # If initializer is defined, then read parameters - # from it. METHOD: { - if (defined($initializer)) { + # avoid unreasonably large postings + if (($POST_MAX > 0) && ($content_length > $POST_MAX)) { + $self->cgi_error("413 Request entity too large"); + last METHOD; + } + + # Process multipart postings, but only if the initializer is + # not defined. + if ($meth eq 'POST' + && defined($ENV{'CONTENT_TYPE'}) + && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data| + && !defined($initializer) + ) { + my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/; + $self->read_multipart($boundary,$content_length); + last METHOD; + } + + # If initializer is defined, then read parameters + # from it. + if (defined($initializer)) { + if (UNIVERSAL::isa($initializer,'CGI')) { + $query_string = $initializer->query_string; + last METHOD; + } if (ref($initializer) && ref($initializer) eq 'HASH') { foreach (keys %$initializer) { $self->param('-name'=>$_,'-value'=>$initializer->{$_}); @@ -357,9 +401,8 @@ sub init { last METHOD; } - $initializer = $$initializer if ref($initializer); - if (defined(fileno($initializer))) { - while (<$initializer>) { + if (defined($fh) && ($fh ne '')) { + while (<$fh>) { chomp; last if /^=/; push(@lines,$_); @@ -372,49 +415,45 @@ sub init { } last METHOD; } + + # last chance -- treat it as a string + $initializer = $$initializer if ref($initializer) eq 'SCALAR'; $query_string = $initializer; + last METHOD; } - # If method is GET or HEAD, fetch the query from - # the environment. - if ($meth=~/^(GET|HEAD)$/) { - $query_string = $ENV{'QUERY_STRING'}; - last METHOD; - } - - # If the method is POST, fetch the query from standard - # input. - if ($meth eq 'POST') { - - if (defined($ENV{'CONTENT_TYPE'}) - && - $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|) { - my($boundary) = $ENV{'CONTENT_TYPE'}=~/boundary=(\S+)/; - $self->read_multipart($boundary,$ENV{'CONTENT_LENGTH'}); + # If method is GET or HEAD, fetch the query from + # the environment. + if ($meth=~/^(GET|HEAD)$/) { + if ($MOD_PERL) { + $query_string = Apache->request->args; } else { - - $self->read_from_client(\*STDIN,\$query_string,$ENV{'CONTENT_LENGTH'},0) - if $ENV{'CONTENT_LENGTH'} > 0; - + $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; } + last METHOD; + } + + if ($meth eq 'POST') { + $self->read_from_client(\*STDIN,\$query_string,$content_length,0) + if $content_length > 0; # Some people want to have their cake and eat it too! # Uncomment this line to have the contents of the query string # APPENDED to the POST data. - # $query_string .= ($query_string ? '&' : '') . $ENV{'QUERY_STRING'} if $ENV{'QUERY_STRING'}; + # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; last METHOD; } - - # If neither is set, assume we're being debugged offline. + + # If $meth is not of GET, POST or HEAD, assume we're being debugged offline. # Check the command line and then the standard input for data. # We use the shellwords package in order to behave the way that # UN*X programmers expect. - $query_string = &read_from_cmdline; + $query_string = read_from_cmdline() unless $NO_DEBUG; } - + # We now have the query string in hand. We do slightly # different things for keyword lists and parameter lists. - if ($query_string) { + if ($query_string ne '') { if ($query_string =~ /=/) { $self->parse_params($query_string); } else { @@ -439,39 +478,23 @@ sub init { $self->delete('.submit'); $self->delete('.cgifields'); $self->save_request unless $initializer; - } - # FUNCTIONS TO OVERRIDE: - # Turn a string into a filehandle sub to_filehandle { - my $string = shift; - if ($string && !ref($string)) { - my($package) = caller(1); - my($tmp) = $string=~/[':]/ ? $string : "$package\:\:$string"; - return $tmp if defined(fileno($tmp)); + my $thingy = shift; + return undef unless $thingy; + return $thingy if UNIVERSAL::isa($thingy,'GLOB'); + return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); + if (!ref($thingy)) { + my $caller = 1; + while (my $package = caller($caller++)) { + my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; + return $tmp if defined(fileno($tmp)); + } } - return $string; -} - -# Create a new multipart buffer -sub new_MultipartBuffer { - my($self,$boundary,$length,$filehandle) = @_; - return MultipartBuffer->new($self,$boundary,$length,$filehandle); -} - -# Read data from a file handle -sub read_from_client { - my($self, $fh, $buff, $len, $offset) = @_; - local $^W=0; # prevent a warning - return read($fh, $$buff, $len, $offset); -} - -# put a filehandle into binary mode (DOS) -sub binmode { - binmode($_[1]); + return undef; } # send output to the browser @@ -486,18 +509,34 @@ sub print { CORE::print(@_); } +# get/set last cgi_error +sub cgi_error { + my ($self,$err) = self_or_default(@_); + $self->{'.cgi_error'} = $err if defined $err; + return $self->{'.cgi_error'}; +} + # unescape URL-encoded data sub unescape { - my($todecode) = @_; - $todecode =~ tr/+/ /; # pluses become spaces - $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge; - return $todecode; + shift() if ref($_[0]) || $_[0] eq $DefaultClass; + my $todecode = shift; + return undef unless defined($todecode); + $todecode =~ tr/+/ /; # pluses become spaces + if ($EBCDIC) { + $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",$A2E[hex($1)])/ge; + } else { + $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge; + } + return $todecode; } # URL-encode data sub escape { - my($toencode) = @_; - $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg; + shift() if ref($_[0]) || $_[0] eq $DefaultClass; + my $toencode = shift; + return undef unless defined($toencode); + $toencode=~s/ /+/g; + $toencode=~s/([^a-zA-Z0-9_.+-])/uc sprintf("%%%02x",ord($1))/eg; return $toencode; } @@ -512,22 +551,14 @@ sub save_request { } } -sub parse_keywordlist { - my($self,$tosplit) = @_; - $tosplit = &unescape($tosplit); # unescape the keywords - $tosplit=~tr/+/ /; # pluses to spaces - my(@keywords) = split(/\s+/,$tosplit); - return @keywords; -} - sub parse_params { my($self,$tosplit) = @_; - my(@pairs) = split('&',$tosplit); + my(@pairs) = split(/[&;]/,$tosplit); my($param,$value); foreach (@pairs) { - ($param,$value) = split('='); - $param = &unescape($param); - $value = &unescape($value); + ($param,$value) = split('=',$_,2); + $param = unescape($param); + $value = unescape($value); $self->add_parameter($param); push (@{$self->{$param}},$value); } @@ -546,46 +577,46 @@ sub all_parameters { return @{$self->{'.parameters'}}; } -#### Method as_string -# -# synonym for "dump" -#### -sub as_string { - &dump(@_); +# put a filehandle into binary mode (DOS) +sub binmode { + CORE::binmode($_[1]); +} + +sub _make_tag_func { + my ($self,$tagname) = @_; + my $func = qq( + sub $tagname { + shift if \$_[0] && +# (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) || + (ref(\$_[0]) && + (substr(ref(\$_[0]),0,3) eq 'CGI' || + UNIVERSAL::isa(\$_[0],'CGI'))); + + my(\$attr) = ''; + if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') { + my(\@attr) = make_attributes( '',shift() ); + \$attr = " \@attr" if \@attr; + } + ); + if ($tagname=~/start_(\w+)/i) { + $func .= qq! return "<\U$1\E\$attr>";} !; + } elsif ($tagname=~/end_(\w+)/i) { + $func .= qq! return "<\U/$1\E>"; } !; + } else { + $func .= qq# + my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U\E"); + return \$tag unless \@_; + my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_"; + return "\@result"; + }#; + } +return $func; } sub AUTOLOAD { print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG; - my($func) = $AUTOLOAD; - my($pack,$func_name) = $func=~/(.+)::([^:]+)$/; - $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass - unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"}); - - my($sub) = \%{"$pack\:\:SUBS"}; - unless (%$sub) { - my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"}; - eval "package $pack; $$auto"; - die $@ if $@; - } - my($code) = $sub->{$func_name}; - - $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY'); - if (!$code) { - if ($EXPORT{':any'} || - $EXPORT{$func_name} || - (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html'))) - && $EXPORT_OK{$func_name}) { - $code = $sub->{'HTML_FUNC'}; - $code=~s/func_name/$func_name/mg; - } - } - die "Undefined subroutine $AUTOLOAD\n" unless $code; - eval "package $pack; $code"; - if ($@) { - $@ =~ s/ at .*\n//; - die $@; - } - goto &{"$pack\:\:$func_name"}; + my $func = &_compile; + goto &$func; } # PRIVATE SUBROUTINE @@ -596,38 +627,112 @@ sub AUTOLOAD { sub rearrange { my($self,$order,@param) = @_; return () unless @param; - - return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-') - || $self->use_named_parameters; - my $i; - for ($i=0;$i<@param;$i+=2) { - $param[$i]=~s/^\-//; # get rid of initial - if present - $param[$i]=~tr/a-z/A-Z/; # parameters are upper case + if (ref($param[0]) eq 'HASH') { + @param = %{$param[0]}; + } else { + return @param + unless (defined($param[0]) && substr($param[0],0,1) eq '-') + || $self->use_named_parameters; } - - my(%param) = @param; # convert into associative array - my(@return_array); - - my($key)=''; - foreach $key (@$order) { - my($value); - # this is an awful hack to fix spurious warnings when the - # -w switch is set. - if (ref($key) && ref($key) eq 'ARRAY') { - foreach (@$key) { - last if defined($value); - $value = $param{$_}; - delete $param{$_}; - } + + # map parameters into positional indices + my ($i,%pos); + $i = 0; + foreach (@$order) { + foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; } + $i++; + } + + my (@result,%leftover); + $#result = $#$order; # preextend + while (@param) { + my $key = uc(shift(@param)); + $key =~ s/^\-//; + if (exists $pos{$key}) { + $result[$pos{$key}] = shift(@param); } else { - $value = $param{$key}; - delete $param{$key}; + $leftover{$key} = shift(@param); + } + } + + push (@result,$self->make_attributes(\%leftover)) if %leftover; + @result; +} + +sub _compile { + my($func) = $AUTOLOAD; + my($pack,$func_name); + { + local($1,$2); # this fixes an obscure variable suicide problem. + $func=~/(.+)::([^:]+)$/; + ($pack,$func_name) = ($1,$2); + $pack=~s/::SUPER$//; # fix another obscure problem + $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass + unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"}); + + my($sub) = \%{"$pack\:\:SUBS"}; + unless (%$sub) { + my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"}; + eval "package $pack; $$auto"; + die $@ if $@; + $$auto = ''; # Free the unneeded storage (but don't undef it!!!) + } + my($code) = $sub->{$func_name}; + + $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY'); + if (!$code) { + (my $base = $func_name) =~ s/^(start_|end_)//i; + if ($EXPORT{':any'} || + $EXPORT{'-any'} || + $EXPORT{$base} || + (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html'))) + && $EXPORT_OK{$base}) { + $code = $CGI::DefaultClass->_make_tag_func($func_name); + } + } + die "Undefined subroutine $AUTOLOAD\n" unless $code; + eval "package $pack; $code"; + if ($@) { + $@ =~ s/ at .*\n//; + die $@; + } + } + CORE::delete($sub->{$func_name}); #free storage + return "$pack\:\:$func_name"; +} + +sub _reset_globals { initialize_globals(); } + +sub _setup_symbols { + my $self = shift; + my $compile = 0; + foreach (@_) { + $HEADERS_ONCE++, next if /^[:-]unique_headers$/; + $NPH++, next if /^[:-]nph$/; + $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/; + $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/; + $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/; + $EXPORT{$_}++, next if /^[:-]any$/; + $compile++, next if /^[:-]compile$/; + + # This is probably extremely evil code -- to be deleted some day. + if (/^[-]autoload$/) { + my($pkg) = caller(1); + *{"${pkg}::AUTOLOAD"} = sub { + my($routine) = $AUTOLOAD; + $routine =~ s/^.*::/CGI::/; + &$routine; + }; + next; + } + + foreach (&expand_tags($_)) { + tr/a-zA-Z0-9_//cd; # don't allow weird function names + $EXPORT{$_}++; } - push(@return_array,$value); } - push (@return_array,$self->make_attributes(\%param)) if %param; - return (@return_array); + _compile_all(keys %EXPORT) if $compile; } ############################################################################### @@ -646,32 +751,83 @@ END_OF_FUNC sub MULTIPART { 'multipart/form-data'; } END_OF_FUNC -'HTML_FUNC' => <<'END_OF_FUNC', -sub func_name { +'SERVER_PUSH' => <<'END_OF_FUNC', +sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; } +END_OF_FUNC - # handle various cases in which we're called - # most of this bizarre stuff is to avoid -w errors - shift if $_[0] && - (!ref($_[0]) && $_[0] eq $CGI::DefaultClass) || - (ref($_[0]) && - (substr(ref($_[0]),0,3) eq 'CGI' || - eval "\$_[0]->isaCGI()")); +'use_named_parameters' => <<'END_OF_FUNC', +#### Method: use_named_parameters +# Force CGI.pm to use named parameter-style method calls +# rather than positional parameters. The same effect +# will happen automatically if the first parameter +# begins with a -. +sub use_named_parameters { + my($self,$use_named) = self_or_default(@_); + return $self->{'.named'} unless defined ($use_named); - my($attr) = ''; - if (ref($_[0]) && ref($_[0]) eq 'HASH') { - my(@attr) = CGI::make_attributes('',shift); - $attr = " @attr" if @attr; - } - my($tag,$untag) = ("\U","\U\E"); - return $tag unless @_; - if (ref($_[0]) eq 'ARRAY') { - my(@r); - foreach (@{$_[0]}) { - push(@r,"$tag$_$untag"); + # stupidity to avoid annoying warnings + return $self->{'.named'}=$use_named; +} +END_OF_FUNC + +'new_MultipartBuffer' => <<'END_OF_FUNC', +# Create a new multipart buffer +sub new_MultipartBuffer { + my($self,$boundary,$length,$filehandle) = @_; + return MultipartBuffer->new($self,$boundary,$length,$filehandle); +} +END_OF_FUNC + +'read_from_client' => <<'END_OF_FUNC', +# Read data from a file handle +sub read_from_client { + my($self, $fh, $buff, $len, $offset) = @_; + local $^W=0; # prevent a warning + return undef unless defined($fh); + return read($fh, $$buff, $len, $offset); +} +END_OF_FUNC + +'delete' => <<'END_OF_FUNC', +#### Method: delete +# Deletes the named parameter entirely. +#### +sub delete { + my($self,$name) = self_or_default(@_); + CORE::delete $self->{$name}; + CORE::delete $self->{'.fieldnames'}->{$name}; + @{$self->{'.parameters'}}=grep($_ ne $name,$self->param()); + return wantarray ? () : undef; +} +END_OF_FUNC + +#### Method: import_names +# Import all parameters into the given namespace. +# Assumes namespace 'Q' if not specified +#### +'import_names' => <<'END_OF_FUNC', +sub import_names { + my($self,$namespace,$delete) = self_or_default(@_); + $namespace = 'Q' unless defined($namespace); + die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::; + if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) { + # can anyone find an easier way to do this? + foreach (keys %{"${namespace}::"}) { + local *symbol = "${namespace}::${_}"; + undef $symbol; + undef @symbol; + undef %symbol; } - return "@r"; - } else { - return "$tag@_$untag"; + } + my($param,@value,$var); + foreach $param ($self->param) { + # protect against silly names + ($var = $param)=~tr/a-zA-Z0-9_/_/c; + $var =~ s/^(?=\d)/_/; + local *symbol = "${namespace}::$var"; + @value = $self->param($param); + @symbol = @value; + $symbol = $value[0]; } } END_OF_FUNC @@ -686,13 +842,24 @@ sub keywords { my($self,@values) = self_or_default(@_); # If values is provided, then we set it. $self->{'keywords'}=[@values] if @values; - my(@result) = @{$self->{'keywords'}}; + my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : (); @result; } END_OF_FUNC # These are some tie() interfaces for compatibility # with Steve Brenner's cgi-lib.pl routines +'Vars' => <<'END_OF_FUNC', +sub Vars { + my %in; + tie(%in,CGI); + return %in if wantarray; + return \%in; +} +END_OF_FUNC + +# These are some tie() interfaces for compatibility +# with Steve Brenner's cgi-lib.pl routines 'ReadParse' => <<'END_OF_FUNC', sub ReadParse { local(*in); @@ -703,6 +870,7 @@ sub ReadParse { *in=*{"${pkg}::in"}; } tie(%in,CGI); + return scalar(keys %in); } END_OF_FUNC @@ -749,7 +917,7 @@ END_OF_FUNC 'TIEHASH' => <<'END_OF_FUNC', sub TIEHASH { - return new CGI; + return $Q || new CGI; } END_OF_FUNC @@ -825,9 +993,23 @@ sub delete_all { } EOF -#### Method: autoescape -# If you want to turn off the autoescaping features, -# call this method with undef as the argument +'Delete' => <<'EOF', +sub Delete { + my($self,@p) = self_or_default(@_); + $self->delete(@p); +} +EOF + +'Delete_all' => <<'EOF', +sub Delete_all { + my($self,@p) = self_or_default(@_); + $self->delete_all(@p); +} +EOF + +#### Method: autoescape +# If you want to turn off the autoescaping features, +# call this method with undef as the argument 'autoEscape' => <<'END_OF_FUNC', sub autoEscape { my($self,$escape) = self_or_default(@_); @@ -853,13 +1035,44 @@ sub make_attributes { foreach (keys %{$attr}) { my($key) = $_; $key=~s/^\-//; # get rid of initial - if present - $key=~tr/a-z/A-Z/; # parameters are upper case - push(@att,$attr->{$_} ne '' ? qq/$key="$attr->{$_}"/ : qq/$key/); + $key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes + push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/); } return @att; } END_OF_FUNC +#### Method: url_param +# Return a parameter in the QUERY_STRING, regardless of +# whether this was a POST or a GET +#### +'url_param' => <<'END_OF_FUNC', +sub url_param { + my ($self,@p) = self_or_default(@_); + my $name = shift(@p); + return undef unless exists($ENV{QUERY_STRING}); + unless (exists($self->{'.url_param'})) { + $self->{'.url_param'}={}; # empty hash + if ($ENV{QUERY_STRING} =~ /=/) { + my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING}); + my($param,$value); + foreach (@pairs) { + ($param,$value) = split('=',$_,2); + $param = unescape($param); + $value = unescape($value); + push(@{$self->{'.url_param'}->{$param}},$value); + } + } else { + $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})]; + } + } + return keys %{$self->{'.url_param'}} unless defined($name); + return () unless $self->{'.url_param'}->{$name}; + return wantarray ? @{$self->{'.url_param'}->{$name}} + : $self->{'.url_param'}->{$name}->[0]; +} +END_OF_FUNC + #### Method: dump # Returns a string in which all the known parameter/value # pairs are represented as nested lists, mainly for the purposes @@ -877,6 +1090,7 @@ sub dump { push(@result,""); @@ -886,6 +1100,15 @@ sub dump { } END_OF_FUNC +#### Method as_string +# +# synonym for "dump" +#### +'as_string' => <<'END_OF_FUNC', +sub as_string { + &dump(@_); +} +END_OF_FUNC #### Method: save # Write values out to a filehandle in such a way that they can @@ -894,16 +1117,15 @@ END_OF_FUNC 'save' => <<'END_OF_FUNC', sub save { my($self,$filehandle) = self_or_default(@_); - my($param); - my($package) = caller; -# Check that this still works! -# $filehandle = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle"; $filehandle = to_filehandle($filehandle); + my($param); + local($,) = ''; # set print field separator back to a sane value + local($\) = ''; # set output line separator to a sane value foreach $param ($self->param) { - my($escaped_param) = &escape($param); + my($escaped_param) = escape($param); my($value); foreach $value ($self->param($param)) { - print $filehandle "$escaped_param=",escape($value),"\n"; + print $filehandle "$escaped_param=",escape("$value"),"\n"; } } print $filehandle "=\n"; # end of record @@ -911,6 +1133,83 @@ sub save { END_OF_FUNC +#### Method: save_parameters +# An alias for save() that is a better name for exportation. +# Only intended to be used with the function (non-OO) interface. +#### +'save_parameters' => <<'END_OF_FUNC', +sub save_parameters { + my $fh = shift; + return save(to_filehandle($fh)); +} +END_OF_FUNC + +#### Method: restore_parameters +# A way to restore CGI parameters from an initializer. +# Only intended to be used with the function (non-OO) interface. +#### +'restore_parameters' => <<'END_OF_FUNC', +sub restore_parameters { + $Q = $CGI::DefaultClass->new(@_); +} +END_OF_FUNC + +#### Method: multipart_init +# Return a Content-Type: style header for server-push +# This has to be NPH, and it is advisable to set $| = 1 +# +# Many thanks to Ed Jordan for this +# contribution +#### +'multipart_init' => <<'END_OF_FUNC', +sub multipart_init { + my($self,@p) = self_or_default(@_); + my($boundary,@other) = $self->rearrange([BOUNDARY],@p); + $boundary = $boundary || '------- =_aaaaaaaaaa0'; + $self->{'separator'} = "\n--$boundary\n"; + $type = SERVER_PUSH($boundary); + return $self->header( + -nph => 1, + -type => $type, + (map { split "=", $_, 2 } @other), + ) . $self->multipart_end; +} +END_OF_FUNC + + +#### Method: multipart_start +# Return a Content-Type: style header for server-push, start of section +# +# Many thanks to Ed Jordan for this +# contribution +#### +'multipart_start' => <<'END_OF_FUNC', +sub multipart_start { + my($self,@p) = self_or_default(@_); + my($type,@other) = $self->rearrange([TYPE],@p); + $type = $type || 'text/html'; + return $self->header( + -type => $type, + (map { split "=", $_, 2 } @other), + ); +} +END_OF_FUNC + + +#### Method: multipart_end +# Return a Content-Type: style header for server-push, end of section +# +# Many thanks to Ed Jordan for this +# contribution +#### +'multipart_end' => <<'END_OF_FUNC', +sub multipart_end { + my($self,@p) = self_or_default(@_); + return $self->{'separator'}; +} +END_OF_FUNC + + #### Method: header # Return a Content-Type: style header # @@ -920,41 +1219,53 @@ sub header { my($self,@p) = self_or_default(@_); my(@header); + return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE; + my($type,$status,$cookie,$target,$expires,$nph,@other) = - $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p); + $self->rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], + STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p); + $nph ||= $NPH; # rearrange() was designed for the HTML portion, so we # need to fix it up a little. foreach (@other) { - next unless my($header,$value) = /([^\s=]+)=(.+)/; - substr($header,1,1000)=~tr/A-Z/a-z/; - ($value)=$value=~/^"(.*)"$/; - $_ = "$header: $value"; + next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/; + ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e; } - $type = $type || 'text/html'; + $type ||= 'text/html' unless defined($type); + + # Maybe future compatibility. Maybe not. + my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; + push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph; - push(@header,'HTTP/1.0 ' . ($status || '200 OK')) if $nph || $NPH; push(@header,"Status: $status") if $status; - push(@header,"Window-target: $target") if $target; + push(@header,"Window-Target: $target") if $target; # push all the cookies -- there may be several if ($cookie) { - my(@cookie) = ref($cookie) ? @{$cookie} : $cookie; + my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie; foreach (@cookie) { - push(@header,"Set-cookie: $_"); + my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_; + push(@header,"Set-Cookie: $cs") if $cs ne ''; } } # if the user indicates an expiration time, then we need # both an Expires and a Date header (so that the browser is # uses OUR clock) - push(@header,"Expires: " . &expires($expires)) if $expires; - push(@header,"Date: " . &expires(0)) if $expires; + push(@header,"Expires: " . expires($expires,'http')) + if $expires; + push(@header,"Date: " . expires(0,'http')) if $expires || $cookie; push(@header,"Pragma: no-cache") if $self->cache(); push(@header,@other); - push(@header,"Content-type: $type"); + push(@header,"Content-Type: $type") if $type ne ''; - my $header = join($CRLF,@header); - return $header . "${CRLF}${CRLF}"; + my $header = join($CRLF,@header)."${CRLF}${CRLF}"; + if ($MOD_PERL and not $nph) { + my $r = Apache->request; + $r->send_cgi_header($header); + return ''; + } + return $header; } END_OF_FUNC @@ -982,24 +1293,17 @@ END_OF_FUNC 'redirect' => <<'END_OF_FUNC', sub redirect { my($self,@p) = self_or_default(@_); - my($url,$target,$cookie,$nph,@other) = $self->rearrange([[URI,URL],TARGET,COOKIE,NPH],@p); + my($url,$target,$cookie,$nph,@other) = $self->rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p); $url = $url || $self->self_url; my(@o); - foreach (@other) { push(@o,split("=")); } - if($MOD_PERL or exists $self->{'.req'}) { - my $r = $self->{'.req'} || Apache->request; - $r->header_out(Location => $url); - $r->err_header_out(Location => $url); - $r->status(302); - return; - } - push(@o, - '-Status'=>'302 Found', + foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); } + unshift(@o, + '-Status'=>'302 Moved', '-Location'=>$url, - '-URI'=>$url, - '-nph'=>($nph||$NPH)); - push(@o,'-Target'=>$target) if $target; - push(@o,'-Cookie'=>$cookie) if $cookie; + '-nph'=>$nph); + unshift(@o,'-Target'=>$target) if $target; + unshift(@o,'-Cookie'=>$cookie) if $cookie; + unshift(@o,'-Type'=>''); return $self->header(@o); } END_OF_FUNC @@ -1018,26 +1322,30 @@ END_OF_FUNC # $script -> (option) Javascript code (-script) # $no_script -> (option) Javascript