X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCGI.pm;h=ffb8ce91dcc12e84884269242c37d5dc188975ce;hb=2db40e90730d5fd105e3f74faa4d22f352568b99;hp=94c4e65990b353d180d9b77c6b73e02bdcc55dca;hpb=29ddc2a4443cff956621f7b060b68c8ff93220d4;p=p5sagit%2Fp5-mst-13.2.git
diff --git a/lib/CGI.pm b/lib/CGI.pm
index 94c4e65..ffb8ce9 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.208 2006/04/23 14:25:14 lstein Exp $';
+$CGI::VERSION='3.22';
# 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:
@@ -177,20 +181,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 +235,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 +330,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 +376,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 +392,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 +434,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 +443,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 {
@@ -496,18 +524,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.
@@ -820,14 +840,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 +870,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 +910,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 +1157,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 +1427,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 +1445,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 +1515,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 +1562,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);
@@ -1767,10 +1798,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);
}
$action = qq(action="$action");
my($other) = @other ? " @other" : '';
@@ -1799,10 +1827,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 +1842,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 +1875,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 +1957,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 +1991,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 +2015,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 +2048,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 +2076,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 +2123,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
@@ -2278,7 +2308,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') {
@@ -2289,7 +2319,7 @@ sub _box_group {
}
%tabs = map {$_=>$self->element_tab} @values unless %tabs;
- my $other = @other ? " @other" : '';
+ my $other = @other ? "@other " : '';
my $radio_checked;
foreach (@values) {
my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++)
@@ -2308,12 +2338,12 @@ sub _box_group {
$label = $self->escapeHTML($label,1);
}
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}/);
}
@@ -2360,7 +2390,7 @@ sub popup_menu {
my(@values);
@values = $self->_set_values_and_labels($values,\$labels,$name);
$tabindex = $self->element_tab($tabindex);
- $result = qq/