# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
-$CGI::revision = '$Id: CGI.pm,v 1.202 2006/02/24 19:03:29 lstein Exp $';
-$CGI::VERSION='3.17_01';
+$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.
$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
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')
||
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) {
if ($MOD_PERL == 1) {
} else {
$self = shift;
}
- my ($hook,$data) = @_;
+ my ($hook,$data,$use_tempfile) = @_;
$self->{'.upload_hook'} = $hook;
$self->{'.upload_data'} = $data;
+ $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile;
}
#### Method: param
}
}
# If values is provided, then we set it.
- if (@values) {
+ if (@values or defined $value) {
$self->add_parameter($name);
$self->{$name}=[@values];
}
}
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 {
# avoid unreasonably large postings
if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
- # quietly read and discard the post
- my $buffer;
- my $tmplength = $content_length;
- while($tmplength > 0) {
- my $maxbuffer = ($tmplength < 10000)?$tmplength:10000;
- my $bytesread = $MOD_PERL ? $self->r->read($buffer,$maxbuffer) : read(STDIN,$buffer,$maxbuffer);
- $tmplength -= $bytesread;
- }
- $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.
} else {
$charset = $self->charset if $type =~ /^text\//;
}
+ $charset ||= '';
# rearrange() was designed for the HTML portion, so we
# need to fix it up a little.
sub start_multipart_form {
my($self,@p) = self_or_default(@_);
if (defined($p[0]) && substr($p[0],0,1) eq '-') {
- my(%p) = @p;
- $p{'-enctype'}=&MULTIPART;
- return $self->startform(%p);
+ return $self->startform(-enctype=>&MULTIPART,@p);
} else {
my($method,$action,@other) =
rearrange([METHOD,ACTION],@p);
}
}
else {
- my $attribs = $self->_set_attributes($_, $attributes);
- my($selectit) = defined($selected) ? $self->_selected($selected eq $_) : '';
- my($label) = $_;
- $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- my($value) = $self->escapeHTML($_);
- $label=$self->escapeHTML($label,1);
- $result .= "<option $selectit${attribs}value=\"$value\">$label</option>\n";
+ my $attribs = $self->_set_attributes($_, $attributes);
+ my($selectit) = defined($selected) ? $self->_selected($selected eq $_) : '';
+ my($label) = $_;
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ my($value) = $self->escapeHTML($_);
+ $label=$self->escapeHTML($label,1);
+ $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
}
}
my $path = $self->path_info;
my $script_name = $self->script_name;
- my $request_uri = $self->request_uri || '';
+ my $request_uri = unescape($self->request_uri) || '';
my $query_str = $self->query_string;
my $rewrite_in_use = $request_uri && $request_uri !~ /^$script_name/;
my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
$uri =~ s/\?.*$//; # remove query string
- $uri =~ s/$path$// if defined $path; # remove path
+ $uri =~ s/\Q$path\E$// if defined $path; # remove path
if ($full) {
my $protocol = $self->protocol();
return $url if $base;
$url .= $uri;
} elsif ($relative) {
- ($url) = $script_name =~ m!([^/]+)$!;
+ ($url) = $uri =~ m!([^/]+)$!;
} elsif ($absolute) {
$url = $uri;
}
'cookie' => <<'END_OF_FUNC',
sub cookie {
my($self,@p) = self_or_default(@_);
- my($name,$value,$path,$domain,$secure,$expires) =
- rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
+ my($name,$value,$path,$domain,$secure,$expires,$httponly) =
+ rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@p);
require CGI::Cookie;
push(@param,'-path'=>$path) if $path;
push(@param,'-expires'=>$expires) if $expires;
push(@param,'-secure'=>$secure) if $secure;
+ push(@param,'-httponly'=>$httponly) if $httponly;
return new CGI::Cookie(@param);
}
} elsif (! defined($self->{'.path_info'}) ) {
my (undef,$path_info) = $self->_name_and_path_from_env;
$self->{'.path_info'} = $path_info || '';
- # hack to fix broken path info in IIS
- $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS;
-
}
return $self->{'.path_info'};
}
my $self = shift;
my $raw_script_name = $ENV{SCRIPT_NAME} || '';
my $raw_path_info = $ENV{PATH_INFO} || '';
- my $uri = $ENV{REQUEST_URI} || '';
+ my $uri = unescape($self->request_uri) || '';
- if ($raw_script_name =~ m/$raw_path_info$/) {
- $raw_script_name =~ s/$raw_path_info$//;
- }
+ my $protected = quotemeta($raw_path_info);
+ $raw_script_name =~ s/$protected$//;
my @uri_double_slashes = $uri =~ m^(/{2,}?)^g;
my @path_double_slashes = "$raw_script_name $raw_path_info" =~ m^(/{2,}?)^g;
my $apache_bug = @uri_double_slashes != @path_double_slashes;
return ($raw_script_name,$raw_path_info) unless $apache_bug;
- my $path_info_search = $raw_path_info;
- # these characters will not (necessarily) be escaped
- $path_info_search =~ s/([^a-zA-Z0-9$()':_.,+*\/;?=&-])/uc sprintf("%%%02x",ord($1))/eg;
- $path_info_search = quotemeta($path_info_search);
+ my $path_info_search = quotemeta($raw_path_info);
$path_info_search =~ s!/!/+!g;
if ($uri =~ m/^(.+)($path_info_search)/) {
return ($1,$2);
$totalbytes += length($data);
&{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'});
}
- print $filehandle $data;
+ print $filehandle $data if ($self->{'use_tempfile'});
}
# back up to beginning of file
'upload' =><<'END_OF_FUNC',
sub upload {
my($self,$param_name) = self_or_default(@_);
- my @param = grep(ref && fileno($_), $self->param($param_name));
+ my @param = grep {ref && defined(fileno($_))}, $self->param($param_name));
return unless @param;
return wantarray ? @param : $param[0];
}
that the first argument to the callback is an Apache::Upload object,
here it's the remote filename.
- $q = CGI->new(\&hook,$data);
+ $q = CGI->new(\&hook [,$data [,$use_tempfile]]);
sub hook
{
print "Read $bytes_read bytes of $filename\n";
}
+The $data field is optional; it lets you pass configuration
+information (e.g. a database handle) to your hook callback.
+
+The $use_tempfile field is a flag that lets you turn on and off
+CGI.pm's use of a temporary disk-based file during file upload. If you
+set this to a FALSE value (default true) then param('uploaded_file')
+will no longer work, and the only way to get at the uploaded data is
+via the hook you provide.
+
If using the function-oriented interface, call the CGI::upload_hook()
method before calling param() or any other CGI functions:
- CGI::upload_hook(\&hook,$data);
+ CGI::upload_hook(\&hook [,$data [,$use_tempfile]]);
This method is not exported by default. You will have to import it
explicitly if you wish to use it without the CGI:: prefix.
projects / p5sagit/p5-mst-13.2.git / blobdiff