# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
-$CGI::revision = '$Id: CGI.pm,v 1.234 2007/04/16 16:58:46 lstein Exp $';
-$CGI::VERSION='3.29';
+$CGI::revision = '$Id: CGI.pm,v 1.251 2008/04/23 13:08:23 lstein Exp $';
+$CGI::VERSION='3.37';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
$TAINTED = substr("$0$^X",0,0);
}
-$MOD_PERL = 0; # no mod_perl by default
+$MOD_PERL = 0; # no mod_perl by default
+
+#global settings
+$POST_MAX = -1; # no limit to uploaded files
+$DISABLE_UPLOADS = 0;
+
@SAVED_SYMBOLS = ();
# it can just be renamed, instead of read and written.
$CLOSE_UPLOAD_FILES = 0;
- # Set this to a positive value to limit the size of a POSTing
- # to a certain number of bytes:
- $POST_MAX = -1;
-
- # Change this to 1 to disable uploads entirely:
- $DISABLE_UPLOADS = 0;
-
# Automatically determined -- don't change
$EBCDIC = 0;
# use CGI qw(-no_undef_params);
$NO_UNDEF_PARAMS = 0;
+ # return everything as utf-8
+ $PARAM_UTF8 = 0;
+
# Other globals that you shouldn't worry about.
undef $Q;
$BEEN_THERE = 0;
$self->r(Apache->request) unless $self->r;
my $r = $self->r;
$r->register_cleanup(\&CGI::_reset_globals);
+ $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
}
else {
# XXX: once we have the new API
my $r = $self->r;
$r->subprocess_env unless exists $ENV{REQUEST_METHOD};
$r->pool->cleanup_register(\&CGI::_reset_globals);
+ $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
}
undef $NPH;
}
return unless defined($name) && $self->{$name};
- 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];
+ my @result = @{$self->{$name}};
+
+ if ($PARAM_UTF8) {
+ eval "require Encode; 1;" unless Encode->can('decode'); # bring in these functions
+ @result = map {ref $_ ? $_ : Encode::decode(utf8=>$_) } @result;
}
+
+ return wantarray ? @result : $result[0];
}
sub self_or_default {
last METHOD;
}
- if ($meth eq 'POST') {
+ if ($meth eq 'POST' || $meth eq 'PUT') {
$self->read_from_client(\$query_string,$content_length,0)
if $content_length > 0;
# Some people want to have their cake and eat it too!
}
# YL: Begin Change for XML handler 10/19/2001
- if (!$is_xforms && $meth eq 'POST'
+ if (!$is_xforms && ($meth eq 'POST' || $meth eq 'PUT')
&& defined($ENV{'CONTENT_TYPE'})
&& $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
&& $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
- my($param) = 'POSTDATA' ;
+ my($param) = $meth . 'DATA' ;
$self->add_parameter($param) ;
push (@{$self->{$param}},$query_string);
undef $query_string ;
$DEBUG=0, next if /^[:-]no_?[Dd]ebug$/;
$DEBUG=2, next if /^[:-][Dd]ebug$/;
$USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
+ $PARAM_UTF8++, next if /^[:-]utf8$/;
$XHTML++, next if /^[:-]xhtml$/;
$XHTML=0, next if /^[:-]no_?xhtml$/;
$USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
push(@header,map {ucfirst $_} @other);
push(@header,"Content-Type: $type") if $type ne '';
my $header = join($CRLF,@header)."${CRLF}${CRLF}";
- if ($MOD_PERL and not $nph) {
+ if (($MOD_PERL >= 1) && !$nph) {
$self->r->send_cgi_header($header);
return '';
}
my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
my @s = ref($style) eq 'ARRAY' ? @$style : $style;
+ my $other = '';
for my $s (@s) {
if (ref($s)) {
ref($s) eq 'ARRAY' ? @$s : %$s));
my $type = defined $stype ? $stype : 'text/css';
my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet';
- my $other = @other ? join ' ',@other : '';
+ $other = "@other" if @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
my($method,$action,$enctype,@other) =
rearrange([METHOD,ACTION,ENCTYPE],@p);
- $method = $self->escapeHTML(lc($method) || 'post');
+ $method = $self->escapeHTML(lc($method || 'post'));
$enctype = $self->escapeHTML($enctype || &URL_ENCODED);
if (defined $action) {
$action = $self->escapeHTML($action);
sub checkbox {
my($self,@p) = self_or_default(@_);
- my($name,$checked,$value,$label,$override,$tabindex,@other) =
- rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE],TABINDEX],@p);
+ my($name,$checked,$value,$label,$labelattributes,$override,$tabindex,@other) =
+ rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES,
+ [OVERRIDE,FORCE],TABINDEX],@p);
$value = defined $value ? $value : 'on';
my($other) = @other ? "@other " : '';
$tabindex = $self->element_tab($tabindex);
$self->register_parameter($name);
- return $XHTML ? CGI::label(qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label})
+ return $XHTML ? CGI::label($labelattributes,
+ qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label})
: qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
}
END_OF_FUNC
else {
$toencode =~ s{"}{"}gso;
}
- my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' ||
- uc $self->{'.charset'} eq 'WINDOWS-1252';
- if ($latin) { # bug in some browsers
+ # Handle bug in some browsers with Latin charsets
+ if ($self->{'.charset'} &&
+ (uc($self->{'.charset'}) eq 'ISO-8859-1' ||
+ uc($self->{'.charset'}) eq 'WINDOWS-1252'))
+ {
$toencode =~ s{'}{'}gso;
$toencode =~ s{\x8b}{‹}gso;
$toencode =~ s{\x9b}{›}gso;
my $self = shift;
my $box_type = shift;
- my($name,$values,$defaults,$linebreak,$labels,$attributes,
- $rows,$columns,$rowheaders,$colheaders,
+ my($name,$values,$defaults,$linebreak,$labels,$labelattributes,
+ $attributes,$rows,$columns,$rowheaders,$colheaders,
$override,$nolabels,$tabindex,$disabled,@other) =
- rearrange([ NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,ATTRIBUTES,
- ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER],
- [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED
- ],@_);
+ rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES,
+ ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER],
+ [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED
+ ],@_);
+
my($result,$checked,@elements,@values);
if ($XHTML) {
push @elements,
- CGI::label(
+ CGI::label($labelattributes,
qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break};
} else {
push(@elements,qq/<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs$disable>${label}${break}/);
$size = $size || scalar(@values);
my(%selected) = $self->previous_or_default($name,$defaults,$override);
+
my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
my($has_size) = $size ? qq/ size="$size"/: '';
my($other) = @other ? " @other" : '';
my $request_uri = unescape($self->request_uri) || '';
my $query_str = $self->query_string;
- my $rewrite_in_use = $request_uri && $request_uri !~ /^$script_name/;
+ my $rewrite_in_use = $request_uri && $request_uri !~ /^\Q$script_name/;
undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active
my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
$url .= $path if $path_info and defined $path;
$url .= "?$query_str" if $query and $query_str ne '';
+ $url ||= '';
$url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
return $url;
}
if (!$override && ($self->{'.fieldnames'}->{$name} ||
defined($self->param($name)) ) ) {
- grep($selected{$_}++,$self->param($name));
+ $selected{$_}++ for $self->param($name);
} elsif (defined($defaults) && ref($defaults) &&
(ref($defaults) eq 'ARRAY')) {
- grep($selected{$_}++,@{$defaults});
+ $selected{$_}++ for @{$defaults};
} else {
$selected{$defaults}++ if defined($defaults);
}
my($param)= $header{'Content-Disposition'}=~/ name="([^"]*)"/;
$param .= $TAINTED;
- # Bug: Netscape doesn't escape quotation marks in file names!!!
- my($filename) = $header{'Content-Disposition'}=~/ filename="([^"]*)"/;
+ # See RFC 1867, 2183, 2045
+ # NB: File content will be loaded into memory should
+ # content-disposition parsing fail.
+ my ($filename) = $header{'Content-Disposition'}
+ =~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i;
+ $filename =~ s/^"([^"]*)"$/$1/;
# Test for Opera's multiple upload feature
my($multipart) = ( defined( $header{'Content-Type'} ) &&
$header{'Content-Type'} =~ /multipart\/mixed/ ) ?
my ($data);
local($\) = '';
- my $totalbytes;
+ my $totalbytes = 0;
while (defined($data = $buffer->read)) {
if (defined $self->{'.upload_hook'})
{
(my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
my $fv = ++$FH . $safename;
my $ref = \*{"Fh::$fv"};
- $file =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return;
+ $file =~ m!^([a-zA-Z0-9_\+ \'\":/.\$\\-]+)$! || return;
my $safe = $1;
sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
unlink($safe) if $delete;
}
my $self = {LENGTH=>$length,
- CHUNKED=>!defined $length,
+ CHUNKED=>!$length,
BOUNDARY=>$boundary,
INTERFACE=>$interface,
BUFFER=>'',
my $filename;
find_tempdir() unless -w $TMPDIRECTORY;
for (my $i = 0; $i < $MAXTRIES; $i++) {
- last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
+ last if ! -f ($filename = sprintf("\%s${SL}CGItemp%d", $TMPDIRECTORY, $sequence++));
}
# check that it is a more-or-less valid filename
- return unless $filename =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$!;
+ return unless $filename =~ m!^([a-zA-Z0-9_\+ \'\":/.\$\\-]+)$!;
# this used to untaint, now it doesn't
# $filename = $1;
return bless \$filename;
hr;
}
+ print end_html;
+
=head1 ABSTRACT
This perl library uses perl5 objects to make it easy to create Web
my $data = $query->param('POSTDATA');
+Likewise if PUTed data can be retrieved with code like this:
+
+ my $data = $query->param('PUTDATA');
+
(If you don't know what the preceding means, don't worry about it. It
only affects people trying to use CGI for XML processing and other
specialized tasks.)
XHTML will automatically be disabled without needing to use this
pragma.
+=item -utf8
+
+This makes CGI.pm treat all parameters as UTF-8 strings. Use this with
+care, as it will interfere with the processing of binary uploads. It
+is better to manually select which fields are expected to return utf-8
+strings and convert them using code like this:
+
+ use Encode;
+ my $arg = decode utf8=>param('foo');
+
=item -nph
This makes CGI.pm produce a header appropriate for an NPH (no
If Apache's mod_rewrite is turned on, then the script name and path
info probably won't match the request that the user sent. Set
-rewrite=>1 (default) to return URLs that match what the user sent
-(the original request URI). Set -rewrite->0 to return URLs that match
+(the original request URI). Set -rewrite=>0 to return URLs that match
the URL after mod_rewrite's rules have run. Because the additional
path information only makes sense in the context of the rewritten URL,
-rewrite is set to false when you request path info in the URL.
-tabindex => ['moe','minie','eenie','meenie'] # tab in this order
-tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
+The optional B<-labelattributes> argument will contain attributes
+attached to the <label> element that surrounds each button.
+
When the form is processed, all checked boxes will be returned as
a list under the parameter name 'group_name'. The values of the
"on" checkboxes can be retrieved with:
with the attribute's name as the key and the attribute's value as the
value.
+The optional B<-labelattributes> argument will contain attributes
+attached to the <label> element that surrounds each button.
+
When the form is processed, the selected radio button can
be retrieved using:
=head1 AUTHOR INFORMATION
-Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
+The GD.pm interface is copyright 1995-2007, Lincoln D. Stein. It is
+distributed under GPL and the Artistic License 2.0.
Address bug reports and comments to: lstein@cshl.org. When sending
bug reports, please provide the version of CGI.pm, the version of