From: Jarkko Hietaniemi Date: Thu, 10 Aug 2000 23:03:34 +0000 (+0000) Subject: Update to CGI 2.70, from Lincoln Stein. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6b4ac6611c98278a0d6cf49b8f443a5cf6468a7a;p=p5sagit%2Fp5-mst-13.2.git Update to CGI 2.70, from Lincoln Stein. p4raw-id: //depot/perl@6580 --- diff --git a/lib/CGI.pm b/lib/CGI.pm index 8b7568a..e017853 100644 --- a/lib/CGI.pm +++ b/lib/CGI.pm @@ -17,18 +17,24 @@ require 5.004; # The most recent version and complete docs are available at: # http://stein.cshl.org/WWW/software/CGI/ -$CGI::revision = '$Id: CGI.pm,v 1.30 2000/03/28 21:31:40 lstein Exp $'; -$CGI::VERSION='2.66'; +$CGI::revision = '$Id: CGI.pm,v 1.39 2000/07/28 03:00:03 lstein Exp $'; +$CGI::VERSION='2.70'; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. # $TempFile::TMPDIRECTORY = '/usr/tmp'; use CGI::Util qw(rearrange make_attributes unescape escape expires); +use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN', + 'DTD/xhtml1-transitional.dtd']; + # >>>>> Here are some globals that you might want to adjust <<<<<< sub initialize_globals { # Set this to 1 to enable copious autoloader debugging messages $AUTOLOAD_DEBUG = 0; + + # Set this to 1 to generate XTML-compatible output + $XHTML = 1; # Change this to the preferred DTD to print in start_html() # or use default_dtd('text of DTD to use'); @@ -569,13 +575,13 @@ sub _make_tag_func { } ); if ($tagname=~/start_(\w+)/i) { - $func .= qq! return "<\U$1\E\$attr>";} !; + $func .= qq! return "<\L$1\E\$attr>";} !; } elsif ($tagname=~/end_(\w+)/i) { - $func .= qq! return "<\U/$1\E>"; } !; + $func .= qq! return "<\L/$1\E>"; } !; } else { $func .= qq# - my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U\E"); - return \$tag unless \@_; + return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@_; + my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L\E"); my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_"; return "\@result"; @@ -644,6 +650,8 @@ sub _setup_symbols { $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/; $DEBUG=2, next if /^[:-][Dd]ebug$/; $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/; + $XHTML++, next if /^[:-]xhtml$/; + $XHTML=0, next if /^[:-]no_?xhtml$/; $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/; $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/; $EXPORT{$_}++, next if /^[:-]any$/; @@ -717,7 +725,8 @@ END_OF_FUNC # Deletes the named parameter entirely. #### sub delete { - my($self,$name) = self_or_default(@_); + my($self,@p) = self_or_default(@_); + my($name) = rearrange([NAME],@p); CORE::delete $self->{$name}; CORE::delete $self->{'.fieldnames'}->{$name}; @{$self->{'.parameters'}}=grep($_ ne $name,$self->param()); @@ -851,7 +860,8 @@ END_OF_FUNC sub STORE { my $self = shift; my $tag = shift; - my @vals = split("\0",shift); + my $vals = shift; + my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals; $self->param(-name=>$tag,-value=>\@vals); } END_OF_FUNC @@ -1135,10 +1145,11 @@ sub header { return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE; - my($type,$status,$cookie,$target,$expires,$nph,$charset,@other) = + my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,@other) = rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], 'STATUS',['COOKIE','COOKIES'],'TARGET', - 'EXPIRES','NPH','CHARSET'],@p); + 'EXPIRES','NPH','CHARSET', + 'ATTACHMENT'],@p); $nph ||= $NPH; if (defined $charset) { @@ -1151,11 +1162,11 @@ sub header { # need to fix it up a little. foreach (@other) { next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/; - ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e; + ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.unescapeHTML($value)/e; } $type ||= 'text/html' unless defined($type); - $type .= "; charset=$charset" if $type ne '' and $type !~ /\bcharset\b/; + $type .= "; charset=$charset" if $type ne '' and $type =~ m!^text/! and $type !~ /\bcharset\b/; # Maybe future compatibility. Maybe not. my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; @@ -1178,6 +1189,7 @@ sub header { if $expires; push(@header,"Date: " . expires(0,'http')) if $expires || $cookie; push(@header,"Pragma: no-cache") if $self->cache(); + push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment; push(@header,@other); push(@header,"Content-Type: $type") if $type ne ''; @@ -1216,7 +1228,7 @@ END_OF_FUNC sub redirect { my($self,@p) = self_or_default(@_); my($url,$target,$cookie,$nph,@other) = rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p); - $url = $url || $self->self_url; + $url ||= $self->self_url; my(@o); foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); } unshift(@o, @@ -1253,39 +1265,45 @@ END_OF_FUNC 'start_html' => <<'END_OF_FUNC', sub start_html { my($self,@p) = &self_or_default(@_); - my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,$dtd,@other) = - rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD],@p); + my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,$dtd,$lang,@other) = + rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD,LANG],@p); # 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'; my(@result); if ($dtd) { - if (ref $dtd && $ref eq 'ARRAY') { + if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) { $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|; } else { $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|; } } else { - $dtd = $DEFAULT_DTD; + $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD; } if (ref($dtd) && ref($dtd) eq 'ARRAY') { - push(@result,qq([0]"\n\t"$dtd->[1]">)); + push(@result,qq([0]"\n\t"$dtd->[1]">)); } else { - push(@result,qq()); + push(@result,qq()); } - push(@result,"$title"); - push(@result,"") if defined $author; + push(@result,$XHTML ? qq($title) + : qq($title)); + if (defined $author) { + push(@result,$XHTML ? "" + : ""); + } if ($base || $xbase || $target) { my $href = $xbase || $self->url('-path'=>1); - my $t = $target ? qq/ TARGET="$target"/ : ''; - push(@result,qq//); + my $t = $target ? qq/ target="$target"/ : ''; + push(@result,$XHTML ? qq() : qq()); } if ($meta && ref($meta) && (ref($meta) eq 'HASH')) { - foreach (keys %$meta) { push(@result,qq()); } + foreach (keys %$meta) { push(@result,$XHTML ? qq() + : qq()); } } push(@result,ref($head) ? @$head : $head) if $head; @@ -1296,13 +1314,13 @@ sub start_html { # handle -noscript parameter push(@result,< + + END ; my($other) = @other ? " @other" : ''; - push(@result,""); + push(@result,""); return join("\n",@result); } END_OF_FUNC @@ -1316,21 +1334,33 @@ sub _style { my (@result); my $type = 'text/css'; if (ref($style)) { - my($src,$code,$stype,@other) = - rearrange([SRC,CODE,TYPE], - '-foo'=>'bar', # a trick to allow the '-' to be omitted - ref($style) eq 'ARRAY' ? @$style : %$style); - $type = $stype if $stype; - push(@result,qq//) if $src; - push(@result,style({'type'=>$type},"")) if $code; + my($src,$code,$stype,@other) = + rearrange([SRC,CODE,TYPE], + '-foo'=>'bar', # a trick to allow the '-' to be omitted + ref($style) eq 'ARRAY' ? @$style : %$style); + $type = $stype if $stype; + #### Here is new code for checking for array reference in -src tag (6/20/00 -- JJN) ##### + #### This should be passed in like this --> -src=>{['style1.css','style2.css','style3.css']} + 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,qq//) if $src; + } + } + else + { # Otherwise, push the single -src, if it exists. + push(@result,qq//) if $src; + } + #### End new code #### + push(@result,style({'type'=>$type},"")) if $code; } else { - push(@result,style({'type'=>$type},"")); + push(@result,style({'type'=>$type},"")); } @result; } END_OF_FUNC - '_script' => <<'END_OF_FUNC', sub _script { my ($self,$script) = @_; @@ -1377,7 +1407,7 @@ END_OF_FUNC #### 'end_html' => <<'END_OF_FUNC', sub end_html { - return ""; + return ""; } END_OF_FUNC @@ -1396,9 +1426,9 @@ END_OF_FUNC sub isindex { my($self,@p) = self_or_default(@_); my($action,@other) = rearrange([ACTION],@p); - $action = qq/ACTION="$action"/ if $action; + $action = qq/action="$action"/ if $action; my($other) = @other ? " @other" : ''; - return ""; + return $XHTML ? "" : ""; } END_OF_FUNC @@ -1416,13 +1446,12 @@ sub startform { my($method,$action,$enctype,@other) = rearrange([METHOD,ACTION,ENCTYPE],@p); - $method = $method || 'POST'; + $method = uc($method) || 'POST'; $enctype = $enctype || &URL_ENCODED; - $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ? - 'ACTION="'.$self->script_name.'"' : ''; + $action = $action ? qq(action="$action") : qq 'action="' . $self->script_name . '"'; my($other) = @other ? " @other" : ''; $self->{'.parametersToAdd'}={}; - return qq/
\n/; + return qq/\n/; } END_OF_FUNC @@ -1465,10 +1494,10 @@ END_OF_FUNC sub endform { my($self,@p) = self_or_default(@_); if ( $NOSTICKY ) { - return wantarray ? ("
") : "\n"; + return wantarray ? ("") : "\n"; } else { - return wantarray ? ($self->get_fields,"") : - $self->get_fields ."\n"; + return wantarray ? ($self->get_fields,"") : + $self->get_fields ."\n"; } } END_OF_FUNC @@ -1494,13 +1523,14 @@ sub _textfield { $current = defined($current) ? $self->escapeHTML($current) : ''; $name = defined($name) ? $self->escapeHTML($name) : ''; - my($s) = defined($size) ? qq/ SIZE=$size/ : ''; - my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : ''; + my($s) = defined($size) ? qq/ size=$size/ : ''; + my($m) = defined($maxlength) ? qq/ maxlength=$maxlength/ : ''; my($other) = @other ? " @other" : ''; # 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 qq//; + my($value) = $current ne '' ? qq(value="$current") : ''; + return $XHTML ? qq() + : qq//; } END_OF_FUNC @@ -1578,10 +1608,10 @@ sub textarea { $name = defined($name) ? $self->escapeHTML($name) : ''; $current = defined($current) ? $self->escapeHTML($current) : ''; - my($r) = $rows ? " ROWS=$rows" : ''; - my($c) = $cols ? " COLS=$cols" : ''; + my($r) = $rows ? " rows=$rows" : ''; + my($c) = $cols ? " cols=$cols" : ''; my($other) = @other ? " @other" : ''; - return qq{}; + return qq{}; } END_OF_FUNC @@ -1611,10 +1641,11 @@ sub button { $name = qq/ NAME="$label"/ if $label; $value = $value || $label; my($val) = ''; - $val = qq/ VALUE="$value"/ if $value; - $script = qq/ ONCLICK="$script"/ if $script; + $val = qq/ value="$value"/ if $value; + $script = qq/ onclick="$script"/ if $script; my($other) = @other ? " @other" : ''; - return qq//; + return $XHTML ? qq() + : qq//; } END_OF_FUNC @@ -1637,13 +1668,14 @@ sub submit { $label=$self->escapeHTML($label); $value=$self->escapeHTML($value); - my($name) = ' NAME=".submit"' unless $NOSTICKY; - $name = qq/ NAME="$label"/ if defined($label); + my($name) = ' name=".submit"' unless $NOSTICKY; + $name = qq/ name="$label"/ if defined($label); $value = defined($value) ? $value : $label; my($val) = ''; - $val = qq/ VALUE="$value"/ if defined($value); + $val = qq/ value="$value"/ if defined($value); my($other) = @other ? " @other" : ''; - return qq//; + return $XHTML ? qq() + : qq//; } END_OF_FUNC @@ -1660,9 +1692,10 @@ sub reset { my($self,@p) = self_or_default(@_); my($label,@other) = rearrange([NAME],@p); $label=$self->escapeHTML($label); - my($value) = defined($label) ? qq/ VALUE="$label"/ : ''; + my($value) = defined($label) ? qq/ value="$label"/ : ''; my($other) = @other ? " @other" : ''; - return qq//; + return $XHTML ? qq() + : qq//; } END_OF_FUNC @@ -1686,9 +1719,10 @@ sub defaults { $label=$self->escapeHTML($label); $label = $label || "Defaults"; - my($value) = qq/ VALUE="$label"/; + my($value) = qq/ value="$label"/; my($other) = @other ? " @other" : ''; - return qq//; + return $XHTML ? qq() + : qq//; } END_OF_FUNC @@ -1726,9 +1760,9 @@ sub checkbox { if (!$override && ($self->{'.fieldnames'}->{$name} || defined $self->param($name))) { - $checked = grep($_ eq $value,$self->param($name)) ? ' CHECKED' : ''; + $checked = grep($_ eq $value,$self->param($name)) ? ' checked="yes"' : ''; } else { - $checked = $checked ? ' CHECKED' : ''; + $checked = $checked ? qq/ checked="yes"/ : ''; } my($the_label) = defined $label ? $label : $name; $name = $self->escapeHTML($name); @@ -1736,7 +1770,8 @@ sub checkbox { $the_label = $self->escapeHTML($the_label); my($other) = @other ? " @other" : ''; $self->register_parameter($name); - return qq{$the_label}; + return $XHTML ? qq{$the_label} + : qq{$the_label}; } END_OF_FUNC @@ -1777,7 +1812,12 @@ sub checkbox_group { my(%checked) = $self->previous_or_default($name,$defaults,$override); - $break = $linebreak ? "
" : ''; + if ($linebreak) { + $break = $XHTML ? "
" : "
"; + } + else { + $break = ''; + } $name=$self->escapeHTML($name); # Create the elements @@ -1787,7 +1827,7 @@ sub checkbox_group { my($other) = @other ? " @other" : ''; foreach (@values) { - $checked = $checked{$_} ? ' CHECKED' : ''; + $checked = $checked{$_} ? qq/ checked="yes"/ : ''; $label = ''; unless (defined($nolabels) && $nolabels) { $label = $_; @@ -1795,7 +1835,8 @@ sub checkbox_group { $label = $self->escapeHTML($label); } $_ = $self->escapeHTML($_); - push(@elements,qq/${label}${break}/); + push(@elements,$XHTML ? qq(${label}${break}) + : qq/${label}${break}/); } $self->register_parameter($name); return wantarray ? @elements : join(' ',@elements) @@ -1807,32 +1848,28 @@ END_OF_FUNC # Escape HTML -- used internally 'escapeHTML' => <<'END_OF_FUNC', sub escapeHTML { - my ($self,$toencode) = self_or_default(@_); - return undef unless defined($toencode); - return $toencode if ref($self) && $self->{'dontescape'}; - if (uc $self->{'.charset'} eq 'ISO-8859-1') { - # fix non-compliant bug in IE and Netscape - $toencode =~ s{(.)}{ - if ($1 eq '<') { '<' } - elsif ($1 eq '>') { '>' } - elsif ($1 eq '&') { '&' } - elsif ($1 eq '"') { '"' } - elsif ($1 eq "\x8b") { '‹' } - elsif ($1 eq "\x9b") { '›' } - else { $1 } - }gsex; - } else { - $toencode =~ s/(.)/'&#'.ord($1).';'/gsex; - } - return $toencode; + my ($self,$toencode) = CGI::self_or_default(@_); + return undef unless defined($toencode); + return $toencode if ref($self) && $self->{'dontescape'}; + $toencode =~ s{&}{&}gso; + $toencode =~ s{<}{<}gso; + $toencode =~ s{>}{>}gso; + $toencode =~ s{"}{"}gso; + if (uc $self->{'.charset'} eq 'ISO-8859-1' or + uc $self->{'.charset'} eq 'WINDOWS-1252') { # bug + $toencode =~ s{\x8b}{‹}gso; + $toencode =~ s{\x9b}{›}gso; + } + return $toencode; } END_OF_FUNC # unescape HTML -- used internally 'unescapeHTML' => <<'END_OF_FUNC', sub unescapeHTML { - my $string = ref($_[0]) ? $_[1] : $_[0]; + my ($self,$string) = CGI::self_or_default(@_); return undef unless defined($string); + my $latin = $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i; # thanks to Randal Schwartz for the correct solution to this one $string=~ s[&(.*?);]{ local $_ = $1; @@ -1840,8 +1877,8 @@ sub unescapeHTML { /^quot$/i ? '"' : /^gt$/i ? ">" : /^lt$/i ? "<" : - /^#(\d+)$/ ? chr($1) : - /^#x([0-9a-f]+)$/i ? chr(hex($1)) : + /^#(\d+)$/ && $latin ? chr($1) : + /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) : $_ }gex; return $string; @@ -1852,6 +1889,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($result); if (defined($columns)) { @@ -1862,23 +1901,23 @@ sub _tableize { } # rearrange into a pretty table - $result = ""; + $result = "
"; my($row,$column); unshift(@$colheaders,'') if @$colheaders && @$rowheaders; - $result .= "" if @{$colheaders}; + $result .= "" if @{$colheaders}; foreach (@{$colheaders}) { - $result .= ""; + $result .= ""; } for ($row=0;$row<$rows;$row++) { - $result .= ""; - $result .= "" if @$rowheaders; + $result .= ""; + $result .= "" if @$rowheaders; for ($column=0;$column<$columns;$column++) { - $result .= "" + $result .= "" if defined($elements[$column*$rows + $row]); } - $result .= ""; + $result .= ""; } - $result .= "
$_$_
$rowheaders->[$row]
$rowheaders->[$row]" . $elements[$column*$rows + $row] . "" . $elements[$column*$rows + $row] . "
"; + $result .= ""; return $result; } END_OF_FUNC @@ -1927,8 +1966,14 @@ sub radio_group { my($other) = @other ? " @other" : ''; foreach (@values) { - my($checkit) = $checked eq $_ ? ' CHECKED' : ''; - my($break) = $linebreak ? '
' : ''; + my($checkit) = $checked eq $_ ? qq/ checked="yes"/ : ''; + my($break); + if ($linebreak) { + $break = $XHTML ? "
" : "
"; + } + else { + $break = ''; + } my($label)=''; unless (defined($nolabels) && $nolabels) { $label = $_; @@ -1936,7 +1981,8 @@ sub radio_group { $label = $self->escapeHTML($label); } $_=$self->escapeHTML($_); - push(@elements,qq/${label}${break}/); + push(@elements,$XHTML ? qq(${label}${break}) + : qq/${label}${break}/); } $self->register_parameter($name); return wantarray ? @elements : join(' ',@elements) @@ -1979,17 +2025,17 @@ sub popup_menu { my(@values); @values = $self->_set_values_and_labels($values,\$labels,$name); - $result = qq/\n/; foreach (@values) { - my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : ''; + my($selectit) = defined($selected) ? ($selected eq $_ ? qq/selected="yes"/ : '' ) : ''; my($label) = $_; $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); my($value) = $self->escapeHTML($_); $label=$self->escapeHTML($label); - $result .= "\n"; } - $result .= "\n"; + $result .= "\n"; return $result; } END_OF_FUNC @@ -2028,21 +2074,21 @@ sub scrolling_list { $size = $size || scalar(@values); my(%selected) = $self->previous_or_default($name,$defaults,$override); - my($is_multiple) = $multiple ? ' MULTIPLE' : ''; - my($has_size) = $size ? " SIZE=$size" : ''; + my($is_multiple) = $multiple ? qq/ multiple="yes"/ : ''; + my($has_size) = $size ? qq/ size="$size"/: ''; my($other) = @other ? " @other" : ''; $name=$self->escapeHTML($name); - $result = qq/\n/; foreach (@values) { - my($selectit) = $selected{$_} ? 'SELECTED' : ''; + my($selectit) = $selected{$_} ? qq/selected="yes"/ : ''; my($label) = $_; $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); $label=$self->escapeHTML($label); my($value)=$self->escapeHTML($_); - $result .= "\n"; + $result .= "\n"; } - $result .= "\n"; + $result .= "\n"; $self->register_parameter($name); return $result; } @@ -2085,7 +2131,8 @@ sub hidden { $name=$self->escapeHTML($name); foreach (@value) { $_ = defined($_) ? $self->escapeHTML($_) : ''; - push(@result,qq//); + push(@result,$XHTMl ? qq() + : qq//); } return wantarray ? @result : join('',@result); } @@ -2107,10 +2154,11 @@ sub image_button { my($name,$src,$alignment,@other) = rearrange([NAME,SRC,ALIGN],@p); - my($align) = $alignment ? " ALIGN=\U$alignment" : ''; + my($align) = $alignment ? " align=\U$alignment" : ''; my($other) = @other ? " @other" : ''; $name=$self->escapeHTML($name); - return qq//; + return $XHTML ? qq() + : qq//; } END_OF_FUNC @@ -2239,7 +2287,7 @@ sub cookie { push(@param,'-expires'=>$expires) if $expires; push(@param,'-secure'=>$secure) if $secure; - return CGI::Cookie->new(@param); + return new CGI::Cookie(@param); } END_OF_FUNC @@ -2762,7 +2810,7 @@ sub read_multipart { my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/; # Bug: Netscape doesn't escape quotation marks in file names!!! - my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/; + my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\"]*)"?/; # add this parameter to our list $self->add_parameter($param); @@ -2920,12 +2968,12 @@ END_OF_FUNC sub new { my($pack,$name,$file,$delete) = @_; require Fcntl unless defined &Fcntl::O_RDWR; - my $fv = ('Fh::' . ++$FH . quotemeta($name)); - warn unless *{$fv}; - my $ref = \*{$fv}; + my $fv = ++$FH . quotemeta($name); + warn unless *{"Fh::$fv"}; + my $ref = \*{"Fh::$fv"}; sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return; unlink($file) if $delete; - CORE::delete $Fh::{$FH}; + CORE::delete $Fh::{$fv}; return bless $ref,$pack; } END_OF_FUNC @@ -3678,13 +3726,13 @@ the keys are the names of the CGI parameters, and the values are the parameters' values. The Vars() method does this. Called in a scalar context, it returns the parameter list as a tied hash reference. Changing a key changes the value of the parameter in the underlying -CGI parameter list. Called in a list context, it returns the +CGI parameter list. Called in an array context, it returns the parameter list as an ordinary hash. This allows you to read the contents of the parameter list, but not to change it. When using this, the thing you must watch out for are multivalued CGI parameters. Because a hash cannot distinguish between scalar and -list context, multivalued parameters will be returned as a packed +array context, multivalued parameters will be returned as a packed string, separated by the "\0" (null) character. You must split this packed string in order to get at the individual values. This is the convention introduced long ago by Steve Brenner in his cgi-lib.pl @@ -3942,6 +3990,13 @@ 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. +=item -no_xhtml + +By default, CGI.pm versions 2.69 and higher emit XHTML +(http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this +feature. Thanks to Michalis Kabrianis for this +feature. + =item -nph This makes CGI.pm produce a header appropriate for an NPH (no @@ -4114,6 +4169,7 @@ pages. -expires=>'+3d', -cookie=>$cookie, -charset=>'utf-7', + -attachment=>'foo.gif', -Cost=>'$2.00'); header() returns the Content-type: header. You can provide your own @@ -4162,6 +4218,12 @@ The B<-charset> parameter can be used to control the character set sent to the browser. If not provided, defaults to ISO-8859-1. As a side effect, this sets the charset() method as well. +The B<-attachment> parameter can be used to turn the page into an +attachment. Instead of displaying the page, some browsers will prompt +the user to save it to disk. The value of the argument is the +suggested name for the saved file. In order for this to work, you may +have to set the B<-type> to "application/octet-stream". + =head2 GENERATING A REDIRECTION HEADER print $query->redirect('http://somewhere.else/in/movie/land'); @@ -4172,9 +4234,7 @@ time of day or the identity of the user. 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. As of version 2.0, we produce both the unofficial Location: -header and the official URI: header. This should satisfy most servers -and browsers. +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. @@ -4210,10 +4270,11 @@ page's appearance and behavior. This method returns a canned HTML header and the opening tag. All parameters are optional. In the named parameter form, recognized -parameters are -title, -author, -base, -xbase and -target (see below -for the explanation). Any additional parameters you provide, such as -the Netscape unofficial BGCOLOR attribute, are added to the -tag. Additional parameters must be proceeded by a hyphen. +parameters are -title, -author, -base, -xbase, -dtd, -lang and -target +(see below for the explanation). Any additional parameters you +provide, such as the Netscape unofficial BGCOLOR attribute, are added +to the tag. Additional parameters must be proceeded by a +hyphen. The argument B<-xbase> allows you to provide an HREF for the tag different from the current location, as in @@ -4239,22 +4300,25 @@ into a series of header tags that look something like this: -There is no direct support for the HTTP-EQUIV type of tag. -This is because you can modify the HTTP header directly with the -B method. For example, if you want to send the Refresh: -header, do it in the header() method: +To create an HTTP-EQUIV type of tag, use B<-head>, described +below. - print $q->header(-Refresh=>'10; URL=http://www.capricorn.com'); +The B<-style> argument is used to incorporate cascading stylesheets +into your code. See the section on CASCADING STYLESHEETS for more +information. -The B<-style> tag is used to incorporate cascading stylesheets 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: + + print $q->header(-lang=>'fr-CA'); 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: print start_html(-head=>Link({-rel=>'next', - -href=>'http://www.capricorn.com/s2.html'})); + -href=>'http://www.capricorn.com/s2.html'})); To incorporate multiple HTML elements into the section, just pass an array reference: @@ -4267,6 +4331,12 @@ array reference: ] ); +And here's how to create an HTTP-EQUIV tag: + + print header(-head=>meta({-http_equiv => 'Content-Type', + -content => 'text/html'})) + + JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>, B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used to add Netscape JavaScript calls to your pages. B<-script> should @@ -4579,7 +4649,7 @@ element of the list. For example, here's one way to make an ordered list: print ul( - li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy']); + li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy']) ); This example will result in HTML output that looks like this: @@ -4793,7 +4863,7 @@ This is the older type of encoding used by all browsers prior to Netscape 2.0. It is compatible with many CGI scripts and is suitable for short fields containing text data. For your convenience, CGI.pm stores the name of this encoding -type in B<$CGI::URL_ENCODED>. +type in B<&CGI::URL_ENCODED>. =item B @@ -4947,7 +5017,7 @@ recognized. See textfield(). filefield() will return a file upload field for Netscape 2.0 browsers. In order to take full advantage of this I for the form. You can do this either -by calling B with an encoding type of B<$CGI::MULTIPART>, +by calling B with an encoding type of B<&CGI::MULTIPART>, or by calling the new method B instead of vanilla B. @@ -5854,6 +5924,9 @@ http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information. ); print end_html; +Pass an array reference to B<-style> in order to incorporate multiple +stylesheets into your document. + =head1 DEBUGGING If you are running the script from the command line or in the perl @@ -5962,9 +6035,8 @@ like $query->user_agent(netscape); =item B Returns additional path information from the script URL. -E.G. fetching /cgi-bin/your_script/additional/stuff will -result in $query->path_info() returning -"additional/stuff". +E.G. fetching /cgi-bin/your_script/additional/stuff will result in +$query->path_info() returning "/additional/stuff". NOTE: The Microsoft Internet Information Server is broken with respect to additional path information. If diff --git a/lib/CGI/Carp.pm b/lib/CGI/Carp.pm index 0a5c121..5aea198 100644 --- a/lib/CGI/Carp.pm +++ b/lib/CGI/Carp.pm @@ -142,6 +142,33 @@ of the error message that caused the script to die. Example: In order to correctly intercept compile-time errors, you should call set_message() from within a BEGIN{} block. +=head1 MAKING WARNINGS APPEAR AS HTML COMMENTS + +It is now also possible to make non-fatal errors appear as HTML +comments embedded in the output of your program. To enable this +feature, export the new "warningsToBrowser" subroutine. Since sending +warnings to the browser before the HTTP headers have been sent would +cause an error, any warnings are stored in an internal buffer until +you call the warningsToBrowser() subroutine with a true argument: + + use CGI::Carp qw(fatalsToBrowser warningsToBrowser); + use CGI qw(:standard); + print header(); + warningsToBrowser(1); + +You may also give a false argument to warningsToBrowser() to prevent +warnings from being sent to the browser while you are printing some +content where HTML comments are not allowed: + + warningsToBrowser(0); # disable warnings + print "\n"; + warningsToBrowser(1); # re-enable warnings + +Note: In this respect warningsToBrowser() differs fundamentally from +fatalsToBrowser(), which you should never call yourself! + =head1 CHANGE LOG 1.05 carpout() added and minor corrections by Marc Hedlund @@ -166,7 +193,11 @@ set_message() from within a BEGIN{} block. 1.12 Changed die() on line 217 to CORE::die to avoid B<-w> warning. 1.13 Added cluck() to make the module orthogonal with Carp. - More mod_perl related fixes. + More mod_perl related fixes. + +1.20 Patch from Ilmari Karonen (perl@itz.pp.sci.fi): Added + warningsToBrowser(). Replaced tags with 
 in
+     fatalsToBrowser() output.
 
 =head1 AUTHORS
 
@@ -190,18 +221,11 @@ use Carp;
 
 @ISA = qw(Exporter);
 @EXPORT = qw(confess croak carp);
-@EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message cluck);
-
-BEGIN {
-  $] >= 5.005
-    ? eval q#sub ineval { defined $^S ? $^S : _longmess() =~ /eval [\{\']/m }#
-    : eval q#sub ineval { _longmess() =~ /eval [\{\']/m }#;
-  $@ and die;
-}
+@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message cluck);
 
 $main::SIG{__WARN__}=\&CGI::Carp::warn;
 $main::SIG{__DIE__}=\&CGI::Carp::die;
-$CGI::Carp::VERSION = '1.16';
+$CGI::Carp::VERSION = '1.20';
 $CGI::Carp::CUSTOM_MSG = undef;
 
 # fancy import routine detects and handles 'errorWrap' specially.
@@ -210,6 +234,7 @@ sub import {
     my(%routines);
     grep($routines{$_}++,@_,@EXPORT);
     $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'};
+    $WARN++ if $routines{'warningsToBrowser'};
     my($oldlevel) = $Exporter::ExportLevel;
     $Exporter::ExportLevel = 1;
     Exporter::import($pkg,keys %routines);
@@ -223,7 +248,7 @@ sub realdie { CORE::die(@_); }
 sub id {
     my $level = shift;
     my($pack,$file,$line,$sub) = caller($level);
-    my($id) = $file=~m|([^/]+)\z|;
+    my($id) = $file=~m|([^/]+)$|;
     return ($file,$line,$id);
 }
 
@@ -235,7 +260,7 @@ sub stamp {
 	$id = $file;
 	($pack,$file) = caller($frame++);
     } until !$file;
-    ($id) = $id=~m|([^/]+)\z|;
+    ($id) = $id=~m|([^/]+)$|;
     return "[$time] $id: ";
 }
 
@@ -243,23 +268,40 @@ sub warn {
     my $message = shift;
     my($file,$line,$id) = id(1);
     $message .= " at $file line $line.\n" unless $message=~/\n$/;
+    _warn($message) if $WARN;
     my $stamp = stamp;
     $message=~s/^/$stamp/gm;
     realwarn $message;
 }
 
+sub _warn {
+    my $msg = shift;
+    if ($EMIT_WARNINGS) {
+	# We need to mangle the message a bit to make it a valid HTML
+	# comment.  This is done by substituting similar-looking ISO
+	# 8859-1 characters for <, > and -.  This is a hack.
+	$msg =~ tr/<>-/\253\273\255/;
+	chomp $msg;
+	print STDOUT "\n";
+    } else {
+	push @WARNINGS, $msg;
+    }
+}
+
+sub ineval { _longmess() =~ /eval [\{\']/m }
+
 # The mod_perl package Apache::Registry loads CGI programs by calling
 # eval.  These evals don't count when looking at the stack backtrace.
 sub _longmess {
     my $message = Carp::longmess();
     my $mod_perl = exists $ENV{MOD_PERL};
     $message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl;
-    return( $message );    
+    return $message;    
 }
 
 sub die {
   realdie @_ if ineval;
-  my $message = shift;
+  my ($message) = @_;
   my $time = scalar(localtime);
   my($file,$line,$id) = id(1);
   $message .= " at $file line $line." unless $message=~/\n$/;
@@ -299,6 +341,11 @@ sub carpout {
 	( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
 }
 
+sub warningsToBrowser {
+    $EMIT_WARNINGS = @_ ? shift : 1;
+    _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS;
+}
+
 # headers
 sub fatalsToBrowser {
     my($msg) = @_;
@@ -318,6 +365,8 @@ END
     print STDOUT "Content-type: text/html\n\n" 
 	unless $mod_perl;
 
+    warningsToBrowser(1);    # emit warnings before dying
+
     if ($CUSTOM_MSG) {
 	if (ref($CUSTOM_MSG) eq 'CODE') {
 	    &$CUSTOM_MSG($msg); # nicer to perl 5.003 users
@@ -329,7 +378,7 @@ END
     
     my $mess = <Software error:
-$msg
+
$msg

 

 $outer_message
 END
diff --git a/lib/CGI/Cookie.pm b/lib/CGI/Cookie.pm
index 575ae79..8c5ac1e 100644
--- a/lib/CGI/Cookie.pm
+++ b/lib/CGI/Cookie.pm
@@ -40,17 +40,18 @@ sub raw_fetch {
     my %results;
     my($key,$value);
 
-    my(@pairs) = split("; ",$raw_cookie);
+    my(@pairs) = split("; ?",$raw_cookie);
     foreach (@pairs) {
-	if (/^([^=]+)=(.*)/) {
-	    $key = $1;
-	    $value = $2;
-	}
-	else {
-	    $key = $_;
-	    $value = '';
-	}
-	$results{$key} = $value;
+      s/\s*(.*?)\s*/$1/;
+      if (/^([^=]+)=(.*)/) {
+	$key = $1;
+	$value = $2;
+      }
+      else {
+	$key = $_;
+	$value = '';
+      }
+      $results{$key} = $value;
     }
     return \%results unless wantarray;
     return %results;
@@ -60,17 +61,18 @@ sub parse {
     my ($self,$raw_cookie) = @_;
     my %results;
 
-    my(@pairs) = split("; ",$raw_cookie);
+    my(@pairs) = split("; ?",$raw_cookie);
     foreach (@pairs) {
-	my($key,$value) = split("=");
-	my(@values) = map unescape($_),split('&',$value);
-	$key = unescape($key);
-	# Some foreign cookies are not in name=value format, so ignore
-	# them.
-	next if !defined($value);
-	# A bug in Netscape can cause several cookies with same name to
-	# appear.  The FIRST one in HTTP_COOKIE is the most recent version.
-	$results{$key} ||= $self->new(-name=>$key,-value=>\@values);
+      s/\s*(.*?)\s*/$1/;
+      my($key,$value) = split("=");
+      my(@values) = map unescape($_),split('&',$value);
+      $key = unescape($key);
+      # Some foreign cookies are not in name=value format, so ignore
+      # them.
+      next if !defined($value);
+      # A bug in Netscape can cause several cookies with same name to
+      # appear.  The FIRST one in HTTP_COOKIE is the most recent version.
+      $results{$key} ||= $self->new(-name=>$key,-value=>\@values);
     }
     return \%results unless wantarray;
     return %results;
@@ -382,7 +384,7 @@ Get or set the cookie's value.  Example:
 	$value = $c->value;
 	@new_value = $c->value(['a','b','c','d']);
 
-B is context sensitive.  In a list context it will return
+B is context sensitive.  In an array context it will return
 the current value of the cookie as an array.  In a scalar context it
 will return the B value of a multivalued cookie.
 
diff --git a/lib/CGI/Pretty.pm b/lib/CGI/Pretty.pm
index 20173f9..d348807 100644
--- a/lib/CGI/Pretty.pm
+++ b/lib/CGI/Pretty.pm
@@ -72,7 +72,7 @@ sub _make_tag_func {
 		\$attr = " \@attr" if \@attr;
 	    }
 
-	    my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U\E");
+	    my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L\E");
 	    return \$tag unless \@_;
 
 	    my \@result;
@@ -128,7 +128,7 @@ sub initialize_globals {
     $CGI::Pretty::LINEBREAK = "\n";
 
     # These tags are not prettify'd.
-    @CGI::Pretty::AS_IS = qw( A PRE CODE SCRIPT TEXTAREA );
+    @CGI::Pretty::AS_IS = qw( a pre code script textarea );
 
     1;
 }
diff --git a/lib/CGI/Push.pm b/lib/CGI/Push.pm
index 6b8e012..83002f2 100644
--- a/lib/CGI/Push.pm
+++ b/lib/CGI/Push.pm
@@ -16,7 +16,7 @@ package CGI::Push;
 # The most recent version and complete docs are available at:
 #   http://stein.cshl.org/WWW/software/CGI/
 
-$CGI::Push::VERSION='1.02';
+$CGI::Push::VERSION='1.03';
 use CGI;
 use CGI::Util 'rearrange';
 @ISA = ('CGI');
@@ -60,7 +60,7 @@ sub do_push {
     while (1) {
 	last unless (@contents = &$callback($self,++$COUNTER)) && defined($contents[0]);
 	print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" 
-	    unless $type eq 'dynamic';
+	    unless $type =~ /^dynamic|heterogeneous$/i;
 	print @contents,"$CGI::CRLF";
 	print "${boundary}$CGI::CRLF";
 	do_sleep($self->push_delay()) if $self->push_delay();
diff --git a/lib/CGI/Util.pm b/lib/CGI/Util.pm
index cb6dd8a..ac7376d 100644
--- a/lib/CGI/Util.pm
+++ b/lib/CGI/Util.pm
@@ -1,13 +1,5 @@
 package CGI::Util;
 
-=pod
-
-=head1 NAME
-
-CGI::Util - various utilities
-
-=cut
-
 use strict;
 use vars '$VERSION','@EXPORT_OK','@ISA','$EBCDIC','@A2E';
 require Exporter;
@@ -56,14 +48,14 @@ sub rearrange {
     my ($i,%pos);
     $i = 0;
     foreach (@$order) {
-	foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; }
+	foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
 	$i++;
     }
 
     my (@result,%leftover);
     $#result = $#$order;  # preextend
     while (@param) {
-	my $key = uc(shift(@param));
+	my $key = lc(shift(@param));
 	$key =~ s/^\-//;
 	if (exists $pos{$key}) {
 	    $result[$pos{$key}] = shift(@param);
@@ -72,7 +64,7 @@ sub rearrange {
 	}
     }
 
-    push (@result,make_attributes(\%leftover)) if %leftover;
+    push (@result,make_attributes(\%leftover,1)) if %leftover;
     @result;
 }
 
@@ -84,7 +76,7 @@ sub make_attributes {
     foreach (keys %{$attr}) {
 	my($key) = $_;
 	$key=~s/^\-//;     # get rid of initial - if present
-	$key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes
+	$key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
 	my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
 	push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
     }
@@ -92,16 +84,14 @@ sub make_attributes {
 }
 
 sub simple_escape {
-  return unless defined (my $toencode = shift);
-  $toencode =~ s{(.)}{
-              if    ($1 eq '<')                            { '<'    }
-              elsif ($1 eq '>')                            { '>'    }
-              elsif ($1 eq '&')                            { '&'   }
-              elsif ($1 eq '"')                            { '"'  }
-              elsif ($1 eq "\x8b")                         { '‹'  }
-              elsif ($1 eq "\x9b")                         { '›'  }
-              else                                         { $1        }
-       }gsex;
+  return unless defined(my $toencode = shift);
+  $toencode =~ s{&}{&}gso;
+  $toencode =~ s{<}{<}gso;
+  $toencode =~ s{>}{>}gso;
+  $toencode =~ s{\"}{"}gso;
+# Doesn't work.  Can't work.  forget it.
+#  $toencode =~ s{\x8b}{‹}gso;
+#  $toencode =~ s{\x9b}{›}gso;
   $toencode;
 }
 
diff --git a/t/lib/cgi-form.t b/t/lib/cgi-form.t
index e3cba5f..1be3894 100755
--- a/t/lib/cgi-form.t
+++ b/t/lib/cgi-form.t
@@ -1,12 +1,8 @@
-#!./perl
+#!/usr/local/bin/perl -w
 
 # Test ability to retrieve HTTP request info
 ######################### We start with some black magic to print on failure.
-
-BEGIN {
-    chdir 't' if -d 't';
-    unshift @INC, '../lib' if -d '../lib';
-}
+use lib '../blib/lib','../blib/arch';
 
 BEGIN {$| = 1; print "1..17\n"; }
 END {print "not ok 1\n" unless $loaded;}
@@ -34,48 +30,48 @@ $ENV{SERVER_PORT} = 8080;
 $ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
 
 test(2,start_form(-action=>'foobar',-method=>GET) eq 
-     qq(
\n),
+     qq(\n),
      "start_form()");
 
-test(3,submit() eq qq(),"submit()");
-test(4,submit(-name=>'foo',-value=>'bar') eq qq(),"submit(-name,-value)");
-test(5,submit({-name=>'foo',-value=>'bar'}) eq qq(),"submit({-name,-value})");
-test(6,textfield(-name=>'weather') eq qq(),"textfield({-name})");
-test(7,textfield(-name=>'weather',-value=>'nice') eq qq(),"textfield({-name,-value})");
-test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(),
+test(3,submit() eq qq(),"submit()");
+test(4,submit(-name=>'foo',-value=>'bar') eq qq(),"submit(-name,-value)");
+test(5,submit({-name=>'foo',-value=>'bar'}) eq qq(),"submit({-name,-value})");
+test(6,textfield(-name=>'weather') eq qq(),"textfield({-name})");
+test(7,textfield(-name=>'weather',-value=>'nice') eq qq(),"textfield({-name,-value})");
+test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(),
      "textfield({-name,-value,-override})");
-test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(weather),
+test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(weather),
      "checkbox()");
 test(10,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast') eq 
-     qq(forecast),
+     qq(forecast),
      "checkbox()");
 test(11,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast',-checked=>1,-override=>1) eq 
-     qq(forecast),
+     qq(forecast),
      "checkbox()");
 test(12,checkbox(-name=>'weather',-value=>'dull',-label=>'forecast') eq 
-     qq(forecast),
+     qq(forecast),
      "checkbox()");
 
 test(13,radio_group(-name=>'game') eq 
-     qq(chess checkers),
+     qq(chess checkers),
      'radio_group()');
 test(14,radio_group(-name=>'game',-labels=>{'chess'=>'ping pong'}) eq 
-     qq(ping pong checkers),
+     qq(ping pong checkers),
      'radio_group()');
 
 test(15, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/]) eq 
-     qq(checkers chess cribbage),
+     qq(checkers chess cribbage),
      'checkbox_group()');
 
-test(16, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/],-Defaults=>['cribbage'],-override=>1) eq 
-     qq(checkers chess cribbage),
+test(16, checkbox_group(-name=>'game',-values=>[qw/checkers chess cribbage/],-defaults=>['cribbage'],-override=>1) eq 
+     qq(checkers chess cribbage),
      'checkbox_group()');
 
-test(17, popup_menu(-name=>'game',-Values=>[qw/checkers chess cribbage/],-Default=>'cribbage',-override=>1) eq <
-