# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
-$CGI::revision = '$Id: CGI.pm,v 1.185 2005/08/03 21:14:55 lstein Exp $';
-$CGI::VERSION='3.11_01';
+$CGI::revision = '$Id: CGI.pm,v 1.193 2005/12/05 13:52:24 lstein Exp $';
+$CGI::VERSION='3.13_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:
# 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" );
}
###############################################################################
$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) = $_;
'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;
+ 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/\?.+$// if defined $query_str;
+ $uri =~ s/$path$// if defined $path; # remove path from URI
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;
}
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;
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",
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";
--- /dev/null
+#!/usr/local/bin/perl -w
+
+# Due to a bug in older versions of MakeMaker & Test::Harness, we must
+# ensure the blib's are in @INC, else we might use the core CGI.pm
+use lib qw(. ./blib/lib ./blib/arch);
+
+use Test::More tests => 18;
+
+BEGIN { use_ok('CGI'); };
+use CGI (':standard','-no_debug');
+
+my $CRLF = "\015\012";
+if ($^O eq 'VMS') {
+ $CRLF = "\n"; # via web server carriage is inserted automatically
+}
+if (ord("\t") != 9) { # EBCDIC?
+ $CRLF = "\r\n";
+}
+
+
+# Set up a CGI environment
+$ENV{REQUEST_METHOD} = 'GET';
+$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull';
+$ENV{PATH_INFO} = '/somewhere/else';
+$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else';
+$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi';
+$ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
+$ENV{SERVER_PORT} = 8080;
+$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
+
+ok( (not $CGI::TABINDEX), "Tab index turned off.");
+
+is(submit(),
+ qq(<input type="submit" name=".submit" />),
+ "submit()");
+
+is(submit(-name => 'foo',
+ -value => 'bar'),
+ qq(<input type="submit" name="foo" value="bar" />),
+ "submit(-name,-value)");
+
+is(submit({-name => 'foo',
+ -value => 'bar'}),
+ qq(<input type="submit" name="foo" value="bar" />),
+ "submit({-name,-value})");
+
+is(textfield(-name => 'weather'),
+ qq(<input type="text" name="weather" value="dull" />),
+ "textfield({-name})");
+
+is(textfield(-name => 'weather',
+ -value => 'nice'),
+ qq(<input type="text" name="weather" value="dull" />),
+ "textfield({-name,-value})");
+
+is(textfield(-name => 'weather',
+ -value => 'nice',
+ -override => 1),
+ qq(<input type="text" name="weather" value="nice" />),
+ "textfield({-name,-value,-override})");
+
+is(checkbox(-name => 'weather',
+ -value => 'nice'),
+ qq(<label><input type="checkbox" name="weather" value="nice" />weather</label>),
+ "checkbox()");
+
+is(checkbox(-name => 'weather',
+ -value => 'nice',
+ -label => 'forecast'),
+ qq(<label><input type="checkbox" name="weather" value="nice" />forecast</label>),
+ "checkbox()");
+
+is(checkbox(-name => 'weather',
+ -value => 'nice',
+ -label => 'forecast',
+ -checked => 1,
+ -override => 1),
+ qq(<label><input type="checkbox" name="weather" value="nice" checked="checked" />forecast</label>),
+ "checkbox()");
+
+is(checkbox(-name => 'weather',
+ -value => 'dull',
+ -label => 'forecast'),
+ qq(<label><input type="checkbox" name="weather" value="dull" checked="checked" />forecast</label>),
+ "checkbox()");
+
+is(radio_group(-name => 'game'),
+ qq(<label><input type="radio" name="game" value="chess" checked="checked" />chess</label> <label><input type="radio" name="game" value="checkers" />checkers</label>),
+ 'radio_group()');
+
+is(radio_group(-name => 'game',
+ -labels => {'chess' => 'ping pong'}),
+ qq(<label><input type="radio" name="game" value="chess" checked="checked" />ping pong</label> <label><input type="radio" name="game" value="checkers" />checkers</label>),
+ 'radio_group()');
+
+is(checkbox_group(-name => 'game',
+ -Values => [qw/checkers chess cribbage/]),
+ qq(<label><input type="checkbox" name="game" value="checkers" checked="checked" />checkers</label> <label><input type="checkbox" name="game" value="chess" checked="checked" />chess</label> <label><input type="checkbox" name="game" value="cribbage" />cribbage</label>),
+ 'checkbox_group()');
+
+is(checkbox_group(-name => 'game',
+ '-values' => [qw/checkers chess cribbage/],
+ '-defaults' => ['cribbage'],
+ -override=>1),
+ qq(<label><input type="checkbox" name="game" value="checkers" />checkers</label> <label><input type="checkbox" name="game" value="chess" />chess</label> <label><input type="checkbox" name="game" value="cribbage" checked="checked" />cribbage</label>),
+ 'checkbox_group()');
+
+is(popup_menu(-name => 'game',
+ '-values' => [qw/checkers chess cribbage/],
+ -default => 'cribbage',
+ -override => 1),
+ '<select name="game" >
+<option value="checkers">checkers</option>
+<option value="chess">chess</option>
+<option selected="selected" value="cribbage">cribbage</option>
+</select>',
+ 'popup_menu()');
+
+
+is(textarea(-name=>'foo',
+ -default=>'starting value',
+ -rows=>10,
+ -columns=>50),
+ '<textarea name="foo" rows="10" cols="50">starting value</textarea>',
+ 'textarea()');
+
projects / p5sagit/p5-mst-13.2.git / commitdiff