X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCGI.pm;h=bd9c3354f7290faac2c15d0d09e6418b04fc2c08;hb=3b0db4f96671dacfd3421850abb588b84e2ce6da;hp=a53fbb51444b8cb95fd133bd0c5123eb0b23cf1d;hpb=b2d0d414607297b6dab01ace56e87e3f6aae98e7;p=p5sagit%2Fp5-mst-13.2.git
diff --git a/lib/CGI.pm b/lib/CGI.pm
index a53fbb5..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.62 2002/04/10 19:36:01 lstein Exp $';
-$CGI::VERSION='2.81';
+$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,6 +32,10 @@ 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
@@ -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,7 +231,7 @@ if ($needs_binmode) {
sub import {
my $self = shift;
-# This causes modules to clash.
+ # This causes modules to clash.
undef %EXPORT_OK;
undef %EXPORT;
@@ -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
@@ -714,6 +729,7 @@ sub _setup_symbols {
}
}
_compile_all(keys %EXPORT) if $compile;
+ @SAVED_SYMBOLS = @_;
}
sub charset {
@@ -766,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
@@ -992,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
@@ -1363,7 +1382,7 @@ sub start_html {
} else {
push(@result,qq());
}
- push(@result,$XHTML ? qq(
$title)
+ push(@result,$XHTML ? qq($title)
: qq($title));
if (defined $author) {
push(@result,$XHTML ? ""
@@ -1504,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
@@ -1533,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" : '';
@@ -1629,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 {
@@ -1645,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 {
@@ -1664,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 {
@@ -1711,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 {
@@ -1744,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 {
@@ -1772,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 {
@@ -1792,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
@@ -1834,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 {
@@ -1882,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);
@@ -1921,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)
@@ -1939,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;
@@ -1948,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;
@@ -2034,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);
@@ -2076,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)
@@ -2106,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))) {
@@ -2123,12 +2147,22 @@ sub popup_menu {
$result = qq/";
@@ -2137,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