X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/1c87da1da4f953d5e3fa74ec3075ddaf999e9d1e..0ecadccd45b827b7dab28b1089e2750d85f803c5:/lib/CGI.pm diff --git a/lib/CGI.pm b/lib/CGI.pm index a30bb9e..f5ecc2d 100644 --- a/lib/CGI.pm +++ b/lib/CGI.pm @@ -18,13 +18,13 @@ use Carp 'croak'; # The most recent version and complete docs are available at: # http://stein.cshl.org/WWW/software/CGI/ -$CGI::revision = '$Id: CGI.pm,v 1.125 2003/06/16 18:54:19 lstein Exp $'; -$CGI::VERSION='2.97'; +$CGI::revision = '$Id: CGI.pm,v 1.185 2005/08/03 21:14:55 lstein Exp $'; +$CGI::VERSION='3.11_01'; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. # $CGITempFile::TMPDIRECTORY = '/usr/tmp'; -use CGI::Util qw(rearrange make_attributes unescape escape expires); +use CGI::Util qw(rearrange make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic); #use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN', # 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd']; @@ -37,9 +37,8 @@ use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN', $TAINTED = substr("$0$^X",0,0); } -my @SAVED_SYMBOLS; - $MOD_PERL = 0; # no mod_perl by default +@SAVED_SYMBOLS = (); # >>>>> Here are some globals that you might want to adjust <<<<<< sub initialize_globals { @@ -111,6 +110,7 @@ sub initialize_globals { # Other globals that you shouldn't worry about. undef $Q; $BEEN_THERE = 0; + $DTD_PUBLIC_IDENTIFIER = ""; undef @QUERY_PARAM; undef %EXPORT; undef $QUERY_CHARSET; @@ -122,6 +122,8 @@ sub initialize_globals { # ------------------ START OF THE LIBRARY ------------ +*end_form = \&endform; + # make mod_perlhappy initialize_globals(); @@ -175,19 +177,18 @@ $IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; # Turn on special checking for Doug MacEachern's modperl if (exists $ENV{MOD_PERL}) { - eval "require mod_perl"; # mod_perl handlers may run system() on scripts using CGI.pm; # Make sure so we don't get fooled by inherited $ENV{MOD_PERL} - if (defined $mod_perl::VERSION) { - if ($mod_perl::VERSION >= 1.99) { - $MOD_PERL = 2; - require Apache::RequestRec; - require Apache::RequestUtil; - require APR::Pool; - } else { - $MOD_PERL = 1; - require Apache; - } + if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { + $MOD_PERL = 2; + require Apache2::Response; + require Apache2::RequestRec; + require Apache2::RequestUtil; + require Apache2::RequestIO; + require APR::Pool; + } else { + $MOD_PERL = 1; + require Apache; } } @@ -210,9 +211,9 @@ if ($OS eq 'VMS') { } if ($needs_binmode) { - $CGI::DefaultClass->binmode(main::STDOUT); - $CGI::DefaultClass->binmode(main::STDIN); - $CGI::DefaultClass->binmode(main::STDERR); + $CGI::DefaultClass->binmode(\*main::STDOUT); + $CGI::DefaultClass->binmode(\*main::STDIN); + $CGI::DefaultClass->binmode(\*main::STDERR); } %EXPORT_TAGS = ( @@ -230,10 +231,11 @@ if ($needs_binmode) { 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 + ':cgi'=>[qw/param upload path_info path_translated request_uri 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 + remote_addr referer server_name server_software server_port server_protocol virtual_port + virtual_host remote_ident auth_type http append save_parameters restore_parameters param_fetch remote_user user_name header redirect import_names put Delete Delete_all url_param cgi_error/], @@ -245,6 +247,33 @@ if ($needs_binmode) { ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/] ); +# Custom 'can' method for both autoloaded and non-autoloaded subroutines. +# Author: Cees Hek + +sub can { + my($class, $method) = @_; + + # See if UNIVERSAL::can finds it. + + if (my $func = $class -> SUPER::can($method) ){ + return $func; + } + + # Try to compile the function. + + eval { + # _compile looks at $AUTOLOAD for the function name. + + local $AUTOLOAD = join "::", $class, $method; + &_compile; + }; + + # Now that the function is loaded (if it exists) + # just use UNIVERSAL::can again to do the work. + + return $class -> SUPER::can($method); +} + # to import symbols into caller sub import { my $self = shift; @@ -295,23 +324,30 @@ sub expand_tags { sub new { my($class,@initializer) = @_; my $self = {}; + bless $self,ref $class || $class || $DefaultClass; if (ref($initializer[0]) && (UNIVERSAL::isa($initializer[0],'Apache') || - UNIVERSAL::isa($initializer[0],'Apache::RequestRec') + UNIVERSAL::isa($initializer[0],'Apache2::RequestRec') )) { $self->r(shift @initializer); } + if (ref($initializer[0]) + && (UNIVERSAL::isa($initializer[0],'CODE'))) { + $self->upload_hook(shift @initializer, shift @initializer); + } if ($MOD_PERL) { - $self->r(Apache->request) unless $self->r; - my $r = $self->r; if ($MOD_PERL == 1) { + $self->r(Apache->request) unless $self->r; + my $r = $self->r; $r->register_cleanup(\&CGI::_reset_globals); } else { # XXX: once we have the new API # will do a real PerlOptions -SetupEnv check + $self->r(Apache2::RequestUtil->request) unless $self->r; + my $r = $self->r; $r->subprocess_env unless exists $ENV{REQUEST_METHOD}; $r->pool->cleanup_register(\&CGI::_reset_globals); } @@ -322,9 +358,20 @@ sub new { return $self; } -# We provide a DESTROY method so that the autoloader -# doesn't bother trying to find it. -sub DESTROY { } +# We provide a DESTROY method so that we can ensure that +# temporary files are closed (via Fh->DESTROY) before they +# are unlinked (via CGITempFile->DESTROY) because it is not +# possible to unlink an open file on Win32. We explicitly +# call DESTROY on each, rather than just undefing them and +# letting Perl DESTROY them by garbage collection, in case the +# user is still holding any reference to them as well. +sub DESTROY { + my $self = shift; + foreach my $href (values %{$self->{'.tmpfiles'}}) { + $href->{hndl}->DESTROY if defined $href->{hndl}; + $href->{name}->DESTROY if defined $href->{name}; + } +} sub r { my $self = shift; @@ -333,6 +380,12 @@ sub r { $r; } +sub upload_hook { + my ($self,$hook,$data) = self_or_default(@_); + $self->{'.upload_hook'} = $hook; + $self->{'.upload_data'} = $data; +} + #### Method: param # Returns the value(s)of a named parameter. # If invoked in a list context, returns the @@ -447,12 +500,15 @@ sub init { # quietly read and discard the post my $buffer; my $max = $content_length; - while ($max > 0 && (my $bytes = read(STDIN,$buffer,$max < 10000 ? $max : 10000))) { - $max -= $bytes; + while ($max > 0 && + (my $bytes = $MOD_PERL + ? $self->r->read($buffer,$max < 10000 ? $max : 10000) + : read(STDIN,$buffer,$max < 10000 ? $max : 10000) + )) { + $self->cgi_error("413 Request entity too large"); + last METHOD; } - $self->cgi_error("413 Request entity too large"); - last METHOD; - } + } # Process multipart postings, but only if the initializer is # not defined. @@ -495,6 +551,21 @@ sub init { last METHOD; } + if (defined($fh) && ($fh ne '')) { + while (<$fh>) { + chomp; + last if /^=/; + push(@lines,$_); + } + # massage back into standard format + if ("@lines" =~ /=/) { + $query_string=join("&",@lines); + } else { + $query_string=join("+",@lines); + } + last METHOD; + } + # last chance -- treat it as a string $initializer = $$initializer if ref($initializer) eq 'SCALAR'; $query_string = $initializer; @@ -515,7 +586,7 @@ sub init { } if ($meth eq 'POST') { - $self->read_from_client(\*STDIN,\$query_string,$content_length,0) + $self->read_from_client(\$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 @@ -528,7 +599,15 @@ sub init { # 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() if $DEBUG; + if ($DEBUG) + { + my $cmdline_ret = read_from_cmdline(); + $query_string = $cmdline_ret->{'query_string'}; + if (defined($cmdline_ret->{'subpath'})) + { + $self->path_info($cmdline_ret->{'subpath'}); + } + } } # YL: Begin Change for XML handler 10/19/2001 @@ -557,7 +636,7 @@ sub init { # Special case. Erase everything if there is a field named # .defaults. if ($self->param('.defaults')) { - undef %{$self}; + $self->delete_all(); } # Associative array containing our defined fieldnames @@ -655,6 +734,7 @@ sub all_parameters { # put a filehandle into binary mode (DOS) sub binmode { + return unless defined($_[1]) && defined fileno($_[1]); CORE::binmode($_[1]); } @@ -707,6 +787,7 @@ sub _compile { my($sub) = \%{"$pack\:\:SUBS"}; unless (%$sub) { my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"}; + local ($@,$!); eval "package $pack; $$auto"; croak("$AUTOLOAD: $@") if $@; $$auto = ''; # Free the unneeded storage (but don't undef it!!!) @@ -725,6 +806,7 @@ sub _compile { } } croak("Undefined subroutine $AUTOLOAD\n") unless $code; + local ($@,$!); eval "package $pack; $code"; if ($@) { $@ =~ s/ at .*\n//; @@ -769,7 +851,7 @@ sub _setup_symbols { $XHTML=0, next if /^[:-]no_?xhtml$/; $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/; $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/; - $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/; + $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/; $EXPORT{$_}++, next if /^[:-]any$/; $compile++, next if /^[:-]compile$/; $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/; @@ -800,6 +882,19 @@ sub charset { $self->{'.charset'}; } +sub element_id { + my ($self,$new_value) = self_or_default(@_); + $self->{'.elid'} = $new_value if defined $new_value; + sprintf('%010d',$self->{'.elid'}++); +} + +sub element_tab { + my ($self,$new_value) = self_or_default(@_); + $self->{'.etab'} ||= 1; + $self->{'.etab'} = $new_value if defined $new_value; + $self->{'.etab'}++; +} + ############################################################################### ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### ############################################################################### @@ -823,18 +918,19 @@ 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); + my($self,$boundary,$length) = @_; + return MultipartBuffer->new($self,$boundary,$length); } 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) = @_; + my($self, $buff, $len, $offset) = @_; local $^W=0; # prevent a warning - return undef unless defined($fh); - return read($fh, $$buff, $len, $offset); + return $MOD_PERL + ? $self->r->read($$buff, $len, $offset) + : read(\*STDIN, $$buff, $len, $offset); } END_OF_FUNC @@ -854,7 +950,7 @@ sub delete { $to_delete{$name}++; } @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param(); - return wantarray ? () : undef; + return; } END_OF_FUNC @@ -1039,7 +1135,7 @@ END_OF_FUNC #### 'append' => <<'EOF', sub append { - my($self,@p) = @_; + my($self,@p) = self_or_default(@_); my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p); my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : (); if (@values) { @@ -1145,7 +1241,7 @@ sub Dump { push(@result,""); @@ -1228,7 +1324,7 @@ sub multipart_init { $self->{'final_separator'} = "$CRLF--$boundary--$CRLF"; $type = SERVER_PUSH($boundary); return $self->header( - -nph => 1, + -nph => 0, -type => $type, (map { split "=", $_, 2 } @other), ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end; @@ -1300,7 +1396,7 @@ sub header { my($self,@p) = self_or_default(@_); my(@header); - return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE; + return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE; my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) = rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], @@ -1388,12 +1484,14 @@ END_OF_FUNC 'redirect' => <<'END_OF_FUNC', sub redirect { my($self,@p) = self_or_default(@_); - my($url,$target,$cookie,$nph,@other) = rearrange([[LOCATION,URI,URL],TARGET,['COOKIE','COOKIES'],NPH],@p); + my($url,$target,$status,$cookie,$nph,@other) = + rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p); + $status = '302 Moved' unless defined $status; $url ||= $self->self_url; my(@o); foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); } unshift(@o, - '-Status' => '302 Moved', + '-Status' => $status, '-Location'=> $url, '-nph' => $nph); unshift(@o,'-Target'=>$target) if $target; @@ -1428,16 +1526,16 @@ END_OF_FUNC sub start_html { my($self,@p) = &self_or_default(@_); my($title,$author,$base,$xbase,$script,$noscript, - $target,$meta,$head,$style,$dtd,$lang,$encoding,@other) = - rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD,LANG,ENCODING],@p); + $target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml,@other) = + rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET, + META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML],@p); + + $self->element_id(0); + $self->element_tab(0); $encoding = 'iso-8859-1' unless defined $encoding; - # strangely enough, the title needs to be escaped as HTML - # while the author needs to be escaped as a URL - $title = $self->escapeHTML($title || 'Untitled Document'); - $author = $self->escape($author); - $lang = 'en-US' unless defined $lang; + # Need to sort out the DTD before it's okay to call escapeHTML(). my(@result,$xml_dtd); if ($dtd) { if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) { @@ -1451,19 +1549,40 @@ sub start_html { $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i; $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i; - push @result,qq() if $xml_dtd; + push @result,qq() if $xml_dtd && $declare_xml; if (ref($dtd) && ref($dtd) eq 'ARRAY') { push(@result,qq([0]"\n\t "$dtd->[1]">)); + $DTD_PUBLIC_IDENTIFIER = $dtd->[0]; } else { push(@result,qq()); + $DTD_PUBLIC_IDENTIFIER = $dtd; } - push(@result,$XHTML ? qq($title) - : ($lang ? qq() : "") + + # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to + # call escapeHTML(). Strangely enough, the title needs to be escaped as + # HTML while the author needs to be escaped as a URL. + $title = $self->escapeHTML($title || 'Untitled Document'); + $author = $self->escape($author); + + if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2)/i) { + $lang = "" unless defined $lang; + $XHTML = 0; + } + else { + $lang = 'en-US' unless defined $lang; + } + + my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : ''; + my $meta_bits = qq() + if $XHTML && $encoding && !$declare_xml; + + push(@result,$XHTML ? qq(\n\n$title) + : ($lang ? qq() : "") . "$title"); if (defined $author) { push(@result,$XHTML ? "" - : ""); + : ""); } if ($base || $xbase || $target) { @@ -1480,8 +1599,9 @@ sub start_html { push(@result,ref($head) ? @$head : $head) if $head; # handle the infrequently-used -style and -script parameters - push(@result,$self->_style($style)) if defined $style; + push(@result,$self->_style($style)) if defined $style; push(@result,$self->_script($script)) if defined $script; + push(@result,$meta_bits) if defined $meta_bits; # handle -noscript parameter push(@result,<"); + push(@result,"\n\n"); return join("\n",@result); } END_OF_FUNC @@ -1508,36 +1628,43 @@ sub _style { my $cdata_start = $XHTML ? "\n\n" : " -->\n"; - if (ref($style)) { - my($src,$code,$verbatim,$stype,$foo,@other) = - rearrange([SRC,CODE,VERBATIM,TYPE], - '-foo'=>'bar', # trick to allow dash to be omitted - ref($style) eq 'ARRAY' ? @$style : %$style); - $type = $stype if $stype; - my $other = @other ? join ' ',@other : ''; - - if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference - { # If it is, push a LINK tag for each one - foreach $src (@$src) - { - push(@result,$XHTML ? qq() + my @s = ref($style) eq 'ARRAY' ? @$style : $style; + + for my $s (@s) { + if (ref($s)) { + my($src,$code,$verbatim,$stype,$foo,@other) = + rearrange([qw(SRC CODE VERBATIM TYPE FOO)], + ('-foo'=>'bar', + ref($s) eq 'ARRAY' ? @$s : %$s)); + $type = $stype if $stype; + my $other = @other ? join ' ',@other : ''; + + if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference + { # If it is, push a LINK tag for each one + foreach $src (@$src) + { + push(@result,$XHTML ? qq() : qq()) if $src; + } } - } - else - { # Otherwise, push the single -src, if it exists. - push(@result,$XHTML ? qq() - : qq() - ) if $src; - } - if ($verbatim) { - push(@result, ""); - } - push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code; - } else { - my $src = $style; + else + { # Otherwise, push the single -src, if it exists. push(@result,$XHTML ? qq() - : qq()); + : qq() + ) if $src; + } + if ($verbatim) { + my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim; + push(@result, "") foreach @v; + } + my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code; + push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) foreach @c; + + } else { + my $src = $s; + push(@result,$XHTML ? qq() + : qq()); + } } @result; } @@ -1571,17 +1698,21 @@ sub _script { $comment = '#' if $type=~/perl|tcl/i; $comment = "'" if $type=~/vbscript/i; - my $cdata_start = "\n\n"; - - my(@satts); - push(@satts,'src'=>$src) if $src; - push(@satts,'language'=>$language) unless defined $type; - push(@satts,'type'=>$type); - $code = "$cdata_start$code$cdata_end" if defined $code; - push(@result,script({@satts},$code || '')); + my ($cdata_start,$cdata_end); + if ($XHTML) { + $cdata_start = "$comment"; + } else { + $cdata_start = "\n\n"; + } + my(@satts); + push(@satts,'src'=>$src) if $src; + push(@satts,'language'=>$language) unless defined $type; + push(@satts,'type'=>$type); + $code = $cdata_start . $code . $cdata_end if defined $code; + push(@result,$self->script({@satts},$code || '')); } @result; } @@ -1593,7 +1724,7 @@ END_OF_FUNC #### 'end_html' => <<'END_OF_FUNC', sub end_html { - return ""; + return "\n\n"; } END_OF_FUNC @@ -1632,15 +1763,17 @@ sub startform { my($method,$action,$enctype,@other) = rearrange([METHOD,ACTION,ENCTYPE],@p); - $method = lc($method) || 'post'; - $enctype = $enctype || &URL_ENCODED; - unless (defined $action) { - $action = $self->url(-absolute=>1,-path=>1); - if (length($ENV{QUERY_STRING})>0) { - $action .= "?$ENV{QUERY_STRING}"; + $method = $self->escapeHTML(lc($method) || 'post'); + $enctype = $self->escapeHTML($enctype || &URL_ENCODED); + if (defined $action) { + $action = $self->escapeHTML($action); + } + else { + $action = $self->escapeHTML($self->url(-absolute=>1,-path=>1)); + if (exists $ENV{QUERY_STRING} && length($ENV{QUERY_STRING})>0) { + $action .= "?".$self->escapeHTML($ENV{QUERY_STRING},1); } } - $action =~ s/\"/%22/g; # fix cross-site scripting bug reported by obscure $action = qq(action="$action"); my($other) = @other ? " @other" : ''; $self->{'.parametersToAdd'}={}; @@ -1653,7 +1786,7 @@ END_OF_FUNC # synonym for startform 'start_form' => <<'END_OF_FUNC', sub start_form { - &startform; + $XHTML ? &start_multipart_form : &startform; } END_OF_FUNC @@ -1696,20 +1829,11 @@ sub endform { END_OF_FUNC -#### Method: end_form -# synonym for endform -'end_form' => <<'END_OF_FUNC', -sub end_form { - &endform; -} -END_OF_FUNC - - '_textfield' => <<'END_OF_FUNC', sub _textfield { my($self,$tag,@p) = self_or_default(@_); - my($name,$default,$size,$maxlength,$override,@other) = - rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); + my($name,$default,$size,$maxlength,$override,$tabindex,@other) = + rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p); my $current = $override ? $default : (defined($self->param($name)) ? $self->param($name) : $default); @@ -1722,7 +1846,8 @@ sub _textfield { # this entered at cristy's request to fix problems with file upload fields # and WebTV -- not sure it won't break stuff my($value) = $current ne '' ? qq(value="$current") : ''; - return $XHTML ? qq() + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq() : qq(); } END_OF_FUNC @@ -1792,9 +1917,8 @@ END_OF_FUNC 'textarea' => <<'END_OF_FUNC', sub textarea { my($self,@p) = self_or_default(@_); - - my($name,$default,$rows,$cols,$override,@other) = - rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p); + my($name,$default,$rows,$cols,$override,$tabindex,@other) = + rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p); my($current)= $override ? $default : (defined($self->param($name)) ? $self->param($name) : $default); @@ -1804,7 +1928,8 @@ sub textarea { my($r) = $rows ? qq/ rows="$rows"/ : ''; my($c) = $cols ? qq/ cols="$cols"/ : ''; my($other) = @other ? " @other" : ''; - return qq{}; + $tabindex = $self->element_tab($tabindex); + return qq{}; } END_OF_FUNC @@ -1823,8 +1948,8 @@ END_OF_FUNC sub button { my($self,@p) = self_or_default(@_); - my($label,$value,$script,@other) = rearrange([NAME,[VALUE,LABEL], - [ONCLICK,SCRIPT]],@p); + my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL], + [ONCLICK,SCRIPT],TABINDEX],@p); $label=$self->escapeHTML($label); $value=$self->escapeHTML($value,1); @@ -1837,7 +1962,8 @@ sub button { $val = qq/ value="$value"/ if $value; $script = qq/ onclick="$script"/ if $script; my($other) = @other ? " @other" : ''; - return $XHTML ? qq() + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq() : qq(); } END_OF_FUNC @@ -1856,18 +1982,19 @@ END_OF_FUNC sub submit { my($self,@p) = self_or_default(@_); - my($label,$value,@other) = rearrange([NAME,[VALUE,LABEL]],@p); + my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p); $label=$self->escapeHTML($label); $value=$self->escapeHTML($value,1); - my($name) = ' name=".submit"' unless $NOSTICKY; + my $name = $NOSTICKY ? '' : ' name=".submit"'; $name = qq/ name="$label"/ if defined($label); $value = defined($value) ? $value : $label; my $val = ''; $val = qq/ value="$value"/ if defined($value); + $tabindex = $self->element_tab($tabindex); my($other) = @other ? " @other" : ''; - return $XHTML ? qq() + return $XHTML ? qq() : qq(); } END_OF_FUNC @@ -1883,7 +2010,7 @@ END_OF_FUNC 'reset' => <<'END_OF_FUNC', sub reset { my($self,@p) = self_or_default(@_); - my($label,$value,@other) = rearrange(['NAME',['VALUE','LABEL']],@p); + my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p); $label=$self->escapeHTML($label); $value=$self->escapeHTML($value,1); my ($name) = ' name=".reset"'; @@ -1892,7 +2019,8 @@ sub reset { my($val) = ''; $val = qq/ value="$value"/ if defined($value); my($other) = @other ? " @other" : ''; - return $XHTML ? qq() + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq() : qq(); } END_OF_FUNC @@ -1913,13 +2041,14 @@ END_OF_FUNC sub defaults { my($self,@p) = self_or_default(@_); - my($label,@other) = rearrange([[NAME,VALUE]],@p); + my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p); $label=$self->escapeHTML($label,1); $label = $label || "Defaults"; my($value) = qq/ value="$label"/; my($other) = @other ? " @other" : ''; - return $XHTML ? qq() + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq() : qq//; } END_OF_FUNC @@ -1951,9 +2080,9 @@ END_OF_FUNC sub checkbox { my($self,@p) = self_or_default(@_); - my($name,$checked,$value,$label,$override,@other) = - rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p); - + my($name,$checked,$value,$label,$override,$tabindex,@other) = + rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE],TABINDEX],@p); + $value = defined $value ? $value : 'on'; if (!$override && ($self->{'.fieldnames'}->{$name} || @@ -1967,84 +2096,14 @@ sub checkbox { $value = $self->escapeHTML($value,1); $the_label = $self->escapeHTML($the_label); my($other) = @other ? " @other" : ''; + $tabindex = $self->element_tab($tabindex); $self->register_parameter($name); - return $XHTML ? qq{$the_label} + return $XHTML ? CGI::label(qq{$the_label}) : qq{$the_label}; } END_OF_FUNC -#### Method: checkbox_group -# Create a list of logically-linked checkboxes. -# Parameters: -# $name -> Common name for all the check boxes -# $values -> A pointer to a regular array containing the -# values for each checkbox in the group. -# $defaults -> (optional) -# 1. If a pointer to a regular array of checkbox values, -# then this will be used to decide which -# checkboxes to turn on by default. -# 2. If a scalar, will be assumed to hold the -# value of a single checkbox in the group to turn on. -# $linebreak -> (optional) Set to true to place linebreaks -# between the buttons. -# $labels -> (optional) -# A pointer to an associative array of labels to print next to each checkbox -# in the form $label{'value'}="Long explanatory label". -# Otherwise the provided values are used as the labels. -# Returns: -# An ARRAY containing a series of fields -#### -'checkbox_group' => <<'END_OF_FUNC', -sub checkbox_group { - my($self,@p) = self_or_default(@_); - - my($name,$values,$defaults,$linebreak,$labels,$attributes,$rows,$columns, - $rowheaders,$colheaders,$override,$nolabels,@other) = - rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], - LINEBREAK,LABELS,ATTRIBUTES,ROWS,[COLUMNS,COLS], - ROWHEADERS,COLHEADERS, - [OVERRIDE,FORCE],NOLABELS],@p); - - my($checked,$break,$result,$label); - - my(%checked) = $self->previous_or_default($name,$defaults,$override); - - if ($linebreak) { - $break = $XHTML ? "
" : "
"; - } - else { - $break = ''; - } - $name=$self->escapeHTML($name); - - # Create the elements - my(@elements,@values); - - @values = $self->_set_values_and_labels($values,\$labels,$name); - - my($other) = @other ? " @other" : ''; - foreach (@values) { - $checked = $self->_checked($checked{$_}); - $label = ''; - unless (defined($nolabels) && $nolabels) { - $label = $_; - $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); - $label = $self->escapeHTML($label); - } - my $attribs = $self->_set_attributes($_, $attributes); - $_ = $self->escapeHTML($_,1); - push(@elements,$XHTML ? qq(${label}${break}) - : qq/${label}${break}/); - } - $self->register_parameter($name); - return wantarray ? @elements : join(' ',@elements) - unless defined($columns) || defined($rows); - $rows = 1 if $rows && $rows < 1; - $cols = 1 if $cols && $cols < 1; - return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); -} -END_OF_FUNC # Escape HTML -- used internally 'escapeHTML' => <<'END_OF_FUNC', @@ -2057,7 +2116,15 @@ sub escapeHTML { $toencode =~ s{&}{&}gso; $toencode =~ s{<}{<}gso; $toencode =~ s{>}{>}gso; - $toencode =~ s{"}{"}gso; + if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) { + # $quot; was accidentally omitted from the HTML 3.2 DTD -- see + # / + # . + $toencode =~ s{"}{"}gso; + } + else { + $toencode =~ s{"}{"}gso; + } my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' || uc $self->{'.charset'} eq 'WINDOWS-1252'; if ($latin) { # bug in some browsers @@ -2076,6 +2143,8 @@ END_OF_FUNC # unescape HTML -- used internally 'unescapeHTML' => <<'END_OF_FUNC', sub unescapeHTML { + # hack to work around earlier hacks + push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; my ($self,$string) = CGI::self_or_default(@_); return undef unless defined($string); my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i @@ -2099,8 +2168,8 @@ END_OF_FUNC '_tableize' => <<'END_OF_FUNC', sub _tableize { my($rows,$columns,$rowheaders,$colheaders,@elements) = @_; - $rowheaders = [] unless defined $rowheaders; - $colheaders = [] unless defined $colheaders; + my @rowheaders = $rowheaders ? @$rowheaders : (); + my @colheaders = $colheaders ? @$colheaders : (); my($result); if (defined($columns)) { @@ -2109,18 +2178,18 @@ sub _tableize { if (defined($rows)) { $columns = int(0.99 + @elements/$rows) unless defined($columns); } - + # rearrange into a pretty table $result = ""; my($row,$column); - unshift(@$colheaders,'') if @$colheaders && @$rowheaders; - $result .= "" if @{$colheaders}; - foreach (@{$colheaders}) { + unshift(@colheaders,'') if @colheaders && @rowheaders; + $result .= "" if @colheaders; + foreach (@colheaders) { $result .= ""; } for ($row=0;$row<$rows;$row++) { $result .= ""; - $result .= "" if @$rowheaders; + $result .= "" if @rowheaders; for ($column=0;$column<$columns;$column++) { $result .= "" if defined($elements[$column*$rows + $row]); @@ -2153,30 +2222,80 @@ END_OF_FUNC 'radio_group' => <<'END_OF_FUNC', sub radio_group { my($self,@p) = self_or_default(@_); + $self->_box_group('radio',@p); +} +END_OF_FUNC + +#### Method: checkbox_group +# Create a list of logically-linked checkboxes. +# Parameters: +# $name -> Common name for all the check boxes +# $values -> A pointer to a regular array containing the +# values for each checkbox in the group. +# $defaults -> (optional) +# 1. If a pointer to a regular array of checkbox values, +# then this will be used to decide which +# checkboxes to turn on by default. +# 2. If a scalar, will be assumed to hold the +# value of a single checkbox in the group to turn on. +# $linebreak -> (optional) Set to true to place linebreaks +# between the buttons. +# $labels -> (optional) +# A pointer to an associative array of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# An ARRAY containing a series of fields +#### + +'checkbox_group' => <<'END_OF_FUNC', +sub checkbox_group { + my($self,@p) = self_or_default(@_); + $self->_box_group('checkbox',@p); +} +END_OF_FUNC - my($name,$values,$default,$linebreak,$labels,$attributes, - $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) = - rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,ATTRIBUTES, - ROWS,[COLUMNS,COLS], - ROWHEADERS,COLHEADERS, - [OVERRIDE,FORCE],NOLABELS],@p); +'_box_group' => <<'END_OF_FUNC', +sub _box_group { + my $self = shift; + my $box_type = shift; + + my($name,$values,$defaults,$linebreak,$labels,$attributes, + $rows,$columns,$rowheaders,$colheaders, + $override,$nolabels,$tabindex,@other) = + rearrange([ NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,ATTRIBUTES, + ROWS,[COLUMNS,COLS],ROWHEADERS,COLHEADERS, + [OVERRIDE,FORCE],NOLABELS,TABINDEX + ],@_); my($result,$checked); - if (!$override && defined($self->param($name))) { - $checked = $self->param($name); - } else { - $checked = $default; - } + my(@elements,@values); @values = $self->_set_values_and_labels($values,\$labels,$name); + my %checked = $self->previous_or_default($name,$defaults,$override); # If no check array is specified, check the first by default - $checked = $values[0] unless defined($checked) && $checked ne ''; + $checked{$values[0]}++ if $box_type eq 'radio' && !%checked; + $name=$self->escapeHTML($name); - my($other) = @other ? " @other" : ''; + my %tabs = (); + if ($tabindex) { + if (!ref $tabindex) { + $self->element_tab($tabindex); + } elsif (ref $tabindex eq 'ARRAY') { + %tabs = map {$_=>$self->element_tab} @$tabindex; + } elsif (ref $tabindex eq 'HASH') { + %tabs = %$tabindex; + } + } + %tabs = map {$_=>$self->element_tab} @values unless %tabs; + + my $other = @other ? " @other" : ''; + my $radio_checked; foreach (@values) { - my($checkit) = $checked eq $_ ? qq/ checked="checked"/ : ''; + my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++) + : $checked{$_}); my($break); if ($linebreak) { $break = $XHTML ? "
" : "
"; @@ -2190,13 +2309,19 @@ sub radio_group { $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); $label = $self->escapeHTML($label,1); } - my $attribs = $self->_set_attributes($_, $attributes); + my $attribs = $self->_set_attributes($_, $attributes); + my $tab = qq( tabindex="$tabs{$_}") if exists $tabs{$_}; $_=$self->escapeHTML($_); - push(@elements,$XHTML ? qq(${label}${break}) - : qq/${label}${break}/); + if ($XHTML) { + push @elements, + CGI::label( + qq($label)).${break}; + } else { + push(@elements,qq/${label}${break}/); + } } $self->register_parameter($name); - return wantarray ? @elements : join(' ',@elements) + return wantarray ? @elements : "@elements" unless defined($columns) || defined($rows); return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); } @@ -2221,9 +2346,9 @@ END_OF_FUNC sub popup_menu { my($self,@p) = self_or_default(@_); - my($name,$values,$default,$labels,$attributes,$override,@other) = + my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) = rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS, - ATTRIBUTES,[OVERRIDE,FORCE]],@p); + ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); my($result,$selected); if (!$override && defined($self->param($name))) { @@ -2236,8 +2361,8 @@ sub popup_menu { my(@values); @values = $self->_set_values_and_labels($values,\$labels,$name); - - $result = qq/\n/; foreach (@values) { if (/ <<'END_OF_FUNC', sub scrolling_list { my($self,@p) = self_or_default(@_); - my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,@other) + my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other) = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], - SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE]],@p); + SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); my($result,@values); @values = $self->_set_values_and_labels($values,\$labels,$name); @@ -2361,7 +2486,8 @@ sub scrolling_list { my($other) = @other ? " @other" : ''; $name=$self->escapeHTML($name); - $result = qq/\n/; foreach (@values) { my($selectit) = $self->_selected($selected{$_}); my($label) = $_; @@ -2414,8 +2540,8 @@ sub hidden { $name=$self->escapeHTML($name); foreach (@value) { $_ = defined($_) ? $self->escapeHTML($_,1) : ''; - push @result,$XHTML ? qq() - : qq(); + push @result,$XHTML ? qq() + : qq(); } return wantarray ? @result : join('',@result); } @@ -2484,29 +2610,17 @@ sub url { my $path = $self->path_info; my $script_name = $self->script_name; - # for compatibility with Apache's MultiViews - if (exists($ENV{REQUEST_URI})) { - my $index; - $script_name = unescape($ENV{REQUEST_URI}); - $script_name =~ s/\?.+$//; # strip query string - # and path - if (exists($ENV{PATH_INFO})) { - my $encoded_path = quotemeta($ENV{PATH_INFO}); - $script_name =~ s/$encoded_path$//i; - } - } - if ($full) { my $protocol = $self->protocol(); $url = "$protocol://"; - my $vh = http('host'); + my $vh = http('x_forwarded_host') || http('host'); if ($vh) { $url .= $vh; } else { $url .= server_name(); my $port = $self->server_port; $url .= ":" . $port - unless (lc($protocol) eq 'http' && $port == 80) + unless (lc($protocol) eq 'http' && $port == 80) || (lc($protocol) eq 'https' && $port == 443); } return $url if $base; @@ -2613,9 +2727,8 @@ sub path_info { $info = "/$info" if $info ne '' && substr($info,0,1) ne '/'; $self->{'.path_info'} = $info; } elsif (! defined($self->{'.path_info'}) ) { - $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ? - $ENV{'PATH_INFO'} : ''; - + my (undef,$path_info) = $self->_name_and_path_from_env; + $self->{'.path_info'} = $path_info || ''; # hack to fix broken path info in IIS $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS; @@ -2624,6 +2737,33 @@ sub path_info { } END_OF_FUNC +# WE USE THIS TO COMPENSATE FOR A BUG IN APACHE 2 PRESENT AT LEAST UP THROUGH 2.0.54 +'_name_and_path_from_env' => <<'END_OF_FUNC', +sub _name_and_path_from_env { + my $self = shift; + my $raw_script_name = $ENV{SCRIPT_NAME} || ''; + my $raw_path_info = $ENV{PATH_INFO} || ''; + my $uri = $ENV{REQUEST_URI} || ''; + + my @uri_double_slashes = $uri =~ m^(/{2,}?)^g; + my @path_double_slashes = "$raw_script_name $raw_path_info" =~ m^(/{2,}?)^g; + + my $apache_bug = @uri_double_slashes != @path_double_slashes; + return ($raw_script_name,$raw_path_info) unless $apache_bug; + + my $path_info_search = $raw_path_info; + # these characters will not (necessarily) be escaped + $path_info_search =~ s/([^a-zA-Z0-9$()':_.,+*\/;?=&-])/uc sprintf("%%%02x",ord($1))/eg; + $path_info_search = quotemeta($path_info_search); + $path_info_search =~ s!/!/+!g; + if ($uri =~ m/^(.+)($path_info_search)/) { + return ($1,$2); + } else { + return ($raw_script_name,$raw_path_info); + } +} +END_OF_FUNC + #### Method: request_method # Returns 'POST', 'GET', 'PUT' or 'HEAD' @@ -2654,6 +2794,16 @@ sub path_translated { END_OF_FUNC +#### Method: request_uri +# Return the literal request URI +#### +'request_uri' => <<'END_OF_FUNC', +sub request_uri { + return $ENV{'REQUEST_URI'}; +} +END_OF_FUNC + + #### Method: query_string # Synthesize a query string from our current # parameters @@ -2771,7 +2921,7 @@ END_OF_FUNC ###### 'virtual_host' => <<'END_OF_FUNC', sub virtual_host { - my $vh = http('host') || server_name(); + my $vh = http('x_forwarded_host') || http('host') || server_name(); $vh =~ s/:\d+$//; # get rid of port number return $vh; } @@ -2809,10 +2959,14 @@ END_OF_FUNC #### 'script_name' => <<'END_OF_FUNC', sub script_name { - return $ENV{'SCRIPT_NAME'} if defined($ENV{'SCRIPT_NAME'}); - # These are for debugging - return "/$0" unless $0=~/^\//; - return $0; + my ($self,@p) = self_or_default(@_); + if (@p) { + $self->{'.script_name'} = shift; + } elsif (!exists $self->{'.script_name'}) { + my ($script_name,$path_info) = $self->_name_and_path_from_env(); + $self->{'.script_name'} = $script_name; + } + return $self->{'.script_name'}; } END_OF_FUNC @@ -2847,6 +3001,21 @@ sub server_software { } END_OF_FUNC +#### Method: virtual_port +# Return the server port, taking virtual hosts into account +#### +'virtual_port' => <<'END_OF_FUNC', +sub virtual_port { + my($self) = self_or_default(@_); + my $vh = $self->http('x_forwarded_host') || $self->http('host'); + if ($vh) { + return ($vh =~ /:(\d+)$/)[0] || '80'; + } else { + return $self->server_port(); + } +} +END_OF_FUNC + #### Method: server_port # Return the tcp/ip port the server is running on #### @@ -3059,11 +3228,12 @@ END_OF_FUNC sub read_from_cmdline { my($input,@words); my($query_string); + my($subpath); if ($DEBUG && @ARGV) { @words = @ARGV; } elsif ($DEBUG > 1) { require "shellwords.pl"; - print STDERR "(offline mode: enter name=value pairs on standard input)\n"; + print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n"; chomp(@lines = ); # remove newlines $input = join(" ",@lines); @words = &shellwords($input); @@ -3078,7 +3248,12 @@ sub read_from_cmdline { } else { $query_string = join('+',@words); } - return $query_string; + if ($query_string =~ /^(.*?)\?(.*)$/) + { + $query_string = $2; + $subpath = $1; + } + return { 'query_string' => $query_string, 'subpath' => $subpath }; } END_OF_FUNC @@ -3092,8 +3267,8 @@ END_OF_FUNC ##### 'read_multipart' => <<'END_OF_FUNC', sub read_multipart { - my($self,$boundary,$length,$filehandle) = @_; - my($buffer) = $self->new_MultipartBuffer($boundary,$length,$filehandle); + my($self,$boundary,$length) = @_; + my($buffer) = $self->new_MultipartBuffer($boundary,$length); return unless $buffer; my(%header,$body); my $filenumber = 0; @@ -3105,11 +3280,11 @@ sub read_multipart { return; } - my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/; + my($param)= $header{'Content-Disposition'}=~/ name="([^;]*)"/; $param .= $TAINTED; # Bug: Netscape doesn't escape quotation marks in file names!!! - my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\"]*)"?/; + my($filename) = $header{'Content-Disposition'}=~/ filename="([^;]*)"/; # Test for Opera's multiple upload feature my($multipart) = ( defined( $header{'Content-Type'} ) && $header{'Content-Type'} =~ /multipart\/mixed/ ) ? @@ -3145,7 +3320,7 @@ sub read_multipart { } # choose a relatively unpredictable tmpfile sequence number - my $seqno = unpack("%16C*",join('',localtime,values %ENV)); + my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV)); for (my $cnt=10;$cnt>0;$cnt--) { next unless $tmpfile = new CGITempFile($seqno); $tmp = $tmpfile->as_string; @@ -3153,10 +3328,11 @@ sub read_multipart { $seqno += int rand(100); } die "CGI open of tmpfile: $!\n" unless defined $filehandle; - $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode + && defined fileno($filehandle); # if this is an multipart/mixed attachment, save the header - # together with the body for lateron parsing with an external + # together with the body for later parsing with an external # MIME parser module if ( $multipart ) { foreach ( keys %header ) { @@ -3167,9 +3343,15 @@ sub read_multipart { my ($data); local($\) = ''; - while (defined($data = $buffer->read)) { + my $totalbytes; + while (defined($data = $buffer->read)) { + if (defined $self->{'.upload_hook'}) + { + $totalbytes += length($data); + &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'}); + } print $filehandle $data; - } + } # back up to beginning of file seek($filehandle,0,0); @@ -3184,6 +3366,7 @@ sub read_multipart { # Save some information about the uploaded file where we can get # at it later. $self->{'.tmpfiles'}->{fileno($filehandle)}= { + hndl => $filehandle, name => $tmpfile, info => {%header}, }; @@ -3238,8 +3421,8 @@ sub _set_attributes { return '' unless defined($attributes->{$element}); $attribs = ' '; foreach my $attrib (keys %{$attributes->{$element}}) { - $attrib =~ s/^-//; - $attribs .= "@{[lc($attrib)]}=\"$attributes->{$element}{$attrib}\" "; + (my $clean_attrib = $attrib) =~ s/^-//; + $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" "; } $attribs =~ s/ $//; return $attribs; @@ -3275,6 +3458,11 @@ $FH='fh00000'; *Fh::AUTOLOAD = \&CGI::AUTOLOAD; +sub DESTROY { + my $self = shift; + close $self; +} + $AUTOLOADED_ROUTINES = ''; # prevent -w error $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; %SUBS = ( @@ -3321,19 +3509,14 @@ sub new { } END_OF_FUNC -'DESTROY' => <<'END_OF_FUNC', -sub DESTROY { - my $self = shift; - close $self; -} -END_OF_FUNC - ); END_OF_AUTOLOAD ######################## MultipartBuffer #################### package MultipartBuffer; +use constant DEBUG => 0; + # how many bytes to read at a time. We use # a 4K buffer by default. $INITIAL_FILLUNIT = 1024 * 4; @@ -3356,18 +3539,10 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; 'new' => <<'END_OF_FUNC', sub new { - my($package,$interface,$boundary,$length,$filehandle) = @_; + my($package,$interface,$boundary,$length) = @_; $FILLUNIT = $INITIAL_FILLUNIT; - my $IN; - if ($filehandle) { - my($package) = caller; - # force into caller's package if necessary - $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle"; - } - $IN = "main::STDIN" unless $IN; + $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always - $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode; - # If the user types garbage into the file upload field, # then Netscape passes NOTHING to the server (not good). # We may hang on this read in that case. So we implement @@ -3389,7 +3564,7 @@ sub new { } else { # otherwise we find it ourselves my($old); ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line - $boundary = <$IN>; # BUG: This won't work correctly under mod_perl + $boundary = ; # BUG: This won't work correctly under mod_perl $length -= length($boundary); chomp($boundary); # remove the CRLF $/ = $old; # restore old line separator @@ -3397,8 +3572,8 @@ sub new { } my $self = {LENGTH=>$length, + CHUNKED=>!defined $length, BOUNDARY=>$boundary, - IN=>$IN, INTERFACE=>$interface, BUFFER=>'', }; @@ -3412,7 +3587,7 @@ sub new { unless ($boundary_read) { while ($self->read(0)) { } } - die "Malformed multipart POST\n" if $self->eof; + die "Malformed multipart POST: data truncated\n" if $self->eof; return $retval; } @@ -3425,7 +3600,7 @@ sub readHeader { my($ok) = 0; my($bad) = 0; - local($CRLF) = "\015\012" if $CGI::OS eq 'VMS'; + local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC; do { $self->fillBuffer($FILLUNIT); @@ -3437,10 +3612,18 @@ sub readHeader { } until $ok || $bad; return () if $bad; + #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines! + my($header) = substr($self->{BUFFER},0,$end+2); substr($self->{BUFFER},0,$end+4) = ''; my %return; + if ($CGI::EBCDIC) { + warn "untranslated header=$header\n" if DEBUG; + $header = CGI::Util::ascii2ebcdic($header); + warn "translated header=$header\n" if DEBUG; + } + # See RFC 2045 Appendix A and RFC 822 sections 3.4.8 # (Folding Long Header Fields), 3.4.3 (Comments) # and 3.4.5 (Quoted-Strings). @@ -3463,9 +3646,18 @@ sub readBody { my($self) = @_; my($data); my($returnval)=''; + + #EBCDIC NOTE: want to translate returnval into EBCDIC HERE + while (defined($data = $self->read)) { $returnval .= $data; } + + if ($CGI::EBCDIC) { + warn "untranslated body=$returnval\n" if DEBUG; + $returnval = CGI::Util::ascii2ebcdic($returnval); + warn "translated body=$returnval\n" if DEBUG; + } return $returnval; } END_OF_FUNC @@ -3478,30 +3670,38 @@ sub read { my($self,$bytes) = @_; # default number of bytes to read - $bytes = $bytes || $FILLUNIT; + $bytes = $bytes || $FILLUNIT; # Fill up our internal buffer in such a way that the boundary # is never split between reads. $self->fillBuffer($bytes); + my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY}; + my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--'; + # Find the boundary in the buffer (it may not be there). - my $start = index($self->{BUFFER},$self->{BOUNDARY}); + my $start = index($self->{BUFFER},$boundary_start); + + warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if DEBUG; + # protect against malformed multipart POST operations - die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0); + die "Malformed multipart POST\n" unless $self->{CHUNKED} || ($start >= 0 || $self->{LENGTH} > 0); + + #EBCDIC NOTE: want to translate boundary search into ASCII here. # If the boundary begins the data, then skip past it # and return undef. if ($start == 0) { # clear us out completely if we've hit the last boundary. - if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) { + if (index($self->{BUFFER},$boundary_end)==0) { $self->{BUFFER}=''; $self->{LENGTH}=0; return undef; } # just remove the boundary. - substr($self->{BUFFER},0,length($self->{BOUNDARY}))=''; + substr($self->{BUFFER},0,length($boundary_start))=''; $self->{BUFFER} =~ s/^\012\015?//; return undef; } @@ -3513,7 +3713,7 @@ sub read { # leave enough bytes in the buffer to allow us to read # the boundary. Thanks to Kevin Hendrick for finding # this one. - $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1); + $bytesToReturn = $bytes - (length($boundary_start)+1); } my $returnval=substr($self->{BUFFER},0,$bytesToReturn); @@ -3531,18 +3731,18 @@ END_OF_FUNC 'fillBuffer' => <<'END_OF_FUNC', sub fillBuffer { my($self,$bytes) = @_; - return unless $self->{LENGTH}; + return unless $self->{CHUNKED} || $self->{LENGTH}; my($boundaryLength) = length($self->{BOUNDARY}); my($bufferLength) = length($self->{BUFFER}); my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2; - $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead; + $bytesToRead = $self->{LENGTH} if !$self->{CHUNKED} && $self->{LENGTH} < $bytesToRead; - # Try to read some data. We may hang here if the browser is screwed up. - my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN}, - \$self->{BUFFER}, + # Try to read some data. We may hang here if the browser is screwed up. + my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER}, $bytesToRead, $bufferLength); + warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if DEBUG; $self->{BUFFER} = '' unless defined $self->{BUFFER}; # An apparent bug in the Apache server causes the read() @@ -3550,14 +3750,14 @@ sub fillBuffer { # remote user aborts during a file transfer. I don't know how # they manage this, but the workaround is to abort if we get # more than SPIN_LOOP_MAX consecutive zero reads. - if ($bytesRead == 0) { + if ($bytesRead <= 0) { die "CGI.pm: Server closed socket during multipart read (client aborted?).\n" if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX); } else { $self->{ZERO_LOOP_COUNTER}=0; } - $self->{LENGTH} -= $bytesRead; + $self->{LENGTH} -= $bytesRead if !$self->{CHUNKED} && $bytesRead; } END_OF_FUNC @@ -3580,10 +3780,12 @@ END_OF_AUTOLOAD #################################################################################### package CGITempFile; -$SL = $CGI::SL; -$MAC = $CGI::OS eq 'MACINTOSH'; -my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : ""; -unless ($TMPDIRECTORY) { +sub find_tempdir { + undef $TMPDIRECTORY; + $SL = $CGI::SL; + $MAC = $CGI::OS eq 'MACINTOSH'; + my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : ""; + unless ($TMPDIRECTORY) { @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp", "C:${SL}temp","${SL}tmp","${SL}temp", "${vol}${SL}Temporary Items", @@ -3601,11 +3803,14 @@ unless ($TMPDIRECTORY) { # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0; foreach (@TEMP) { - do {$TMPDIRECTORY = $_; last} if -d $_ && -w _; + do {$TMPDIRECTORY = $_; last} if -d $_ && -w _; } + } + $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY; } -$TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY; +find_tempdir(); + $MAXTRIES = 5000; # cute feature, but overload implementation broke it @@ -3630,6 +3835,7 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; sub new { my($package,$sequence) = @_; my $filename; + find_tempdir() unless -w $TMPDIRECTORY; for (my $i = 0; $i < $MAXTRIES; $i++) { last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++)); } @@ -3699,9 +3905,12 @@ CGI - Simple Common Gateway Interface Class hr; if (param()) { - print "Your name is",em(param('name')),p, - "The keywords are: ",em(join(", ",param('words'))),p, - "Your favorite color is ",em(param('color')), + my $name = param('name'); + my $keywords = join ', ',param('words'); + my $color = param('color'); + print "Your name is",em(escapeHTML($name)),p, + "The keywords are: ",em(escapeHTML($keywords)),p, + "Your favorite color is ",em(escapeHTML($color)), hr; } @@ -4105,7 +4314,7 @@ function calls (also see the section on CGI-LIB compatibility). =head2 SAVING THE STATE OF THE SCRIPT TO A FILE: - $query->save(FILEHANDLE) + $query->save(\*FILEHANDLE) This will write the current state of the form to the provided filehandle. You can read it back in by providing a filehandle @@ -4135,14 +4344,14 @@ a short example of creating multiple session records: foreach (0..$records) { my $q = new CGI; $q->param(-name=>'counter',-value=>$_); - $q->save(OUT); + $q->save(\*OUT); } close OUT; # reopen for reading open (IN,"test.out") || die; while (!eof(IN)) { - my $q = new CGI(IN); + my $q = new CGI(\*IN); print $q->param('counter'),"\n"; } @@ -4358,11 +4567,16 @@ then import the functions individually in each mod_perl script. =item -nosticky -This makes CGI.pm not generating the hidden fields .submit -and .cgifields. It is very useful if you don't want to -have the hidden fields appear in the querystring in a GET method. -For example, a search script generated this way will have -a very nice url with search parameters for bookmarking. +By default the CGI module implements a state-preserving behavior +called "sticky" fields. The way this works is that if you are +regenerating a form, the methods that generate the form field values +will interrogate param() to see if similarly-named parameters are +present in the query string. If they find a like-named parameter, they +will use it to set their default values. + +Sometimes this isn't what you want. The B<-nosticky> pragma prevents +this behavior. You can also selectively change the sticky behavior in +each element that you generate. =item -no_undef_params @@ -4375,6 +4589,10 @@ By default, CGI.pm versions 2.69 and higher emit XHTML feature. Thanks to Michalis Kabrianis for this feature. +If start_html()'s -dtd parameter specifies an HTML 2.0 or 3.2 DTD, +XHTML will automatically be disabled without needing to use this +pragma. + =item -nph This makes CGI.pm produce a header appropriate for an NPH (no @@ -4529,19 +4747,19 @@ date, and whether to cache the document. The header can also be manipulated for special purposes, such as server push and pay per view pages. - print $query->header; + print header; -or- - print $query->header('image/gif'); + print header('image/gif'); -or- - print $query->header('text/html','204 No response'); + print header('text/html','204 No response'); -or- - print $query->header(-type=>'image/gif', + print header(-type=>'image/gif', -nph=>1, -status=>'402 Payment required', -expires=>'+3d', @@ -4563,7 +4781,7 @@ parameters will be stripped of their initial hyphens and turned into header fields, allowing you to specify any HTTP header you desire. Internal underscores will be turned into hyphens: - print $query->header(-Content_length=>3002); + print header(-Content_length=>3002); Most browsers will not cache the output from CGI scripts. Every time the browser reloads the page, the script is invoked anew. You can @@ -4615,7 +4833,7 @@ In either case, the outgoing header will be formatted as: =head2 GENERATING A REDIRECTION HEADER - print $query->redirect('http://somewhere.else/in/movie/land'); + print redirect('http://somewhere.else/in/movie/land'); Sometimes you don't want to produce a document yourself, but simply redirect the browser elsewhere, perhaps choosing a URL based on the @@ -4625,25 +4843,35 @@ The redirect() function redirects the browser to a different URL. If you use redirection like this, you should B print out a header as well. -One hint I can offer is that relative links may not work correctly -when you generate a redirection to another document on your site. -This is due to a well-intentioned optimization that some servers use. -The solution to this is to use the full URL (including the http: part) -of the document you are redirecting to. +You should always use full URLs (including the http: or ftp: part) in +redirection requests. Relative URLs will not work correctly. You can also use named arguments: - print $query->redirect(-uri=>'http://somewhere.else/in/movie/land', - -nph=>1); + print redirect(-uri=>'http://somewhere.else/in/movie/land', + -nph=>1, + -status=>301); The B<-nph> parameter, if set to a true value, will issue the correct headers to work with a NPH (no-parse-header) script. This is important -to use with certain servers, such as Microsoft Internet Explorer, which +to use with certain servers, such as Microsoft IIS, which expect all their scripts to be NPH. +The B<-status> parameter will set the status of the redirect. HTTP +defines three different possible redirection status codes: + + 301 Moved Permanently + 302 Found + 303 See Other + +The default if not specified is 302, which means "moved temporarily." +You may change the status to another status code if you wish. Be +advised that changing the status to anything other than 301, 302 or +303 will probably break redirection. + =head2 CREATING THE HTML DOCUMENT HEADER - print $query->start_html(-title=>'Secrets of the Pyramids', + print start_html(-title=>'Secrets of the Pyramids', -author=>'fred@capricorn.org', -base=>'true', -target=>'_blank', @@ -4697,17 +4925,25 @@ into your code. See the section on CASCADING STYLESHEETS for more information. The B<-lang> argument is used to incorporate a language attribute into -the tag. The default if not specified is "en-US" for US -English. For example: +the tag. For example: print $q->start_html(-lang=>'fr-CA'); -To leave off the lang attribute, as you must do if you want to generate -legal HTML 3.2 or earlier, pass the empty string (-lang=>''). +The default if not specified is "en-US" for US English, unless the +-dtd parameter specifies an HTML 2.0 or 3.2 DTD, in which case the +lang attribute is left off. You can force the lang attribute to left +off in other cases by passing an empty string (-lang=>''). The B<-encoding> argument can be used to specify the character set for XHTML. It defaults to iso-8859-1 if not specified. +The B<-declare_xml> argument, when used in conjunction with XHTML, +will put a declaration at the top of the HTML header. The sole +purpose of this declaration is to declare the character set +encoding. In the absence of -declare_xml, the output HTML will contain +a tag that specifies the encoding, allowing the HTML to pass +most validators. The default for -declare_xml is false. + You can place other arbitrary HTML elements to the section with the B<-head> tag. For example, to place the rarely-used element in the head section, use this: @@ -4751,7 +4987,7 @@ browser. Usually these parameters are calls to functions defined in the B<-script> field: $query = new CGI; - print $query->header; + print header; $JSCRIPT=< field: alert("Wrong! Guess again."); } END - print $query->start_html(-title=>'The Riddle of the Sphinx', + print start_html(-title=>'The Riddle of the Sphinx', -script=>$JSCRIPT); Use the B<-noScript> parameter to pass some HTML text that will be displayed on @@ -4852,13 +5088,13 @@ place to put Netscape extensions, such as colors and wallpaper patterns. =head2 ENDING THE HTML DOCUMENT: - print $query->end_html + print end_html This ends an HTML document by printing the tags. =head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION: - $myself = $query->self_url; + $myself = self_url; print q(I'm talking to myself.); self_url() will return a URL, that, when selected, will reinvoke @@ -4867,7 +5103,7 @@ useful when you want to jump around within the document using internal anchors but you don't want to disrupt the current contents of the form(s). Something like this will do the trick. - $myself = $query->self_url; + $myself = self_url; print "See table 1"; print "See table 2"; print "See for yourself"; @@ -4877,17 +5113,17 @@ method instead. You can also retrieve the unprocessed query string with query_string(): - $the_string = $query->query_string; + $the_string = query_string; =head2 OBTAINING THE SCRIPT'S URL - $full_url = $query->url(); - $full_url = $query->url(-full=>1); #alternative syntax - $relative_url = $query->url(-relative=>1); - $absolute_url = $query->url(-absolute=>1); - $url_with_path = $query->url(-path_info=>1); - $url_with_path_and_query = $query->url(-path_info=>1,-query=>1); - $netloc = $query->url(-base => 1); + $full_url = url(); + $full_url = url(-full=>1); #alternative syntax + $relative_url = url(-relative=>1); + $absolute_url = url(-absolute=>1); + $url_with_path = url(-path_info=>1); + $url_with_path_and_query = url(-path_info=>1,-query=>1); + $netloc = url(-base => 1); B returns the script's URL in a variety of formats. Called without any arguments, it returns the full form of the URL, including @@ -4937,7 +5173,7 @@ Generate just the protocol and net location, as in http://www.foo.com:8000 =head2 MIXING POST AND URL PARAMETERS - $color = $query->url_param('color'); + $color = url_param('color'); It is possible for a script to receive CGI parameters in the URL as well as in the fill-out form by creating a form that POSTs to a URL @@ -4965,7 +5201,6 @@ commonly, print out so that it displays in the browser window. This example shows how to use the HTML methods: - $q = new CGI; print $q->blockquote( "Many years ago on the island of", $q->a({href=>"http://crete.org/"},"Crete"), @@ -5196,7 +5431,7 @@ choices: (2) use the -override (alias -force) parameter (a new feature in version 2.15). This forces the default value to be used, regardless of the previous value: - print $query->textfield(-name=>'field_name', + print textfield(-name=>'field_name', -default=>'starting value', -override=>1, -size=>50, @@ -5210,15 +5445,30 @@ into your fields. If you wish to turn off automatic escaping, call the autoEscape() method with a false value immediately after creating the CGI object: $query = new CGI; - $query->autoEscape(undef); + autoEscape(undef); + +I Some of the form-element generating methods return +multiple tags. In a scalar context, the tags will be concatenated +together with spaces, or whatever is the current value of the $" +global. In a list context, the methods will return a list of +elements, allowing you to modify them if you wish. Usually you will +not notice this behavior, but beware of this: + + printf("%s\n",end_form()) + +end_form() produces several tags, and only the first of them will be +printed because the format only expects one value. + +

+ =head2 CREATING AN ISINDEX TAG - print $query->isindex(-action=>$action); + print isindex(-action=>$action); -or- - print $query->isindex($action); + print isindex($action); Prints out an tag. Not very exciting. The parameter -action specifies the URL of the script to process the query. The @@ -5226,17 +5476,17 @@ default is to process the query with the current script. =head2 STARTING AND ENDING A FORM - print $query->start_form(-method=>$method, - -action=>$action, - -enctype=>$encoding); + print start_form(-method=>$method, + -action=>$action, + -enctype=>$encoding); <... various form stuff ...> - print $query->endform; + print endform; -or- - print $query->start_form($method,$action,$encoding); + print start_form($method,$action,$encoding); <... various form stuff ...> - print $query->endform; + print endform; start_form() will return a
tag with the optional method, action and form encoding that you specify. The defaults are: @@ -5277,6 +5527,9 @@ Forms that use this type of encoding are not easily interpreted by CGI scripts unless they use CGI.pm or another library designed to handle them. +If XHTML is activated (the default), then forms will be automatically +created using this type of encoding. + =back For compatibility, the start_form() method uses the older form of @@ -5298,17 +5551,67 @@ Usually the bulk of JavaScript functions are defined in a

$_
$rowheaders->[$row]$rowheaders[$row]" . $elements[$column*$rows + $row] . "