$title

From: Rafael Garcia-Suarez Date: Thu, 10 Mar 2005 10:10:33 +0000 (+0000) Subject: Upgrade to CGI.pm 3.06 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=29ddc2a4443cff956621f7b060b68c8ff93220d4;p=p5sagit%2Fp5-mst-13.2.git Upgrade to CGI.pm 3.06 p4raw-id: //depot/perl@24013 --- diff --git a/lib/CGI.pm b/lib/CGI.pm index 148b861..94c4e65 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.165 2004/04/12 20:37:26 lstein Exp $'; -$CGI::VERSION=3.05; +$CGI::revision = '$Id: CGI.pm,v 1.177 2005/03/09 21:04:48 lstein Exp $'; +$CGI::VERSION=3.06; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. @@ -248,6 +248,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; @@ -759,6 +786,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!!!) @@ -777,6 +805,7 @@ sub _compile { } } croak("Undefined subroutine $AUTOLOAD\n") unless $code; + local ($@,$!); eval "package $pack; $code"; if ($@) { $@ =~ s/ at .*\n//; @@ -852,6 +881,18 @@ 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'} = $new_value if defined $new_value; + $self->{'.etab'}++; +} + ############################################################################### ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### ############################################################################### @@ -1483,8 +1524,12 @@ 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; @@ -1502,7 +1547,7 @@ 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]">)); @@ -1526,12 +1571,16 @@ sub start_html { $lang = 'en-US' unless defined $lang; } - push(@result,$XHTML ? qq($title) - : ($lang ? qq() : "") + 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) { @@ -1550,6 +1599,7 @@ sub start_html { # handle the infrequently-used -style and -script parameters 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 @@ -1659,8 +1709,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; } @@ -1672,7 +1722,7 @@ END_OF_FUNC #### 'end_html' => <<'END_OF_FUNC', sub end_html { - return ""; + return "\n\n"; } END_OF_FUNC @@ -1734,7 +1784,7 @@ END_OF_FUNC # synonym for startform 'start_form' => <<'END_OF_FUNC', sub start_form { - &startform; + $XHTML ? &start_multipart_form : &startform; } END_OF_FUNC @@ -1780,8 +1830,8 @@ 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); @@ -1794,7 +1844,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 @@ -1864,9 +1915,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); @@ -1876,7 +1926,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 @@ -1895,8 +1946,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); @@ -1909,7 +1960,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 @@ -1928,7 +1980,7 @@ 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); @@ -1938,8 +1990,9 @@ sub submit { $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 @@ -1955,7 +2008,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"'; @@ -1964,7 +2017,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 @@ -1985,13 +2039,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 @@ -2023,9 +2078,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} || @@ -2039,84 +2094,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', @@ -2181,8 +2166,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)) { @@ -2191,18 +2176,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]); @@ -2235,30 +2220,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 ? "
" : "
"; @@ -2272,13 +2307,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); } @@ -2303,9 +2344,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))) { @@ -2318,8 +2359,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); @@ -2443,7 +2484,8 @@ sub scrolling_list { my($other) = @other ? " @other" : ''; $name=$self->escapeHTML($name); - $result = qq/\n/; foreach (@values) { my($selectit) = $self->_selected($selected{$_}); my($label) = $_; @@ -3248,7 +3290,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; @@ -3386,6 +3428,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 = ( @@ -3432,13 +3479,6 @@ sub new { } END_OF_FUNC -'DESTROY' => <<'END_OF_FUNC', -sub DESTROY { - my $self = shift; - close $self; -} -END_OF_FUNC - ); END_OF_AUTOLOAD @@ -3472,7 +3512,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 @@ -3502,6 +3542,7 @@ sub new { } my $self = {LENGTH=>$length, + CHUNKED=>!defined $length, BOUNDARY=>$boundary, INTERFACE=>$interface, BUFFER=>'', @@ -3612,9 +3653,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. @@ -3660,12 +3701,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}, @@ -3679,14 +3720,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 @@ -4240,7 +4281,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 @@ -4270,14 +4311,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"; } @@ -4493,11 +4534,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 @@ -4668,19 +4714,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', @@ -4702,7 +4748,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 @@ -4754,7 +4800,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 @@ -4769,7 +4815,7 @@ redirection requests. Relative URLs will not work correctly. You can also use named arguments: - print $query->redirect(-uri=>'http://somewhere.else/in/movie/land', + print redirect(-uri=>'http://somewhere.else/in/movie/land', -nph=>1, -status=>301); @@ -4792,7 +4838,7 @@ advised that changing the status to anything other than 301, 302 or =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', @@ -4858,6 +4904,13 @@ 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: @@ -4901,7 +4954,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 @@ -5002,13 +5055,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 @@ -5017,7 +5070,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"; @@ -5027,17 +5080,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 @@ -5087,7 +5140,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 @@ -5115,7 +5168,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"), @@ -5346,7 +5398,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, @@ -5360,7 +5412,7 @@ 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 @@ -5369,7 +5421,7 @@ 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",$query->end_form()) + 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. @@ -5379,11 +5431,11 @@ 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 @@ -5391,17 +5443,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: @@ -5442,6 +5494,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 @@ -5463,17 +5518,67 @@ Usually the bulk of JavaScript functions are defined in a

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