X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCGI.pm;h=bd9c3354f7290faac2c15d0d09e6418b04fc2c08;hb=3b0db4f96671dacfd3421850abb588b84e2ce6da;hp=292e26234f57e88d3d0eab71356116e415cd1351;hpb=3acbd4f53b544ab36759ef8cf0a6fcc4f696a8d0;p=p5sagit%2Fp5-mst-13.2.git
diff --git a/lib/CGI.pm b/lib/CGI.pm
index 292e262..bd9c335 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.56 2001/12/09 21:36:23 lstein Exp $';
-$CGI::VERSION='2.79';
+$CGI::revision = '$Id: CGI.pm,v 1.75 2002/10/16 17:48:37 lstein Exp $';
+$CGI::VERSION='2.89';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
@@ -32,11 +32,15 @@ use CGI::Util qw(rearrange make_attributes unescape escape expires);
use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
+$TAINTED = substr("$0$^X",0,0);
+
+my @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
$AUTOLOAD_DEBUG = 0;
-
+
# Set this to 1 to generate XTML-compatible output
$XHTML = 1;
@@ -85,9 +89,9 @@ sub initialize_globals {
# separate the name=value pairs by semicolons rather than ampersands
$USE_PARAM_SEMICOLONS = 1;
- # Do not include undefined params parsed from query string
- # use CGI qw(-no_undef_params);
- $NO_UNDEF_PARAMS = 0;
+ # Do not include undefined params parsed from query string
+ # use CGI qw(-no_undef_params);
+ $NO_UNDEF_PARAMS = 0;
# Other globals that you shouldn't worry about.
undef $Q;
@@ -127,12 +131,14 @@ if ($OS =~ /^MSWin/i) {
$OS = 'OS2';
} elsif ($OS =~ /^epoc/i) {
$OS = 'EPOC';
+} elsif ($OS =~ /^cygwin/i) {
+ $OS = 'CYGWIN';
} else {
$OS = 'UNIX';
}
# Some OS logic. Binary mode enabled on DOS, NT and VMS
-$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin)/;
+$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN)/;
# This is the default class for the CGI object to use when all else fails.
$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
@@ -143,8 +149,8 @@ $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
# The path separator is a slash, backslash or semicolon, depending
# on the paltform.
$SL = {
- UNIX=>'/', OS2=>'\\', EPOC=>'/',
- WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/'
+ UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/',
+ WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/'
}->{$OS};
# This no longer seems to be necessary
@@ -153,13 +159,19 @@ $SL = {
$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
# Turn on special checking for Doug MacEachern's modperl
-if (exists $ENV{'GATEWAY_INTERFACE'}
- &&
+if (exists $ENV{'GATEWAY_INTERFACE'}
+ &&
($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//))
-{
+ {
$| = 1;
- require Apache;
-}
+ require mod_perl;
+ if ($mod_perl::VERSION >= 1.99) {
+ require Apache::compat;
+ } else {
+ require Apache;
+ }
+ }
+
# Turn on special checking for ActiveState's PerlEx
$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
@@ -219,9 +231,9 @@ if ($needs_binmode) {
sub import {
my $self = shift;
-# This causes modules to clash.
-# undef %EXPORT_OK;
-# undef %EXPORT;
+ # This causes modules to clash.
+ undef %EXPORT_OK;
+ undef %EXPORT;
$self->_setup_symbols(@_);
my ($callpack, $callfile, $callline) = caller;
@@ -381,6 +393,9 @@ sub init {
# set charset to the safe ISO-8859-1
$self->charset('ISO-8859-1');
+ # set autoescaping to on
+ $self->{'escape'} = 1;
+
METHOD: {
# avoid unreasonably large postings
@@ -552,6 +567,7 @@ sub parse_params {
my($param,$value);
foreach (@pairs) {
($param,$value) = split('=',$_,2);
+ next unless defined $param;
next if $NO_UNDEF_PARAMS and not defined $value;
$value = '' unless defined $value;
$param = unescape($param);
@@ -662,14 +678,14 @@ sub _selected {
my $self = shift;
my $value = shift;
return '' unless $value;
- return $XHTML ? qq( selected="1") : qq( selected);
+ return $XHTML ? qq( selected="selected") : qq( selected);
}
sub _checked {
my $self = shift;
my $value = shift;
return '' unless $value;
- return $XHTML ? qq( checked="1") : qq( checked);
+ return $XHTML ? qq( checked="checked") : qq( checked);
}
sub _reset_globals { initialize_globals(); }
@@ -677,6 +693,10 @@ sub _reset_globals { initialize_globals(); }
sub _setup_symbols {
my $self = shift;
my $compile = 0;
+
+ # to avoid reexporting unwanted variables
+ undef %EXPORT;
+
foreach (@_) {
$HEADERS_ONCE++, next if /^[:-]unique_headers$/;
$NPH++, next if /^[:-]nph$/;
@@ -709,6 +729,7 @@ sub _setup_symbols {
}
}
_compile_all(keys %EXPORT) if $compile;
+ @SAVED_SYMBOLS = @_;
}
sub charset {
@@ -761,11 +782,12 @@ END_OF_FUNC
####
sub delete {
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());
- return wantarray ? () : undef;
+ my(@names) = rearrange([NAME],@p);
+ for my $name (@names) {
+ CORE::delete $self->{$name};
+ CORE::delete $self->{'.fieldnames'}->{$name};
+ @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
+ }
}
END_OF_FUNC
@@ -987,7 +1009,9 @@ EOF
'autoEscape' => <<'END_OF_FUNC',
sub autoEscape {
my($self,$escape) = self_or_default(@_);
- $self->{'dontescape'}=!$escape;
+ my $d = $self->{'escape'};
+ $self->{'escape'} = $escape;
+ $d;
}
END_OF_FUNC
@@ -1331,7 +1355,7 @@ sub start_html {
$target,$meta,$head,$style,$dtd,$lang,$encoding,@other) =
rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD,LANG,ENCODING],@p);
- $encoding = 'utf-8' unless defined $encoding;
+ $encoding = 'iso-8859-1' unless defined $encoding;
# strangely enough, the title needs to be escaped as HTML
# while the author needs to be escaped as a URL
@@ -1354,11 +1378,11 @@ sub start_html {
push @result,qq() if $xml_dtd;
if (ref($dtd) && ref($dtd) eq 'ARRAY') {
- push(@result,qq([0]"\n\tSYSTEM "$dtd->[1]">));
+ push(@result,qq([0]"\n\t "$dtd->[1]">));
} else {
push(@result,qq());
}
- push(@result,$XHTML ? qq(
$title)
+ push(@result,$XHTML ? qq($title)
: qq($title));
if (defined $author) {
push(@result,$XHTML ? ""
@@ -1418,7 +1442,7 @@ sub _style {
foreach $src (@$src)
{
push(@result,$XHTML ? qq()
- : qq(/)) if $src;
+ : qq()) if $src;
}
}
else
@@ -1499,14 +1523,14 @@ END_OF_FUNC
# Parameters:
# $action -> optional URL of script to run
# Returns:
-# A string containing a tag
+# A string containing a tag
'isindex' => <<'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 $XHTML ? "" : "";
+ return $XHTML ? "" : "";
}
END_OF_FUNC
@@ -1528,7 +1552,9 @@ sub startform {
$enctype = $enctype || &URL_ENCODED;
unless (defined $action) {
$action = $self->url(-absolute=>1,-path=>1);
- $action .= "?$ENV{QUERY_STRING}" if $ENV{QUERY_STRING};
+ if (length($ENV{QUERY_STRING})>0) {
+ $action .= "?$ENV{QUERY_STRING}";
+ }
}
$action = qq(action="$action");
my($other) = @other ? " @other" : '';
@@ -1612,7 +1638,7 @@ sub _textfield {
# and WebTV -- not sure it won't break stuff
my($value) = $current ne '' ? qq(value="$current") : '';
return $XHTML ? qq()
- : qq//;
+ : qq();
}
END_OF_FUNC
@@ -1624,7 +1650,7 @@ END_OF_FUNC
# $size -> Optional width of field in characaters.
# $maxlength -> Optional maximum number of characters.
# Returns:
-# A string containing a field
+# A string containing a field
#
'textfield' => <<'END_OF_FUNC',
sub textfield {
@@ -1640,7 +1666,7 @@ END_OF_FUNC
# $size -> Optional width of field in characaters.
# $maxlength -> Optional maximum number of characters.
# Returns:
-# A string containing a field
+# A string containing a field
#
'filefield' => <<'END_OF_FUNC',
sub filefield {
@@ -1659,7 +1685,7 @@ END_OF_FUNC
# $size -> Optional width of field in characters.
# $maxlength -> Optional maximum characters that can be entered.
# Returns:
-# A string containing a field
+# A string containing a field
#
'password_field' => <<'END_OF_FUNC',
sub password_field {
@@ -1706,7 +1732,7 @@ END_OF_FUNC
# $onclick -> (optional) Text of the JavaScript to run when the button is
# clicked.
# Returns:
-# A string containing a tag
+# A string containing a tag
####
'button' => <<'END_OF_FUNC',
sub button {
@@ -1727,7 +1753,7 @@ sub button {
$script = qq/ onclick="$script"/ if $script;
my($other) = @other ? " @other" : '';
return $XHTML ? qq()
- : qq//;
+ : qq();
}
END_OF_FUNC
@@ -1739,7 +1765,7 @@ END_OF_FUNC
# $value -> (optional) Value of the button when selected (also doubles as label).
# $label -> (optional) Label printed on the button(also doubles as the value).
# Returns:
-# A string containing a tag
+# A string containing a tag
####
'submit' => <<'END_OF_FUNC',
sub submit {
@@ -1757,7 +1783,7 @@ sub submit {
$val = qq/ value="$value"/ if defined($value);
my($other) = @other ? " @other" : '';
return $XHTML ? qq()
- : qq//;
+ : qq();
}
END_OF_FUNC
@@ -1767,7 +1793,7 @@ END_OF_FUNC
# Parameters:
# $name -> (optional) Name for the button.
# Returns:
-# A string containing a tag
+# A string containing a tag
####
'reset' => <<'END_OF_FUNC',
sub reset {
@@ -1777,7 +1803,7 @@ sub reset {
my($value) = defined($label) ? qq/ value="$label"/ : '';
my($other) = @other ? " @other" : '';
return $XHTML ? qq()
- : qq//;
+ : qq();
}
END_OF_FUNC
@@ -1787,7 +1813,7 @@ END_OF_FUNC
# Parameters:
# $name -> (optional) Name for the button.
# Returns:
-# A string containing a tag
+# A string containing a tag
#
# Note: this button has a special meaning to the initialization script,
# and tells it to ERASE the current query string so that your defaults
@@ -1829,7 +1855,7 @@ END_OF_FUNC
# $label -> (optional) a user-readable label printed next to the box.
# Otherwise the checkbox name is used.
# Returns:
-# A string containing a field
+# A string containing a field
####
'checkbox' => <<'END_OF_FUNC',
sub checkbox {
@@ -1877,16 +1903,16 @@ END_OF_FUNC
# 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
+# 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,$rows,$columns,
+ my($name,$values,$defaults,$linebreak,$labels,$attributes,$rows,$columns,
$rowheaders,$colheaders,$override,$nolabels,@other) =
rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
- LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
+ LINEBREAK,LABELS,ATTRIBUTES,ROWS,[COLUMNS,COLS],
ROWHEADERS,COLHEADERS,
[OVERRIDE,FORCE],NOLABELS],@p);
@@ -1916,9 +1942,10 @@ sub checkbox_group {
$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}/);
+ push(@elements,$XHTML ? qq(${label}${break})
+ : qq/${label}${break}/);
}
$self->register_parameter($name);
return wantarray ? @elements : join(' ',@elements)
@@ -1934,7 +1961,7 @@ sub escapeHTML {
push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
return undef unless defined($toencode);
- return $toencode if ref($self) && $self->{'dontescape'};
+ return $toencode if ref($self) && !$self->{'escape'};
$toencode =~ s{&}{&}gso;
$toencode =~ s{<}{<}gso;
$toencode =~ s{>}{>}gso;
@@ -1943,8 +1970,8 @@ sub escapeHTML {
uc $self->{'.charset'} eq 'WINDOWS-1252';
if ($latin) { # bug in some browsers
$toencode =~ s{'}{'}gso;
- $toencode =~ s{\x8b}{}gso;
- $toencode =~ s{\x9b}{}gso;
+ $toencode =~ s{\x8b}{‹}gso;
+ $toencode =~ s{\x9b}{›}gso;
if (defined $newlinestoo && $newlinestoo) {
$toencode =~ s{\012}{
}gso;
$toencode =~ s{\015}{
}gso;
@@ -2029,15 +2056,15 @@ END_OF_FUNC
# 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
+# An ARRAY containing a series of fields
####
'radio_group' => <<'END_OF_FUNC',
sub radio_group {
my($self,@p) = self_or_default(@_);
- my($name,$values,$default,$linebreak,$labels,
+ my($name,$values,$default,$linebreak,$labels,$attributes,
$rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
- rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
+ rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,ATTRIBUTES,
ROWS,[COLUMNS,COLS],
ROWHEADERS,COLHEADERS,
[OVERRIDE,FORCE],NOLABELS],@p);
@@ -2057,7 +2084,7 @@ sub radio_group {
my($other) = @other ? " @other" : '';
foreach (@values) {
- my($checkit) = $checked eq $_ ? qq/ checked="1"/ : '';
+ my($checkit) = $checked eq $_ ? qq/ checked="checked"/ : '';
my($break);
if ($linebreak) {
$break = $XHTML ? " " : " ";
@@ -2071,9 +2098,10 @@ sub radio_group {
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
$label = $self->escapeHTML($label,1);
}
+ my $attribs = $self->_set_attributes($_, $attributes);
$_=$self->escapeHTML($_);
- push(@elements,$XHTML ? qq(${label}${break})
- : qq/${label}${break}/);
+ push(@elements,$XHTML ? qq(${label}${break})
+ : qq/${label}${break}/);
}
$self->register_parameter($name);
return wantarray ? @elements : join(' ',@elements)
@@ -2101,8 +2129,9 @@ END_OF_FUNC
sub popup_menu {
my($self,@p) = self_or_default(@_);
- my($name,$values,$default,$labels,$override,@other) =
- rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
+ my($name,$values,$default,$labels,$attributes,$override,@other) =
+ rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
+ ATTRIBUTES,[OVERRIDE,FORCE]],@p);
my($result,$selected);
if (!$override && defined($self->param($name))) {
@@ -2118,12 +2147,22 @@ sub popup_menu {
$result = qq/";
@@ -2132,6 +2171,66 @@ sub popup_menu {
END_OF_FUNC
+#### Method: optgroup
+# Create a optgroup.
+# Parameters:
+# $name -> Label for the group
+# $values -> A pointer to a regular array containing the
+# values for each option line in the group.
+# $labels -> (optional)
+# A pointer to an associative array of labels to print next to each item
+# in the form $label{'value'}="Long explanatory label".
+# Otherwise the provided values are used as the labels.
+# $labeled -> (optional)
+# A true value indicates the value should be used as the label attribute
+# in the option elements.
+# The label attribute specifies the option label presented to the user.
+# This defaults to the content of the