X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/efc8e943aad385721753037c6be3d8bf9a5c28d8..21c1191d96d28acb87f4479c4eef93ca5aef5405:/lib/CGI.pm diff --git a/lib/CGI.pm b/lib/CGI.pm index 68072f0..4d5742b 100644 --- a/lib/CGI.pm +++ b/lib/CGI.pm @@ -18,8 +18,8 @@ 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.151 2004/01/13 16:28:35 lstein Exp $'; -$CGI::VERSION=3.03; +$CGI::revision = '$Id: CGI.pm,v 1.194 2005/12/06 22:12:56 lstein Exp $'; +$CGI::VERSION='3.15_01'; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. @@ -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 { @@ -78,6 +77,9 @@ sub initialize_globals { # 2) CGI::private_tempfiles(1); $PRIVATE_TEMPFILES = 0; + # Set this to 1 to generate automatic tab indexes + $TABINDEX = 0; + # Set this to 1 to cause files uploaded in multipart documents # to be closed, instead of caching the file handle # or: @@ -111,6 +113,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 +125,8 @@ sub initialize_globals { # ------------------ START OF THE LIBRARY ------------ +*end_form = \&endform; + # make mod_perlhappy initialize_globals(); @@ -175,20 +180,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::Response; - 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; } } @@ -231,7 +234,8 @@ 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_port virtual_host remote_ident auth_type http append @@ -246,6 +250,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; @@ -301,7 +332,7 @@ sub new { 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); } @@ -310,14 +341,16 @@ sub new { $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); } @@ -337,9 +370,11 @@ sub new { # 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}; + if ($OS eq 'WINDOWS') { + foreach my $href (values %{$self->{'.tmpfiles'}}) { + $href->{hndl}->DESTROY if defined $href->{hndl}; + $href->{name}->DESTROY if defined $href->{name}; + } } } @@ -351,7 +386,13 @@ sub r { } sub upload_hook { - my ($self,$hook,$data) = self_or_default(@_); + my $self; + if (ref $_[0] eq 'CODE') { + $CGI::Q = $self = $CGI::DefaultClass->new(@_); + } else { + $self = shift; + } + my ($hook,$data) = @_; $self->{'.upload_hook'} = $hook; $self->{'.upload_data'} = $data; } @@ -469,16 +510,15 @@ sub init { if (($POST_MAX > 0) && ($content_length > $POST_MAX)) { # quietly read and discard the post my $buffer; - my $max = $content_length; - 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; - } - } + my $tmplength = $content_length; + while($tmplength > 0) { + my $maxbuffer = ($tmplength < 10000)?$tmplength:10000; + my $bytesread = $MOD_PERL ? $self->r->read($buffer,$maxbuffer) : read(STDIN,$buffer,$maxbuffer); + $tmplength -= $bytesread; + } + $self->cgi_error("413 Request entity too large"); + last METHOD; + } # Process multipart postings, but only if the initializer is # not defined. @@ -606,7 +646,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 @@ -757,6 +797,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!!!) @@ -775,6 +816,7 @@ sub _compile { } } croak("Undefined subroutine $AUTOLOAD\n") unless $code; + local ($@,$!); eval "package $pack; $code"; if ($@) { $@ =~ s/ at .*\n//; @@ -789,14 +831,14 @@ sub _selected { my $self = shift; my $value = shift; return '' unless $value; - return $XHTML ? qq( selected="selected") : qq( selected); + return $XHTML ? qq(selected="selected" ) : qq(selected ); } sub _checked { my $self = shift; my $value = shift; return '' unless $value; - return $XHTML ? qq( checked="checked") : qq( checked); + return $XHTML ? qq(checked="checked" ) : qq(checked ); } sub _reset_globals { initialize_globals(); } @@ -819,7 +861,8 @@ 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$/; + $TABINDEX++, next if /^[:-]tabindex$/; + $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/; $EXPORT{$_}++, next if /^[:-]any$/; $compile++, next if /^[:-]compile$/; $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/; @@ -850,6 +893,21 @@ 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; + my $tab = $self->{'.etab'}++; + return '' unless $TABINDEX or defined $new_value; + return qq(tabindex="$tab" ); +} + ############################################################################### ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### ############################################################################### @@ -905,7 +963,7 @@ sub delete { $to_delete{$name}++; } @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param(); - return wantarray ? () : undef; + return; } END_OF_FUNC @@ -1090,7 +1148,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) { @@ -1279,7 +1337,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; @@ -1439,12 +1497,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; @@ -1479,16 +1539,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')) { @@ -1502,19 +1562,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) { @@ -1531,8 +1612,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 @@ -1559,36 +1641,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; } @@ -1635,8 +1724,8 @@ sub _script { 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 || '')); + $code = $cdata_start . $code . $cdata_end if defined $code; + push(@result,$self->script({@satts},$code || '')); } @result; } @@ -1648,7 +1737,7 @@ END_OF_FUNC #### 'end_html' => <<'END_OF_FUNC', sub end_html { - return ""; + return "\n\n"; } END_OF_FUNC @@ -1687,14 +1776,13 @@ 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->escapeHTML($self->url(-absolute=>1,-path=>1)); - if (length($ENV{QUERY_STRING})>0) { - $action .= "?".$self->escapeHTML($ENV{QUERY_STRING},1); - } + $method = $self->escapeHTML(lc($method) || 'post'); + $enctype = $self->escapeHTML($enctype || &URL_ENCODED); + if (defined $action) { + $action = $self->escapeHTML($action); + } + else { + $action = $self->escapeHTML($self->request_uri); } $action = qq(action="$action"); my($other) = @other ? " @other" : ''; @@ -1708,7 +1796,7 @@ END_OF_FUNC # synonym for startform 'start_form' => <<'END_OF_FUNC', sub start_form { - &startform; + $XHTML ? &start_multipart_form : &startform; } END_OF_FUNC @@ -1723,7 +1811,7 @@ END_OF_FUNC 'start_multipart_form' => <<'END_OF_FUNC', sub start_multipart_form { my($self,@p) = self_or_default(@_); - if (defined($param[0]) && substr($param[0],0,1) eq '-') { + if (defined($p[0]) && substr($p[0],0,1) eq '-') { my(%p) = @p; $p{'-enctype'}=&MULTIPART; return $self->startform(%p); @@ -1740,31 +1828,26 @@ END_OF_FUNC # End a form 'endform' => <<'END_OF_FUNC', sub endform { - my($self,@p) = self_or_default(@_); + my($self,@p) = self_or_default(@_); if ( $NOSTICKY ) { return wantarray ? ("") : "\n"; } else { - return wantarray ? ("
",$self->get_fields,"
","") : - "
".$self->get_fields ."
\n"; + if (my @fields = $self->get_fields) { + return wantarray ? ("
",@fields,"
","") + : "
".(join '',@fields)."
\n"; + } else { + return ""; + } } } 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); @@ -1777,7 +1860,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 @@ -1847,9 +1931,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); @@ -1859,7 +1942,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 @@ -1878,8 +1962,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); @@ -1892,7 +1976,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 @@ -1911,19 +1996,20 @@ 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 = $NOSTICKY ? '' : ' name=".submit"'; - $name = qq/ name="$label"/ if defined($label); + 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); - my($other) = @other ? " @other" : ''; - return $XHTML ? qq() - : qq(); + $val = qq/value="$value" / if defined($value); + $tabindex = $self->element_tab($tabindex); + my($other) = @other ? "@other " : ''; + return $XHTML ? qq() + : qq(); } END_OF_FUNC @@ -1938,7 +2024,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"'; @@ -1947,7 +2033,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 @@ -1968,13 +2055,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 @@ -2006,9 +2094,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} || @@ -2021,85 +2109,15 @@ sub checkbox { $name = $self->escapeHTML($name); $value = $self->escapeHTML($value,1); $the_label = $self->escapeHTML($the_label); - my($other) = @other ? " @other" : ''; + 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', @@ -2112,7 +2130,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 @@ -2156,8 +2182,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)) { @@ -2166,18 +2192,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]); @@ -2210,30 +2236,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 - 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); +#### 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 + +'_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 && $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 ? "
" : "
"; @@ -2247,13 +2323,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 = $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); } @@ -2278,9 +2360,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))) { @@ -2293,8 +2375,8 @@ sub popup_menu { my(@values); @values = $self->_set_values_and_labels($values,\$labels,$name); - - $result = qq/\n/; foreach (@values) { if (/{$_} if defined($labels) && defined($labels->{$_}); my($value) = $self->escapeHTML($_); $label=$self->escapeHTML($label,1); - $result .= "$label\n"; + $result .= "\n"; } } @@ -2403,9 +2485,9 @@ END_OF_FUNC 'scrolling_list' => <<'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); @@ -2418,7 +2500,8 @@ sub scrolling_list { my($other) = @other ? " @other" : ''; $name=$self->escapeHTML($name); - $result = qq/\n/; foreach (@values) { my($selectit) = $self->_selected($selected{$_}); my($label) = $_; @@ -2426,7 +2509,7 @@ sub scrolling_list { $label=$self->escapeHTML($label); my($value)=$self->escapeHTML($_,1); my $attribs = $self->_set_attributes($_, $attributes); - $result .= "$label\n"; + $result .= "\n"; } $result .= ""; $self->register_parameter($name); @@ -2471,8 +2554,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); } @@ -2533,30 +2616,28 @@ END_OF_FUNC 'url' => <<'END_OF_FUNC', sub url { my($self,@p) = self_or_default(@_); - my ($relative,$absolute,$full,$path_info,$query,$base) = - rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE'],@p); - my $url; + my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) = + rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p); + my $url = ''; $full++ if $base || !($relative || $absolute); + $rewrite++ unless defined $rewrite; - 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 = unescape($ENV{PATH_INFO}); - $script_name =~ s/\Q$encoded_path\E$//i; - } - } + my $path = $self->path_info; + my $script_name = $self->script_name; + my $request_uri = $self->request_uri || ''; + my $query_str = $self->query_string; + + my $rewrite_in_use = $request_uri && $request_uri !~ /^$script_name/; + undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active + + my $uri = $rewrite && $request_uri ? $request_uri : $script_name; + $uri =~ s/\?.*$//; # remove query string + $uri =~ s/$path$// if defined $path; # remove path 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 { @@ -2567,16 +2648,15 @@ sub url { || (lc($protocol) eq 'https' && $port == 443); } return $url if $base; - $url .= $script_name; + $url .= $uri; } elsif ($relative) { ($url) = $script_name =~ m!([^/]+)$!; } elsif ($absolute) { - $url = $script_name; + $url = $uri; } - $url .= $path if $path_info and defined $path; - $url .= "?" . $self->query_string if $query and $self->query_string; - $url = '' unless defined $url; + $url .= $path if $path_info and defined $path; + $url .= "?$query_str" if $query and $query_str ne ''; $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg; return $url; } @@ -2670,9 +2750,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; @@ -2681,6 +2760,37 @@ 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} || ''; + + if ($raw_script_name =~ m/$raw_path_info$/) { + $raw_script_name =~ s/$raw_path_info$//; + } + + 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' @@ -2711,6 +2821,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 @@ -2828,7 +2948,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; } @@ -2866,10 +2986,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 @@ -2910,9 +3034,10 @@ END_OF_FUNC 'virtual_port' => <<'END_OF_FUNC', sub virtual_port { my($self) = self_or_default(@_); - my $vh = $self->http('host'); + my $vh = $self->http('x_forwarded_host') || $self->http('host'); + my $protocol = $self->protocol; if ($vh) { - return ($vh =~ /:(\d+)$/)[0] || '80'; + return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80); } else { return $self->server_port(); } @@ -3183,11 +3308,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/ ) ? @@ -3223,7 +3348,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; @@ -3268,7 +3393,11 @@ sub read_multipart { # Save some information about the uploaded file where we can get # at it later. - $self->{'.tmpfiles'}->{fileno($filehandle)}= { + # Use the typeglob as the key, as this is guaranteed to be + # unique for each filehandle. Don't use the file descriptor as + # this will be re-used for each filehandle if the + # close_upload_files feature is used. + $self->{'.tmpfiles'}->{$$filehandle}= { hndl => $filehandle, name => $tmpfile, info => {%header}, @@ -3291,8 +3420,8 @@ END_OF_FUNC 'tmpFileName' => <<'END_OF_FUNC', sub tmpFileName { my($self,$filename) = self_or_default(@_); - return $self->{'.tmpfiles'}->{fileno($filename)}->{name} ? - $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string + return $self->{'.tmpfiles'}->{$$filename}->{name} ? + $self->{'.tmpfiles'}->{$$filename}->{name}->as_string : ''; } END_OF_FUNC @@ -3300,7 +3429,7 @@ END_OF_FUNC 'uploadInfo' => <<'END_OF_FUNC', sub uploadInfo { my($self,$filename) = self_or_default(@_); - return $self->{'.tmpfiles'}->{fileno($filename)}->{info}; + return $self->{'.tmpfiles'}->{$$filename}->{info}; } END_OF_FUNC @@ -3324,8 +3453,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; @@ -3361,6 +3490,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 = ( @@ -3407,13 +3541,6 @@ sub new { } END_OF_FUNC -'DESTROY' => <<'END_OF_FUNC', -sub DESTROY { - my $self = shift; - close $self; -} -END_OF_FUNC - ); END_OF_AUTOLOAD @@ -3447,7 +3574,7 @@ sub new { my($package,$interface,$boundary,$length) = @_; $FILLUNIT = $INITIAL_FILLUNIT; $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always - + # 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 @@ -3477,6 +3604,7 @@ sub new { } my $self = {LENGTH=>$length, + CHUNKED=>!defined $length, BOUNDARY=>$boundary, INTERFACE=>$interface, BUFFER=>'', @@ -3587,9 +3715,9 @@ sub read { 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); + # protect against malformed multipart POST operations + die "Malformed multipart POST\n" unless $self->{CHUNKED} || ($start >= 0 || $self->{LENGTH} > 0); #EBCDIC NOTE: want to translate boundary search into ASCII here. @@ -3635,12 +3763,12 @@ 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->{BUFFER}, @@ -3654,14 +3782,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 @@ -3685,11 +3813,10 @@ END_OF_AUTOLOAD package CGITempFile; sub find_tempdir { - undef $TMPDIRECTORY; $SL = $CGI::SL; $MAC = $CGI::OS eq 'MACINTOSH'; my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : ""; - unless ($TMPDIRECTORY) { + unless (defined $TMPDIRECTORY) { @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp", "C:${SL}temp","${SL}tmp","${SL}temp", "${vol}${SL}Temporary Items", @@ -3809,9 +3936,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; } @@ -4170,6 +4300,21 @@ that all the defaults are taken when you create a fill-out form. Use Delete_all() instead if you are using the function call interface. +=head2 HANDLING NON-URLENCODED ARGUMENTS + + +If POSTed data is not of type application/x-www-form-urlencoded or +multipart/form-data, then the POSTed data will not be processed, but +instead be returned as-is in a parameter named POSTDATA. To retrieve +it, use code like this: + + my $data = $query->param('POSTDATA'); + +(If you don't know what the preceding means, don't worry about it. It +only affects people trying to use CGI for XML processing and other +specialized tasks.) + + =head2 DIRECT ACCESS TO THE PARAMETER LIST: $q->param_fetch('address')->[1] = '1313 Mockingbird Lane'; @@ -4215,7 +4360,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 @@ -4245,14 +4390,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"; } @@ -4468,11 +4613,22 @@ 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 -tabindex + +Automatically add tab index attributes to each form field. With this +option turned off, you can still add tab indexes manually by passing a +-tabindex option to each field-generating method. =item -no_undef_params @@ -4485,6 +4641,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 @@ -4639,19 +4799,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', @@ -4673,7 +4833,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 @@ -4725,7 +4885,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 @@ -4740,17 +4900,30 @@ 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 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', @@ -4804,17 +4977,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: @@ -4858,7 +5039,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 @@ -4959,13 +5140,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 @@ -4974,7 +5155,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"; @@ -4984,17 +5165,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 @@ -5040,11 +5221,21 @@ as a synonym. Generate just the protocol and net location, as in http://www.foo.com:8000 +=item B<-rewrite> + +If Apache's mod_rewrite is turned on, then the script name and path +info probably won't match the request that the user sent. Set +-rewrite=>1 (default) to return URLs that match what the user sent +(the original request URI). Set -rewrite->0 to return URLs that match +the URL after mod_rewrite's rules have run. Because the additional +path information only makes sense in the context of the rewritten URL, +-rewrite is set to false when you request path info in the URL. + =back =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 @@ -5072,7 +5263,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"), @@ -5303,7 +5493,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, @@ -5317,15 +5507,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 @@ -5333,17 +5538,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: @@ -5384,6 +5589,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 @@ -5405,17 +5613,67 @@ Usually the bulk of JavaScript functions are defined in a

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