X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCGI.pm;h=0d5ef00548c4b90f3abdf390bf8f1bcd26796d65;hb=5108dc18037af131227ae095719eaab3a8fd54cb;hp=94c4e65990b353d180d9b77c6b73e02bdcc55dca;hpb=29ddc2a4443cff956621f7b060b68c8ff93220d4;p=p5sagit%2Fp5-mst-13.2.git
diff --git a/lib/CGI.pm b/lib/CGI.pm
index 94c4e65..0d5ef00 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.177 2005/03/09 21:04:48 lstein Exp $';
-$CGI::VERSION=3.06;
+$CGI::revision = '$Id: CGI.pm,v 1.234 2007/04/16 16:58:46 lstein Exp $';
+$CGI::VERSION='3.29';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
@@ -40,6 +40,7 @@ use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
$MOD_PERL = 0; # no mod_perl by default
@SAVED_SYMBOLS = ();
+
# >>>>> Here are some globals that you might want to adjust <<<<<<
sub initialize_globals {
# Set this to 1 to enable copious autoloader debugging messages
@@ -77,6 +78,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:
@@ -115,6 +119,7 @@ sub initialize_globals {
undef %EXPORT;
undef $QUERY_CHARSET;
undef %QUERY_FIELDNAMES;
+ undef %QUERY_TMPFILES;
# prevent complaints by mod_perl
1;
@@ -177,20 +182,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;
}
}
@@ -233,7 +236,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
@@ -327,26 +331,33 @@ sub new {
my $self = {};
bless $self,ref $class || $class || $DefaultClass;
+
+ # always use a tempfile
+ $self->{'use_tempfile'} = 1;
+
if (ref($initializer[0])
&& (UNIVERSAL::isa($initializer[0],'Apache')
||
- UNIVERSAL::isa($initializer[0],'Apache::RequestRec')
+ UNIVERSAL::isa($initializer[0],'Apache2::RequestRec')
)) {
$self->r(shift @initializer);
}
if (ref($initializer[0])
&& (UNIVERSAL::isa($initializer[0],'CODE'))) {
$self->upload_hook(shift @initializer, shift @initializer);
+ $self->{'use_tempfile'} = shift @initializer if (@initializer > 0);
}
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);
}
@@ -366,9 +377,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};
+ }
}
}
@@ -380,9 +393,16 @@ 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,$use_tempfile) = @_;
$self->{'.upload_hook'} = $hook;
$self->{'.upload_data'} = $data;
+ $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile;
}
#### Method: param
@@ -415,7 +435,7 @@ sub param {
}
}
# If values is provided, then we set it.
- if (@values) {
+ if (@values or defined $value) {
$self->add_parameter($name);
$self->{$name}=[@values];
}
@@ -424,7 +444,16 @@ sub param {
}
return unless defined($name) && $self->{$name};
- return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
+
+ my $charset = $self->charset || '';
+ my $utf8 = $charset eq 'utf-8';
+ if ($utf8) {
+ eval "require Encode; 1;" if $utf8 && !Encode->can('decode'); # bring in these functions
+ return wantarray ? map {Encode::decode(utf8=>$_) } @{$self->{$name}}
+ : Encode::decode(utf8=>$self->{$name}->[0]);
+ } else {
+ return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
+ }
}
sub self_or_default {
@@ -466,6 +495,8 @@ sub init {
my $self = shift;
my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
+ my $is_xforms;
+
my $initializer = shift; # for backward compatibility
local($/) = "\n";
@@ -476,12 +507,20 @@ sub init {
# ourselves from the original query (which may be gone
# if it was read from STDIN originally.)
if (defined(@QUERY_PARAM) && !defined($initializer)) {
- foreach (@QUERY_PARAM) {
- $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
- }
- $self->charset($QUERY_CHARSET);
- $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
- return;
+ for my $name (@QUERY_PARAM) {
+ my $val = $QUERY_PARAM{$name}; # always an arrayref;
+ $self->param('-name'=>$name,'-value'=> $val);
+ if (defined $val and ref $val eq 'ARRAY') {
+ for my $fh (grep {defined(fileno($_))} @$val) {
+ seek($fh,0,0); # reset the filehandle.
+ }
+
+ }
+ }
+ $self->charset($QUERY_CHARSET);
+ $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
+ $self->{'.tmpfiles'} = {%QUERY_TMPFILES};
+ return;
}
$meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
@@ -496,18 +535,10 @@ sub init {
# avoid unreasonably large postings
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;
- }
- }
+ #discard the post, unread
+ $self->cgi_error("413 Request entity too large");
+ last METHOD;
+ }
# Process multipart postings, but only if the initializer is
# not defined.
@@ -521,9 +552,50 @@ sub init {
last METHOD;
}
+ # Process XForms postings. We know that we have XForms in the
+ # following cases:
+ # method eq 'POST' && content-type eq 'application/xml'
+ # method eq 'POST' && content-type =~ /multipart\/related.+start=/
+ # There are more cases, actually, but for now, we don't support other
+ # methods for XForm posts.
+ # In a XForm POST, the QUERY_STRING is parsed normally.
+ # If the content-type is 'application/xml', we just set the param
+ # XForms:Model (referring to the xml syntax) param containing the
+ # unparsed XML data.
+ # In the case of multipart/related we set XForms:Model as above, but
+ # the other parts are available as uploads with the Content-ID as the
+ # the key.
+ # See the URL below for XForms specs on this issue.
+ # http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options
+ if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) {
+ if ($ENV{'CONTENT_TYPE'} eq 'application/xml') {
+ my($param) = 'XForms:Model';
+ my($value) = '';
+ $self->add_parameter($param);
+ $self->read_from_client(\$value,$content_length,0)
+ if $content_length > 0;
+ push (@{$self->{$param}},$value);
+ $is_xforms = 1;
+ } elsif ($ENV{'CONTENT_TYPE'} =~ /multipart\/related.+boundary=\"?([^\";,]+)\"?.+start=\"?\([^\"\>]+)\>?\"?/) {
+ my($boundary,$start) = ($1,$2);
+ my($param) = 'XForms:Model';
+ $self->add_parameter($param);
+ my($value) = $self->read_multipart_related($start,$boundary,$content_length,0);
+ push (@{$self->{$param}},$value);
+ if ($MOD_PERL) {
+ $query_string = $self->r->args;
+ } else {
+ $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
+ $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
+ }
+ $is_xforms = 1;
+ }
+ }
+
+
# If initializer is defined, then read parameters
# from it.
- if (defined($initializer)) {
+ if (!$is_xforms && defined($initializer)) {
if (UNIVERSAL::isa($initializer,'CGI')) {
$query_string = $initializer->query_string;
last METHOD;
@@ -534,21 +606,6 @@ sub init {
}
last METHOD;
}
-
- if (defined($fh) && ($fh ne '')) {
- while (<$fh>) {
- chomp;
- last if /^=/;
- push(@lines,$_);
- }
- # massage back into standard format
- if ("@lines" =~ /=/) {
- $query_string=join("&",@lines);
- } else {
- $query_string=join("+",@lines);
- }
- last METHOD;
- }
if (defined($fh) && ($fh ne '')) {
while (<$fh>) {
@@ -574,7 +631,7 @@ sub init {
# If method is GET or HEAD, fetch the query from
# the environment.
- if ($meth=~/^(GET|HEAD)$/) {
+ if ($is_xforms || $meth=~/^(GET|HEAD)$/) {
if ($MOD_PERL) {
$query_string = $self->r->args;
} else {
@@ -610,7 +667,7 @@ sub init {
}
# YL: Begin Change for XML handler 10/19/2001
- if ($meth eq 'POST'
+ if (!$is_xforms && $meth eq 'POST'
&& defined($ENV{'CONTENT_TYPE'})
&& $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
&& $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
@@ -699,6 +756,7 @@ sub save_request {
}
$QUERY_CHARSET = $self->charset;
%QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
+ %QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} };
}
sub parse_params {
@@ -820,14 +878,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(); }
@@ -850,6 +908,7 @@ sub _setup_symbols {
$XHTML=0, next if /^[:-]no_?xhtml$/;
$USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
$PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
+ $TABINDEX++, next if /^[:-]tabindex$/;
$CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
$EXPORT{$_}++, next if /^[:-]any$/;
$compile++, next if /^[:-]compile$/;
@@ -889,8 +948,11 @@ sub element_id {
sub element_tab {
my ($self,$new_value) = self_or_default(@_);
+ $self->{'.etab'} ||= 1;
$self->{'.etab'} = $new_value if defined $new_value;
- $self->{'.etab'}++;
+ my $tab = $self->{'.etab'}++;
+ return '' unless $TABINDEX or defined $new_value;
+ return qq(tabindex="$tab" );
}
###############################################################################
@@ -1133,7 +1195,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) {
@@ -1403,11 +1465,15 @@ sub header {
'ATTACHMENT','P3P'],@p);
$nph ||= $NPH;
+
+ $type ||= 'text/html' unless defined($type);
+
if (defined $charset) {
$self->charset($charset);
} else {
- $charset = $self->charset;
+ $charset = $self->charset if $type =~ /^text\//;
}
+ $charset ||= '';
# rearrange() was designed for the HTML portion, so we
# need to fix it up a little.
@@ -1417,8 +1483,11 @@ sub header {
($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
}
- $type ||= 'text/html' unless defined($type);
- $type .= "; charset=$charset" if $type ne '' and $type =~ m!^text/! and $type !~ /\bcharset\b/ and $charset ne '';
+ $type .= "; charset=$charset"
+ if $type ne ''
+ and $type !~ /\bcharset\b/
+ and defined $charset
+ and $charset ne '';
# Maybe future compatibility. Maybe not.
my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
@@ -1484,7 +1553,7 @@ sub redirect {
my($self,@p) = self_or_default(@_);
my($url,$target,$status,$cookie,$nph,@other) =
rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p);
- $status = '302 Moved' unless defined $status;
+ $status = '302 Found' unless defined $status;
$url ||= $self->self_url;
my(@o);
foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
@@ -1531,7 +1600,7 @@ sub start_html {
$self->element_id(0);
$self->element_tab(0);
- $encoding = 'iso-8859-1' unless defined $encoding;
+ $encoding = lc($self->charset) unless defined $encoding;
# Need to sort out the DTD before it's okay to call escapeHTML().
my(@result,$xml_dtd);
@@ -1621,7 +1690,10 @@ END_OF_FUNC
sub _style {
my ($self,$style) = @_;
my (@result);
+
my $type = 'text/css';
+ my $rel = 'stylesheet';
+
my $cdata_start = $XHTML ? "\n\n" : " -->\n";
@@ -1630,25 +1702,26 @@ sub _style {
for my $s (@s) {
if (ref($s)) {
- my($src,$code,$verbatim,$stype,$foo,@other) =
- rearrange([qw(SRC CODE VERBATIM TYPE FOO)],
+ my($src,$code,$verbatim,$stype,$alternate,$foo,@other) =
+ rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)],
('-foo'=>'bar',
ref($s) eq 'ARRAY' ? @$s : %$s));
- $type = $stype if $stype;
+ my $type = defined $stype ? $stype : 'text/css';
+ my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet';
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;
+ push(@result,$XHTML ? qq()
+ : qq()) if $src;
}
}
else
{ # Otherwise, push the single -src, if it exists.
- push(@result,$XHTML ? qq()
- : qq()
+ push(@result,$XHTML ? qq()
+ : qq()
) if $src;
}
if ($verbatim) {
@@ -1660,8 +1733,8 @@ sub _style {
} else {
my $src = $s;
- push(@result,$XHTML ? qq()
- : qq());
+ push(@result,$XHTML ? qq()
+ : qq());
}
}
@result;
@@ -1677,19 +1750,17 @@ sub _script {
foreach $script (@scripts) {
my($src,$code,$language);
if (ref($script)) { # script is a hash
- ($src,$code,$language, $type) =
- rearrange([SRC,CODE,LANGUAGE,TYPE],
+ ($src,$code,$type) =
+ rearrange(['SRC','CODE',['LANGUAGE','TYPE']],
'-foo'=>'bar', # a trick to allow the '-' to be omitted
ref($script) eq 'ARRAY' ? @$script : %$script);
- # User may not have specified language
- $language ||= 'JavaScript';
- unless (defined $type) {
- $type = lc $language;
- # strip '1.2' from 'javascript1.2'
- $type =~ s/^(\D+).*$/text\/$1/;
+ $type ||= 'text/javascript';
+ unless ($type =~ m!\w+/\w+!) {
+ $type =~ s/[\d.]+$//;
+ $type = "text/$type";
}
} else {
- ($src,$code,$language, $type) = ('',$script,'JavaScript', 'text/javascript');
+ ($src,$code,$type) = ('',$script, 'text/javascript');
}
my $comment = '//'; # javascript by default
@@ -1707,7 +1778,6 @@ sub _script {
}
my(@satts);
push(@satts,'src'=>$src) if $src;
- push(@satts,'language'=>$language) unless defined $type;
push(@satts,'type'=>$type);
$code = $cdata_start . $code . $cdata_end if defined $code;
push(@result,$self->script({@satts},$code || ''));
@@ -1767,10 +1837,7 @@ sub startform {
$action = $self->escapeHTML($action);
}
else {
- $action = $self->escapeHTML($self->url(-absolute=>1,-path=>1));
- if (exists $ENV{QUERY_STRING} && length($ENV{QUERY_STRING})>0) {
- $action .= "?".$self->escapeHTML($ENV{QUERY_STRING},1);
- }
+ $action = $self->escapeHTML($self->request_uri || $self->self_url);
}
$action = qq(action="$action");
my($other) = @other ? " @other" : '';
@@ -1799,10 +1866,8 @@ 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 '-') {
- my(%p) = @p;
- $p{'-enctype'}=&MULTIPART;
- return $self->startform(%p);
+ if (defined($p[0]) && substr($p[0],0,1) eq '-') {
+ return $self->startform(-enctype=>&MULTIPART,@p);
} else {
my($method,$action,@other) =
rearrange([METHOD,ACTION],@p);
@@ -1816,12 +1881,16 @@ 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
@@ -1845,7 +1914,7 @@ sub _textfield {
# and WebTV -- not sure it won't break stuff
my($value) = $current ne '' ? qq(value="$current") : '';
$tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq()
+ return $XHTML ? qq()
: qq();
}
END_OF_FUNC
@@ -1927,7 +1996,7 @@ sub textarea {
my($c) = $cols ? qq/ cols="$cols"/ : '';
my($other) = @other ? " @other" : '';
$tabindex = $self->element_tab($tabindex);
- return qq{};
+ return qq{};
}
END_OF_FUNC
@@ -1961,7 +2030,7 @@ sub button {
$script = qq/ onclick="$script"/ if $script;
my($other) = @other ? " @other" : '';
$tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq()
+ return $XHTML ? qq()
: qq();
}
END_OF_FUNC
@@ -1985,15 +2054,15 @@ sub submit {
$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);
+ $val = qq/value="$value" / if defined($value);
$tabindex = $self->element_tab($tabindex);
- my($other) = @other ? " @other" : '';
- return $XHTML ? qq()
- : qq();
+ my($other) = @other ? "@other " : '';
+ return $XHTML ? qq()
+ : qq();
}
END_OF_FUNC
@@ -2018,7 +2087,7 @@ sub reset {
$val = qq/ value="$value"/ if defined($value);
my($other) = @other ? " @other" : '';
$tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq()
+ return $XHTML ? qq()
: qq();
}
END_OF_FUNC
@@ -2046,7 +2115,7 @@ sub defaults {
my($value) = qq/ value="$label"/;
my($other) = @other ? " @other" : '';
$tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq()
+ return $XHTML ? qq()
: qq//;
}
END_OF_FUNC
@@ -2093,10 +2162,10 @@ 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 ? CGI::label(qq{$the_label})
+ return $XHTML ? CGI::label(qq{$the_label})
: qq{$the_label};
}
END_OF_FUNC
@@ -2260,15 +2329,14 @@ sub _box_group {
my($name,$values,$defaults,$linebreak,$labels,$attributes,
$rows,$columns,$rowheaders,$colheaders,
- $override,$nolabels,$tabindex,@other) =
+ $override,$nolabels,$tabindex,$disabled,@other) =
rearrange([ NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,ATTRIBUTES,
- ROWS,[COLUMNS,COLS],ROWHEADERS,COLHEADERS,
- [OVERRIDE,FORCE],NOLABELS,TABINDEX
+ ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER],
+ [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED
],@_);
- my($result,$checked);
+ my($result,$checked,@elements,@values);
- my(@elements,@values);
@values = $self->_set_values_and_labels($values,\$labels,$name);
my %checked = $self->previous_or_default($name,$defaults,$override);
@@ -2278,7 +2346,7 @@ sub _box_group {
$name=$self->escapeHTML($name);
my %tabs = ();
- if ($tabindex) {
+ if ($TABINDEX && $tabindex) {
if (!ref $tabindex) {
$self->element_tab($tabindex);
} elsif (ref $tabindex eq 'ARRAY') {
@@ -2288,10 +2356,21 @@ sub _box_group {
}
}
%tabs = map {$_=>$self->element_tab} @values unless %tabs;
-
- my $other = @other ? " @other" : '';
+ my $other = @other ? "@other " : '';
my $radio_checked;
+
+ # for disabling groups of radio/checkbox buttons
+ my %disabled;
+ foreach (@{$disabled}) {
+ $disabled{$_}=1;
+ }
+
foreach (@values) {
+ my $disable="";
+ if ($disabled{$_}) {
+ $disable="disabled='1'";
+ }
+
my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++)
: $checked{$_});
my($break);
@@ -2306,16 +2385,18 @@ sub _box_group {
$label = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
$label = $self->escapeHTML($label,1);
+ $label = "$label" if $disabled{$_};
}
my $attribs = $self->_set_attributes($_, $attributes);
- my $tab = qq( tabindex="$tabs{$_}") if exists $tabs{$_};
+ my $tab = $tabs{$_};
$_=$self->escapeHTML($_);
+
if ($XHTML) {
push @elements,
CGI::label(
- qq($label)).${break};
+ qq($label)).${break};
} else {
- push(@elements,qq/${label}${break}/);
+ push(@elements,qq/${label}${break}/);
}
}
$self->register_parameter($name);
@@ -2360,7 +2441,7 @@ sub popup_menu {
my(@values);
@values = $self->_set_values_and_labels($values,\$labels,$name);
$tabindex = $self->element_tab($tabindex);
- $result = qq/