# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
-$CGI::revision = '$Id: CGI.pm,v 1.181 2005/05/13 21:45:26 lstein Exp $';
-$CGI::VERSION='3.10_01';
+$CGI::revision = '$Id: CGI.pm,v 1.194 2005/12/06 22:12:56 lstein Exp $';
+$CGI::VERSION='3.15_01';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
# 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:
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
# 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};
+ }
}
}
}
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) = @_;
$self->{'.upload_hook'} = $hook;
$self->{'.upload_data'} = $data;
}
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;
- }
- }
+ 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;
+ }
# Process multipart postings, but only if the initializer is
# not defined.
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(); }
$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$/;
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" );
}
###############################################################################
####
'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) {
$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" : '';
'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 '-') {
+ if (defined($p[0]) && substr($p[0],0,1) eq '-') {
my(%p) = @p;
$p{'-enctype'}=&MULTIPART;
return $self->startform(%p);
# 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 ? ("</form>") : "\n</form>";
} else {
- return wantarray ? ("<div>",$self->get_fields,"</div>","</form>") :
- "<div>".$self->get_fields ."</div>\n</form>";
+ if (my @fields = $self->get_fields) {
+ return wantarray ? ("<div>",@fields,"</div>","</form>")
+ : "<div>".(join '',@fields)."</div>\n</form>";
+ } else {
+ return "</form>";
+ }
}
}
END_OF_FUNC
# and WebTV -- not sure it won't break stuff
my($value) = $current ne '' ? qq(value="$current") : '';
$tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq(<input type="$tag" name="$name" tabindex="$tabindex" $value$s$m$other />)
+ return $XHTML ? qq(<input type="$tag" name="$name" $tabindex$value$s$m$other />)
: qq(<input type="$tag" name="$name" $value$s$m$other>);
}
END_OF_FUNC
my($c) = $cols ? qq/ cols="$cols"/ : '';
my($other) = @other ? " @other" : '';
$tabindex = $self->element_tab($tabindex);
- return qq{<textarea name="$name" tabindex="$tabindex"$r$c$other>$current</textarea>};
+ return qq{<textarea name="$name" $tabindex$r$c$other>$current</textarea>};
}
END_OF_FUNC
$script = qq/ onclick="$script"/ if $script;
my($other) = @other ? " @other" : '';
$tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq(<input type="button" tabindex="$tabindex"$name$val$script$other />)
+ return $XHTML ? qq(<input type="button" $tabindex$name$val$script$other />)
: qq(<input type="button"$name$val$script$other>);
}
END_OF_FUNC
$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(<input type="submit" tabindex="$tabindex"$name$val$other />)
- : qq(<input type="submit"$name$val$other>);
+ my($other) = @other ? "@other " : '';
+ return $XHTML ? qq(<input type="submit" $tabindex$name$val$other/>)
+ : qq(<input type="submit" $name$val$other>);
}
END_OF_FUNC
$val = qq/ value="$value"/ if defined($value);
my($other) = @other ? " @other" : '';
$tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq(<input type="reset" tabindex="$tabindex"$name$val$other />)
+ return $XHTML ? qq(<input type="reset" $tabindex$name$val$other />)
: qq(<input type="reset"$name$val$other>);
}
END_OF_FUNC
my($value) = qq/ value="$label"/;
my($other) = @other ? " @other" : '';
$tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq(<input type="submit" name=".defaults" tabindex="$tabindex"$value$other />)
+ return $XHTML ? qq(<input type="submit" name=".defaults" $tabindex$value$other />)
: qq/<input type="submit" NAME=".defaults"$value$other>/;
}
END_OF_FUNC
$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{<input type="checkbox" name="$name" value="$value" tabindex="$tabindex"$checked$other />$the_label})
+ return $XHTML ? CGI::label(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
$name=$self->escapeHTML($name);
my %tabs = ();
- if ($tabindex) {
+ if ($TABINDEX && $tabindex) {
if (!ref $tabindex) {
$self->element_tab($tabindex);
} elsif (ref $tabindex eq 'ARRAY') {
}
%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++)
$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(<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs />$label)).${break};
+ qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs/>$label)).${break};
} else {
push(@elements,qq/<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs>${label}${break}/);
}
my(@values);
@values = $self->_set_values_and_labels($values,\$labels,$name);
$tabindex = $self->element_tab($tabindex);
- $result = qq/<select name="$name" tabindex="$tabindex"$other>\n/;
+ $result = qq/<select name="$name" $tabindex$other>\n/;
foreach (@values) {
if (/<optgroup/) {
foreach (split(/\n/)) {
$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";
+ $result .= "<option $selectit${attribs}value=\"$value\">$label</option>\n";
}
}
$name=$self->escapeHTML($name);
$tabindex = $self->element_tab($tabindex);
- $result = qq/<select name="$name" tabindex="$tabindex"$has_size$is_multiple$other>\n/;
+ $result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/;
foreach (@values) {
my($selectit) = $self->_selected($selected{$_});
my($label) = $_;
$label=$self->escapeHTML($label);
my($value)=$self->escapeHTML($_,1);
my $attribs = $self->_set_attributes($_, $attributes);
- $result .= "<option$selectit$attribs value=\"$value\">$label</option>\n";
+ $result .= "<option ${selectit}${attribs}value=\"$value\">$label</option>\n";
}
$result .= "</select>";
$self->register_parameter($name);
'url' => <<'END_OF_FUNC',
sub url {
my($self,@p) = self_or_default(@_);
- my ($relative,$absolute,$full,$path_info,$query,$base) =
- rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE'],@p);
- my $url;
+ my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) =
+ rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p);
+ my $url = '';
$full++ if $base || !($relative || $absolute);
+ $rewrite++ unless defined $rewrite;
- my $path = $self->path_info;
- my $script_name = $self->script_name;
-
- # for compatibility with Apache's MultiViews
- if (exists($ENV{REQUEST_URI})) {
- my $index;
- $script_name = unescape($ENV{REQUEST_URI});
- $script_name =~ s/\?.+$//s; # strip query string
- # and path
- if (exists($ENV{PATH_INFO})) {
- my $encoded_path = unescape($ENV{PATH_INFO});
- $script_name =~ s/\Q$encoded_path\E$//i;
- }
- }
+ my $path = $self->path_info;
+ my $script_name = $self->script_name;
+ my $request_uri = $self->request_uri || '';
+ my $query_str = $self->query_string;
+
+ my $rewrite_in_use = $request_uri && $request_uri !~ /^$script_name/;
+ undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active
+
+ my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
+ $uri =~ s/\?.*$//; # remove query string
+ $uri =~ s/$path$// if defined $path; # remove path
if ($full) {
my $protocol = $self->protocol();
|| (lc($protocol) eq 'https' && $port == 443);
}
return $url if $base;
- $url .= $script_name;
+ $url .= $uri;
} elsif ($relative) {
($url) = $script_name =~ m!([^/]+)$!;
} elsif ($absolute) {
- $url = $script_name;
+ $url = $uri;
}
- $url .= $path if $path_info and defined $path;
- $url .= "?" . $self->query_string if $query and $self->query_string;
- $url = '' unless defined $url;
+ $url .= $path if $path_info and defined $path;
+ $url .= "?$query_str" if $query and $query_str ne '';
$url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
return $url;
}
$info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
$self->{'.path_info'} = $info;
} elsif (! defined($self->{'.path_info'}) ) {
- $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ?
- $ENV{'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;
}
END_OF_FUNC
+# WE USE THIS TO COMPENSATE FOR A BUG IN APACHE 2 PRESENT AT LEAST UP THROUGH 2.0.54
+'_name_and_path_from_env' => <<'END_OF_FUNC',
+sub _name_and_path_from_env {
+ my $self = shift;
+ my $raw_script_name = $ENV{SCRIPT_NAME} || '';
+ my $raw_path_info = $ENV{PATH_INFO} || '';
+ my $uri = $ENV{REQUEST_URI} || '';
+
+ if ($raw_script_name =~ m/$raw_path_info$/) {
+ $raw_script_name =~ s/$raw_path_info$//;
+ }
+
+ 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);
+ $path_info_search =~ s!/!/+!g;
+ if ($uri =~ m/^(.+)($path_info_search)/) {
+ return ($1,$2);
+ } else {
+ return ($raw_script_name,$raw_path_info);
+ }
+}
+END_OF_FUNC
+
#### Method: request_method
# Returns 'POST', 'GET', 'PUT' or 'HEAD'
END_OF_FUNC
+#### Method: request_uri
+# Return the literal request URI
+####
+'request_uri' => <<'END_OF_FUNC',
+sub request_uri {
+ return $ENV{'REQUEST_URI'};
+}
+END_OF_FUNC
+
+
#### Method: query_string
# Synthesize a query string from our current
# parameters
####
'script_name' => <<'END_OF_FUNC',
sub script_name {
- return $ENV{'SCRIPT_NAME'} if defined($ENV{'SCRIPT_NAME'});
- # These are for debugging
- return "/$0" unless $0=~/^\//;
- return $0;
+ my ($self,@p) = self_or_default(@_);
+ if (@p) {
+ $self->{'.script_name'} = shift;
+ } elsif (!exists $self->{'.script_name'}) {
+ my ($script_name,$path_info) = $self->_name_and_path_from_env();
+ $self->{'.script_name'} = $script_name;
+ }
+ return $self->{'.script_name'};
}
END_OF_FUNC
sub virtual_port {
my($self) = self_or_default(@_);
my $vh = $self->http('x_forwarded_host') || $self->http('host');
+ my $protocol = $self->protocol;
if ($vh) {
- return ($vh =~ /:(\d+)$/)[0] || '80';
+ return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80);
} else {
return $self->server_port();
}
# Save some information about the uploaded file where we can get
# at it later.
- $self->{'.tmpfiles'}->{fileno($filehandle)}= {
+ # Use the typeglob as the key, as this is guaranteed to be
+ # unique for each filehandle. Don't use the file descriptor as
+ # this will be re-used for each filehandle if the
+ # close_upload_files feature is used.
+ $self->{'.tmpfiles'}->{$$filehandle}= {
hndl => $filehandle,
name => $tmpfile,
info => {%header},
'tmpFileName' => <<'END_OF_FUNC',
sub tmpFileName {
my($self,$filename) = self_or_default(@_);
- return $self->{'.tmpfiles'}->{fileno($filename)}->{name} ?
- $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string
+ return $self->{'.tmpfiles'}->{$$filename}->{name} ?
+ $self->{'.tmpfiles'}->{$$filename}->{name}->as_string
: '';
}
END_OF_FUNC
'uploadInfo' => <<'END_OF_FUNC',
sub uploadInfo {
my($self,$filename) = self_or_default(@_);
- return $self->{'.tmpfiles'}->{fileno($filename)}->{info};
+ return $self->{'.tmpfiles'}->{$$filename}->{info};
}
END_OF_FUNC
package CGITempFile;
sub find_tempdir {
- undef $TMPDIRECTORY;
$SL = $CGI::SL;
$MAC = $CGI::OS eq 'MACINTOSH';
my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
- unless ($TMPDIRECTORY) {
+ unless (defined $TMPDIRECTORY) {
@TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
"C:${SL}temp","${SL}tmp","${SL}temp",
"${vol}${SL}Temporary Items",
hr;
if (param()) {
- print "Your name is",em(param('name')),p,
- "The keywords are: ",em(join(", ",param('words'))),p,
- "Your favorite color is ",em(param('color')),
+ my $name = param('name');
+ my $keywords = join ', ',param('words');
+ my $color = param('color');
+ print "Your name is",em(escapeHTML($name)),p,
+ "The keywords are: ",em(escapeHTML($keywords)),p,
+ "Your favorite color is ",em(escapeHTML($color)),
hr;
}
Use Delete_all() instead if you are using the function call interface.
+=head2 HANDLING NON-URLENCODED ARGUMENTS
+
+
+If POSTed data is not of type application/x-www-form-urlencoded or
+multipart/form-data, then the POSTed data will not be processed, but
+instead be returned as-is in a parameter named POSTDATA. To retrieve
+it, use code like this:
+
+ my $data = $query->param('POSTDATA');
+
+(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.)
+
+
=head2 DIRECT ACCESS TO THE PARAMETER LIST:
$q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
this behavior. You can also selectively change the sticky behavior in
each element that you generate.
+=item -tabindex
+
+Automatically add tab index attributes to each form field. With this
+option turned off, you can still add tab indexes manually by passing a
+-tabindex option to each field-generating method.
+
=item -no_undef_params
This keeps CGI.pm from including undef params in the parameter list.
Generate just the protocol and net location, as in http://www.foo.com:8000
+=item B<-rewrite>
+
+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 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.
+
=back
=head2 MIXING POST AND URL PARAMETERS
that the first argument to the callback is an Apache::Upload object,
here it's the remote filename.
- $q = CGI->new();
- $q->upload_hook(\&hook,$data);
+ $q = CGI->new(\&hook,$data);
sub hook
{
compatibility routine "ReadParse" is provided. Porting is simple:
OLD VERSION
-
require "cgi-lib.pl";
&ReadParse;
print "The value of the antique is $in{antique}.\n";
NEW VERSION
-
use CGI;
CGI::ReadParse();
print "The value of the antique is $in{antique}.\n";
https://perl5.git.perl.org / perl5.git / blobdiff