# listing the modifications you have made.
# The most recent version and complete docs are available at:
-# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
-# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
+# http://stein.cshl.org/WWW/software/CGI/
-$CGI::revision = '$Id: CGI.pm,v 1.32 1998/05/28 21:55:43 lstein Exp lstein $';
-$CGI::VERSION='2.42';
+$CGI::revision = '$Id: CGI.pm,v 1.18 1999/06/09 14:52:45 lstein Exp $';
+$CGI::VERSION='2.53';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
# Change this to 1 to disable uploads entirely:
$DISABLE_UPLOADS = 0;
+ # Automatically determined -- don't change
+ $EBCDIC = 0;
+
+ # Change this to 1 to suppress redundant HTTP headers
+ $HEADERS_ONCE = 0;
+
+ # separate the name=value pairs by semicolons rather than ampersands
+ $USE_PARAM_SEMICOLONS = 0;
+
# Other globals that you shouldn't worry about.
undef $Q;
$BEEN_THERE = 0;
}
}
if ($OS=~/Win/i) {
- $OS = 'WINDOWS';
+ $OS = 'WINDOWS';
} elsif ($OS=~/vms/i) {
- $OS = 'VMS';
+ $OS = 'VMS';
+} elsif ($OS=~/dos/i) {
+ $OS = 'DOS';
} elsif ($OS=~/^MacOS$/i) {
$OS = 'MACINTOSH';
} elsif ($OS=~/os2/i) {
}
# Some OS logic. Binary mode enabled on DOS, NT and VMS
-$needs_binmode = $OS=~/^(WINDOWS|VMS|OS2)/;
+$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin)/;
# This is the default class for the CGI object to use when all else fails.
$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
# The path separator is a slash, backslash or semicolon, depending
# on the paltform.
$SL = {
- UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', MACINTOSH=>':', VMS=>'/'
+ UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/'
}->{$OS};
# This no longer seems to be necessary
$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
# Turn on special checking for Doug MacEachern's modperl
-if (defined($ENV{'GATEWAY_INTERFACE'}) &&
- ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//))
+if (exists $ENV{'GATEWAY_INTERFACE'}
+ &&
+ ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//))
{
$| = 1;
require Apache;
# really annoying.
$EBCDIC = "\t" ne "\011";
if ($OS eq 'VMS') {
- $CRLF = "\n";
+ $CRLF = "\n";
} elsif ($EBCDIC) {
- $CRLF= "\r\n";
+ $CRLF= "\r\n";
} else {
- $CRLF = "\015\012";
+ $CRLF = "\015\012";
+}
+
+if ($EBCDIC) {
+@A2E = (
+ 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
+ 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
+240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
+124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
+215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
+121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
+151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7,
+ 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27,
+ 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255,
+ 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
+144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
+100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
+172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
+ 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
+140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
+ );
}
if ($needs_binmode) {
tt u i b blockquote pre img a address cite samp dfn html head
base body Link nextid title meta kbd start_html end_html
input Select option comment/],
- ':html3'=>[qw/div table caption th td TR Tr sup sub strike applet Param
+ ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param
embed basefont style span layer ilayer font frameset frame script small big/],
':netscape'=>[qw/blink fontsize center/],
':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
submit reset defaults radio_group popup_menu button autoEscape
scrolling_list image_button start_form end_form startform endform
- start_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
- ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump
- raw_cookie request_method query_string accept user_agent remote_host
+ 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
+ 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_host remote_ident auth_type http use_named_parameters
save_parameters restore_parameters param_fetch
- remote_user user_name header redirect import_names put Delete Delete_all url_param/],
+ remote_user user_name header redirect import_names put
+ Delete Delete_all url_param cgi_error/],
':ssl' => [qw/https/],
- ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/],
+ ':imagemap' => [qw/Area Map/],
+ ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
':html' => [qw/:html2 :html3 :netscape/],
':standard' => [qw/:html2 :html3 :form :cgi/],
':push' => [qw/multipart_init multipart_start multipart_end/],
sub expand_tags {
my($tag) = @_;
+ return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
my(@r);
return ($tag) unless $EXPORT_TAGS{$tag};
foreach (@{$EXPORT_TAGS{$tag}}) {
$name = $p[0];
}
- return () unless defined($name) && $self->{$name};
+ return unless defined($name) && $self->{$name};
return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
}
sub init {
my($self,$initializer) = @_;
my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
+ local($/) = "\n";
# if we get called more than once, we want to initialize
# ourselves from the original query (which may be gone
# if it was read from STDIN originally.)
- if (defined(@QUERY_PARAM) && !defined($initializer)) {
+ if (@QUERY_PARAM && !defined($initializer)) {
foreach (@QUERY_PARAM) {
$self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
}
$meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
$content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
- die "Client attempted to POST $content_length bytes, but POSTs are limited to $POST_MAX"
- if ($POST_MAX > 0) && ($content_length > $POST_MAX);
+
$fh = to_filehandle($initializer) if $initializer;
METHOD: {
+ # avoid unreasonably large postings
+ if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
+ $self->cgi_error("413 Request entity too large");
+ last METHOD;
+ }
+
# Process multipart postings, but only if the initializer is
# not defined.
if ($meth eq 'POST'
&& $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
&& !defined($initializer)
) {
- my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";]+)\"?/;
+ my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
$self->read_multipart($boundary,$content_length);
last METHOD;
}
# If method is GET or HEAD, fetch the query from
# the environment.
if ($meth=~/^(GET|HEAD)$/) {
- $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
+ if ($MOD_PERL) {
+ $query_string = Apache->request->args;
+ } else {
+ $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
+ }
last METHOD;
}
CORE::print(@_);
}
+# get/set last cgi_error
+sub cgi_error {
+ my ($self,$err) = self_or_default(@_);
+ $self->{'.cgi_error'} = $err if defined $err;
+ return $self->{'.cgi_error'};
+}
+
# unescape URL-encoded data
sub unescape {
- shift() if ref($_[0]);
- my $todecode = shift;
- return undef unless defined($todecode);
- $todecode =~ tr/+/ /; # pluses become spaces
- $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
- return $todecode;
+ shift() if ref($_[0]) || $_[0] eq $DefaultClass;
+ my $todecode = shift;
+ return undef unless defined($todecode);
+ $todecode =~ tr/+/ /; # pluses become spaces
+ if ($EBCDIC) {
+ $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",$A2E[hex($1)])/ge;
+ } else {
+ $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
+ }
+ return $todecode;
}
# URL-encode data
shift() if ref($_[0]) || $_[0] eq $DefaultClass;
my $toencode = shift;
return undef unless defined($toencode);
- $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
+ $toencode=~s/ /+/g;
+ $toencode=~s/([^a-zA-Z0-9_.+-])/uc sprintf("%%%02x",ord($1))/eg;
return $toencode;
}
sub parse_params {
my($self,$tosplit) = @_;
- my(@pairs) = split('&',$tosplit);
+ my(@pairs) = split(/[&;]/,$tosplit);
my($param,$value);
foreach (@pairs) {
($param,$value) = split('=',$_,2);
}
sub _make_tag_func {
- my $tagname = shift;
- return qq{
+ my ($self,$tagname) = @_;
+ my $func = qq(
sub $tagname {
- # handle various cases in which we're called
- # most of this bizarre stuff is to avoid -w errors
shift if \$_[0] &&
- (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) ||
+# (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) ||
(ref(\$_[0]) &&
(substr(ref(\$_[0]),0,3) eq 'CGI' ||
UNIVERSAL::isa(\$_[0],'CGI')));
my(\@attr) = make_attributes( '',shift() );
\$attr = " \@attr" if \@attr;
}
+ );
+ if ($tagname=~/start_(\w+)/i) {
+ $func .= qq! return "<\U$1\E\$attr>";} !;
+ } elsif ($tagname=~/end_(\w+)/i) {
+ $func .= qq! return "<\U/$1\E>"; } !;
+ } else {
+ $func .= qq#
my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U</$tagname>\E");
return \$tag unless \@_;
my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
return "\@result";
- }
-}
+ }#;
+ }
+return $func;
}
sub AUTOLOAD {
$code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
if (!$code) {
+ (my $base = $func_name) =~ s/^(start_|end_)//i;
if ($EXPORT{':any'} ||
$EXPORT{'-any'} ||
- $EXPORT{$func_name} ||
+ $EXPORT{$base} ||
(%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
- && $EXPORT_OK{$func_name}) {
- $code = _make_tag_func($func_name);
+ && $EXPORT_OK{$base}) {
+ $code = $CGI::DefaultClass->_make_tag_func($func_name);
}
}
die "Undefined subroutine $AUTOLOAD\n" unless $code;
die $@;
}
}
- delete($sub->{$func_name}); #free storage
+ CORE::delete($sub->{$func_name}); #free storage
return "$pack\:\:$func_name";
}
my $self = shift;
my $compile = 0;
foreach (@_) {
- $NPH++, next if /^[:-]nph$/;
- $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/;
- $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
- $EXPORT{$_}++, next if /^[:-]any$/;
- $compile++, next if /^[:-]compile$/;
+ $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
+ $NPH++, next if /^[:-]nph$/;
+ $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/;
+ $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
+ $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
+ $EXPORT{$_}++, next if /^[:-]any$/;
+ $compile++, next if /^[:-]compile$/;
- # This is probably extremely evil code -- to be deleted
- # some day.
+ # This is probably extremely evil code -- to be deleted some day.
if (/^[-]autoload$/) {
my($pkg) = caller(1);
*{"${pkg}::AUTOLOAD"} = sub {
####
sub delete {
my($self,$name) = self_or_default(@_);
- delete $self->{$name};
- delete $self->{'.fieldnames'}->{$name};
+ CORE::delete $self->{$name};
+ CORE::delete $self->{'.fieldnames'}->{$name};
@{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
return wantarray ? () : undef;
}
my($self,$namespace,$delete) = self_or_default(@_);
$namespace = 'Q' unless defined($namespace);
die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
- if ($delete || $MOD_PERL) {
+ if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
# can anyone find an easier way to do this?
foreach (keys %{"${namespace}::"}) {
local *symbol = "${namespace}::${_}";
sub keywords {
my($self,@values) = self_or_default(@_);
# If values is provided, then we set it.
- $self->{'keywords'}=[@values] if defined(@values);
+ $self->{'keywords'}=[@values] if @values;
my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
@result;
}
# These are some tie() interfaces for compatibility
# with Steve Brenner's cgi-lib.pl routines
+'Vars' => <<'END_OF_FUNC',
+sub Vars {
+ my %in;
+ tie(%in,CGI);
+ return %in if wantarray;
+ return \%in;
+}
+END_OF_FUNC
+
+# These are some tie() interfaces for compatibility
+# with Steve Brenner's cgi-lib.pl routines
'ReadParse' => <<'END_OF_FUNC',
sub ReadParse {
local(*in);
unless (exists($self->{'.url_param'})) {
$self->{'.url_param'}={}; # empty hash
if ($ENV{QUERY_STRING} =~ /=/) {
- my(@pairs) = split('&',$ENV{QUERY_STRING});
+ my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
my($param,$value);
foreach (@pairs) {
($param,$value) = split('=',$_,2);
push(@result,"<UL>");
foreach $value ($self->param($param)) {
$value = $self->escapeHTML($value);
+ $value =~ s/\n/<BR>\n/g;
push(@result,"<LI>$value");
}
push(@result,"</UL>");
$filehandle = to_filehandle($filehandle);
my($param);
local($,) = ''; # set print field separator back to a sane value
+ local($\) = ''; # set output line separator to a sane value
foreach $param ($self->param) {
my($escaped_param) = escape($param);
my($value);
foreach $value ($self->param($param)) {
- print $filehandle "$escaped_param=",escape($value),"\n";
+ print $filehandle "$escaped_param=",escape("$value"),"\n";
}
}
print $filehandle "=\n"; # end of record
my($self,@p) = self_or_default(@_);
my(@header);
+ return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE;
+
my($type,$status,$cookie,$target,$expires,$nph,@other) =
- $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
+ $self->rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
+ STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
$nph ||= $NPH;
# rearrange() was designed for the HTML portion, so we
# need to fix it up a little.
foreach (@other) {
- next unless my($header,$value) = /([^\s=]+)=\"?([^\"]+)\"?/;
+ next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e;
}
- $type = $type || 'text/html';
+ $type ||= 'text/html' unless defined($type);
# Maybe future compatibility. Maybe not.
my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
if ($cookie) {
my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
foreach (@cookie) {
- push(@header,"Set-Cookie: " . (UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_));
+ my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
+ push(@header,"Set-Cookie: $cs") if $cs ne '';
}
}
# if the user indicates an expiration time, then we need
push(@header,"Date: " . expires(0,'http')) if $expires || $cookie;
push(@header,"Pragma: no-cache") if $self->cache();
push(@header,@other);
- push(@header,"Content-Type: $type");
+ push(@header,"Content-Type: $type") if $type ne '';
my $header = join($CRLF,@header)."${CRLF}${CRLF}";
if ($MOD_PERL and not $nph) {
'-nph'=>$nph);
unshift(@o,'-Target'=>$target) if $target;
unshift(@o,'-Cookie'=>$cookie) if $cookie;
+ unshift(@o,'-Type'=>'');
return $self->header(@o);
}
END_OF_FUNC
'-foo'=>'bar', # a trick to allow the '-' to be omitted
ref($style) eq 'ARRAY' ? @$style : %$style);
$type = $stype if $stype;
- push(@result,qq/<LINK REL="stylesheet" HREF="$src">/) if $src;
+ push(@result,qq/<LINK REL="stylesheet" TYPE="$type" HREF="$src">/) if $src;
push(@result,style({'type'=>$type},"<!--\n$code\n-->")) if $code;
} else {
push(@result,style({'type'=>$type},"<!--\n$style\n-->"));
($src,$code,$language) =
$self->rearrange([SRC,CODE,LANGUAGE],
'-foo'=>'bar', # a trick to allow the '-' to be omitted
- ref($style) eq 'ARRAY' ? @$script : %$script);
+ ref($script) eq 'ARRAY' ? @$script : %$script);
} else {
($src,$code,$language) = ('',$script,'JavaScript');
if $code && $language=~/javascript/i;
$code = "<!-- Hide script\n$code\n\# End script hiding -->"
if $code && $language=~/perl/i;
- push(@result,script({@satts},$code));
+ push(@result,script({@satts},$code || ''));
}
@result;
}
}
END_OF_FUNC
+'end_multipart_form' => <<'END_OF_FUNC',
+sub end_multipart_form {
+ &endform;
+}
+END_OF_FUNC
#### Method: start_multipart_form
# synonym for startform
$name = defined($name) ? $self->escapeHTML($name) : '';
my($s) = defined($size) ? qq/ SIZE=$size/ : '';
my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
- my($other) = @other ? " @other" : '';
- return qq/<INPUT TYPE="$tag" NAME="$name" VALUE="$current"$s$m$other>/;
+ my($other) = @other ? " @other" : '';
+ # this entered at cristy's request to fix problems with file upload fields
+ # and WebTV -- not sure it won't break stuff
+ my($value) = $current ne '' ? qq(VALUE="$current") : '';
+ return qq/<INPUT TYPE="$tag" NAME="$name" $value$s$m$other>/;
}
END_OF_FUNC
$the_label = $self->escapeHTML($the_label);
my($other) = @other ? " @other" : '';
$self->register_parameter($name);
- return <<END;
-<INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label
-END
+ return qq{<INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label};
}
END_OF_FUNC
# Escape HTML -- used internally
'escapeHTML' => <<'END_OF_FUNC',
sub escapeHTML {
- my($self,$toencode) = @_;
- $toencode = $self unless ref($self);
+ my ($self,$toencode) = self_or_default(@_);
return undef unless defined($toencode);
return $toencode if ref($self) && $self->{'dontescape'};
sub unescapeHTML {
my $string = ref($_[0]) ? $_[1] : $_[0];
return undef unless defined($string);
- $string=~s/&/&/ig;
- $string=~s/"/\"/ig;
- $string=~s/>/>/ig;
- $string=~s/</</ig;
- $string=~s/&#(\d+);/chr($1)/eg;
- $string=~s/&#[xX]([0-9a-fA-F]);/chr(hex($1))/eg;
+ # thanks to Randal Schwartz for the correct solution to this one
+ $string=~ s[&(.*?);]{
+ local $_ = $1;
+ /^amp$/i ? "&" :
+ /^quot$/i ? '"' :
+ /^gt$/i ? ">" :
+ /^lt$/i ? "<" :
+ /^#(\d+)$/ ? chr($1) :
+ /^#x([0-9a-f]+)$/i ? chr(hex($1)) :
+ $_
+ }gex;
return $string;
}
END_OF_FUNC
# rearrange into a pretty table
$result = "<TABLE>";
my($row,$column);
- unshift(@$colheaders,'') if defined(@$colheaders) && defined(@$rowheaders);
- $result .= "<TR>" if defined(@{$colheaders});
+ unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
+ $result .= "<TR>" if @$colheaders;
foreach (@{$colheaders}) {
$result .= "<TH>$_</TH>";
}
for ($row=0;$row<$rows;$row++) {
$result .= "<TR>";
- $result .= "<TH>$rowheaders->[$row]</TH>" if defined(@$rowheaders);
+ $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders;
for ($column=0;$column<$columns;$column++) {
$result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>"
if defined($elements[$column*$rows + $row]);
} else {
$checked = $default;
}
- # If no check array is specified, check the first by default
- $checked = $values->[0] unless defined($checked) && $checked ne '';
- $name=$self->escapeHTML($name);
-
my(@elements,@values);
-
@values = $self->_set_values_and_labels($values,\$labels,$name);
+ # If no check array is specified, check the first by default
+ $checked = $values[0] unless defined($checked) && $checked ne '';
+ $name=$self->escapeHTML($name);
+
my($other) = @other ? " @other" : '';
foreach (@values) {
my($checkit) = $checked eq $_ ? ' CHECKED' : '';
my $url;
$full++ if !($relative || $absolute);
+ my $path = $self->path_info;
+ my $script_name;
+ if (exists($ENV{REQUEST_URI})) {
+ my $index;
+ $script_name = $ENV{REQUEST_URI};
+ # strip query string
+ substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0;
+ # and path
+ substr($script_name,$index) = '' if $path and ($index = rindex($script_name,$path)) >= 0;
+ } else {
+ $script_name = $self->script_name;
+ }
+
if ($full) {
my $protocol = $self->protocol();
$url = "$protocol://";
unless (lc($protocol) eq 'http' && $port == 80)
|| (lc($protocol) eq 'https' && $port == 443);
}
- $url .= $self->script_name;
+ $url .= $script_name;
} elsif ($relative) {
- ($url) = $self->script_name =~ m!([^/]+)$!;
+ ($url) = $script_name =~ m!([^/]+)$!;
} elsif ($absolute) {
- $url = $self->script_name;
+ $url = $script_name;
}
- $url .= $self->path_info if $path_info and $self->path_info;
+ $url .= $path if $path_info and defined $path;
$url .= "?" . $self->query_string if $query and $self->query_string;
return $url;
}
my($offset);
if (!$time || (lc($time) eq 'now')) {
$offset = 0;
+ } elsif ($time=~/^\d+/) {
+ return $time;
} elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
$offset = ($mult{$2} || 1)*$1;
} else {
# This internal routine creates date strings suitable for use in
# cookies and HTTP headers. (They differ, unfortunately.)
-# Thanks to Fisher Mark for this.
+# Thanks to Mark Fisher for this.
'expires' => <<'END_OF_FUNC',
sub expires {
my($time,$format) = @_;
}
END_OF_FUNC
+#### Method: content_type
+# Returns the content_type string
+####
+'content_type' => <<'END_OF_FUNC',
+sub content_type {
+ return $ENV{'CONTENT_TYPE'};
+}
+END_OF_FUNC
+
#### Method: path_translated
# Return the physical path information provided
# by the URL (if any)
my($eparam) = escape($param);
foreach $value ($self->param($param)) {
$value = escape($value);
+ next unless defined $value;
push(@pairs,"$eparam=$value");
}
}
- return join("&",@pairs);
+ return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
}
END_OF_FUNC
# declares a quantitative score for it.
# This handles MIME type globs correctly.
####
-'accept' => <<'END_OF_FUNC',
-sub accept {
+'Accept' => <<'END_OF_FUNC',
+sub Accept {
my($self,$search) = self_or_CGI(@_);
my(%prefs,$type,$pref,$pat);
sub http {
my ($self,$parameter) = self_or_CGI(@_);
return $ENV{$parameter} if $parameter=~/^HTTP/;
+ $parameter =~ tr/-/_/;
return $ENV{"HTTP_\U$parameter\E"} if $parameter;
my(@p);
foreach (keys %ENV) {
my ($self,$parameter) = self_or_CGI(@_);
return $ENV{HTTPS} unless $parameter;
return $ENV{$parameter} if $parameter=~/^HTTPS/;
+ $parameter =~ tr/-/_/;
return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
my(@p);
foreach (keys %ENV) {
my $filenumber = 0;
while (!$buffer->eof) {
%header = $buffer->readHeader;
- die "Malformed multipart POST\n" unless %header;
+
+ unless (%header) {
+ $self->cgi_error("400 Bad request (malformed multipart POST)");
+ return;
+ }
my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
last UPLOADS;
}
- $tmpfile = new TempFile;
- $tmp = $tmpfile->as_string;
-
- $filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES);
-
+ # choose a relatively unpredictable tmpfile sequence number
+ my $seqno = unpack("%16C*",join('',localtime,values %ENV));
+ for (my $cnt=10;$cnt>0;$cnt--) {
+ next unless $tmpfile = new TempFile($seqno);
+ $tmp = $tmpfile->as_string;
+ last if $filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES);
+ $seqno += int rand(100);
+ }
+ die "CGI open of tmpfile: $!\n" unless $filehandle;
$CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
- chmod 0600,$tmp; # only the owner can tamper with it
my ($data);
+ local($\) = '';
while (defined($data = $buffer->read)) {
print $filehandle $data;
}
}
END_OF_FUNC
+'upload' =><<'END_OF_FUNC',
+sub upload {
+ my($self,$param_name) = self_or_default(@_);
+ my $param = $self->param($param_name);
+ return unless $param;
+ return unless ref($param) && fileno($param);
+ return $param;
+}
+END_OF_FUNC
+
'tmpFileName' => <<'END_OF_FUNC',
sub tmpFileName {
my($self,$filename) = self_or_default(@_);
'asString' => <<'END_OF_FUNC',
sub asString {
my $self = shift;
- my $i = $$self;
- $i=~ s/^\*(\w+::)+//; # get rid of package name
+ # get rid of package name
+ (my $i = $$self) =~ s/^\*(\w+::)+//;
$i =~ s/\\(.)/$1/g;
return $i;
+# BEGIN DEAD CODE
+# This was an extremely clever patch that allowed "use strict refs".
+# Unfortunately it relied on another bug that caused leaky file descriptors.
+# The underlying bug has been fixed, so this no longer works. However
+# "strict refs" still works for some reason.
+# my $self = shift;
+# return ${*{$self}{SCALAR}};
+# END DEAD CODE
}
END_OF_FUNC
my($pack,$name,$file,$delete) = @_;
require Fcntl unless defined &Fcntl::O_RDWR;
++$FH;
- *{$FH} = quotemeta($name);
- sysopen($FH,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL())
- || die "CGI open of $file: $!\n";
+ my $ref = \*{'Fh::' . quotemeta($name)};
+ sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
unlink($file) if $delete;
- return bless \*{$FH},$pack;
+ CORE::delete $Fh::{$FH};
+ return bless $ref,$pack;
}
END_OF_FUNC
package MultipartBuffer;
# how many bytes to read at a time. We use
-# a 5K buffer by default.
-$INITIAL_FILLUNIT = 1024 * 5;
-$TIMEOUT = 10*60; # 10 minute timeout
-$SPIN_LOOP_MAX = 1000; # bug fix for some Netscape servers
+# a 4K buffer by default.
+$INITIAL_FILLUNIT = 1024 * 4;
+$TIMEOUT = 240*60; # 4 hour timeout for big files
+$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
$CRLF=$CGI::CRLF;
#reuse the autoload function
# characters "--" PLUS the Boundary string
# BUG: IE 3.01 on the Macintosh uses just the boundary -- not
- # the two extra spaces. We do a special case here on the user-agent!!!!
- $boundary = "--$boundary" unless CGI::user_agent('MSIE 3\.0[12]; Mac');
+ # the two extra hyphens. We do a special case here on the user-agent!!!!
+ $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac');
} else { # otherwise we find it ourselves
my($old);
\$self->{BUFFER},
$bytesToRead,
$bufferLength);
+ $self->{BUFFER} = '' unless defined $self->{BUFFER};
# An apparent bug in the Apache server causes the read()
# to return zero bytes repeatedly without blocking if the
my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
unless ($TMPDIRECTORY) {
@TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
- "${SL}tmp","${SL}temp","${vol}${SL}Temporary Items",
+ "C:${SL}temp","${SL}tmp","${SL}temp",
+ "${vol}${SL}Temporary Items",
"${SL}WWW_ROOT");
+ unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'};
+
+ #
+ # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
+ # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
+ # : can generate a 'getpwuid() not implemented' exception, even though
+ # : it's never called. Found under DOS/Win with the DJGPP perl port.
+ # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX.
+ unshift(@TEMP,(eval {(getpwuid($<))[7]}).'/tmp') if $CGI::OS eq 'UNIX';
+
foreach (@TEMP) {
do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
}
}
$TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
-$SEQUENCE=0;
$MAXTRIES = 5000;
# cute feature, but overload implementation broke it
'new' => <<'END_OF_FUNC',
sub new {
- my($package) = @_;
- my $directory;
- my $i;
- for ($i = 0; $i < $MAXTRIES; $i++) {
- $directory = sprintf("${TMPDIRECTORY}${SL}CGItemp%d%04d",${$},++$SEQUENCE);
- last if ! -f $directory;
+ my($package,$sequence) = @_;
+ my $filename;
+ for (my $i = 0; $i < $MAXTRIES; $i++) {
+ last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
}
- return bless \$directory;
+ # untaint the darn thing
+ return unless $filename =~ m!^([a-zA-Z0-9_ '":/\\]+)$!;
+ $filename = $1;
+ return bless \$filename;
}
END_OF_FUNC
$MultipartBuffer::CRLF;
$MultipartBuffer::TIMEOUT;
$MultipartBuffer::INITIAL_FILLUNIT;
- $TempFile::SEQUENCE;
EOF
;
}
independent of the others, this allows you to save the state of the
script and restore it later.
-For example, using the object oriented style, here is now you create
+For example, using the object oriented style, here is how you create
a simple "Hello World" HTML page:
- #!/usr/local/bin/pelr
+ #!/usr/local/bin/perl -w
use CGI; # load CGI routines
$q = new CGI; # create new CGI object
print $q->header, # create the HTTP header
into our name space (usually the "standard" functions), and we don't
need to create the CGI object.
- #!/usr/local/bin/pelr
+ #!/usr/local/bin/perl
use CGI qw/:standard/; # load standard CGI routines
print header, # create the HTTP header
start_html('hello world'), # start the HTML
dash. If a dash is present in the first argument, CGI.pm assumes
dashes for the subsequent ones.
-You don't have to use the hyphen at allif you don't want to. After
+You don't have to use the hyphen at all if you don't want to. After
creating a CGI object, call the B<use_named_parameters()> method with
a nonzero value. This will tell CGI.pm that you intend to use named
parameters exclusively:
You can also use a named argument style using the B<-name> argument.
+=head2 FETCHING THE PARAMETER LIST AS A HASH:
+
+ $params = $q->Vars;
+ print $params->{'address'};
+ @foo = split("\0",$params->{'foo'});
+ %params = $q->Vars;
+
+ use CGI ':cgi-lib';
+ $params = Vars;
+
+Many people want to fetch the entire parameter list as a hash in which
+the keys are the names of the CGI parameters, and the values are the
+parameters' values. The Vars() method does this. Called in a scalar
+context, it returns the parameter list as a tied hash reference.
+Changing a key changes the value of the parameter in the underlying
+CGI parameter list. Called in an array context, it returns the
+parameter list as an ordinary hash. This allows you to read the
+contents of the parameter list, but not to change it.
+
+When using this, the thing you must watch out for are multivalued CGI
+parameters. Because a hash cannot distinguish between scalar and
+array context, multivalued parameters will be returned as a packed
+string, separated by the "\0" (null) character. You must split this
+packed string in order to get at the individual values. This is the
+convention introduced long ago by Steve Brenner in his cgi-lib.pl
+module for Perl version 4.
+
+If you wish to use Vars() as a function, import the I<:cgi-lib> set of
+function calls (also see the section on CGI-LIB compatibility).
+
=head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
$query->save(FILEHANDLE)
Whitehead Genome Center's data exchange format "Boulderio", and can be
manipulated and even databased using Boulderio utilities. See
- http://www.genome.wi.mit.edu/genome_software/other/boulder.html
+ http://stein.cshl.org/boulder/
for further details.
If you wish to use this method from the function-oriented (non-OO)
interface, the exported name for this method is B<save_parameters()>.
+=head2 RETRIEVING CGI ERRORS
+
+Errors can occur while processing user input, particularly when
+processing uploaded files. When these errors occur, CGI will stop
+processing and return an empty parameter list. You can test for
+the existence and nature of errors using the I<cgi_error()> function.
+The error messages are formatted as HTTP status codes. You can either
+incorporate the error text into an HTML page, or use it as the value
+of the HTTP status:
+
+ my $error = $q->cgi_error;
+ if ($error) {
+ print $q->header(-status=>$error),
+ $q->start_html('Problems'),
+ $q->h2('Request not processed'),
+ $q->strong($error);
+ exit 0;
+ }
+
+When using the function-oriented interface (see the next section),
+errors may only occur the first time you call I<param()>. Be ready
+for this!
+
=head2 USING THE FUNCTION-ORIENTED INTERFACE
To use the function-oriented interface, you must specify which CGI.pm
$zipcode = param('zipcode');
More frequently, you'll import common sets of functions by referring
-to the gropus by name. All function sets are preceded with a ":"
+to the groups by name. All function sets are preceded with a ":"
character as in ":html3" (for tags defined in the HTML 3 standard).
Here is a list of the function sets you can import:
=item B<:all>
Import all the available methods. For the full list, see the CGI.pm
-code, where the variable %TAGS is defined.
+code, where the variable %EXPORT_TAGS is defined.
=back
Microsoft comes out with a new tag called <GRADIENT> (which causes the
user's desktop to be flooded with a rotating gradient fill until his
machine reboots). You don't need to wait for a new version of CGI.pm
-to start using it immeidately:
+to start using it immediately:
use CGI qw/:standard :html3 gradient/;
print gradient({-start=>'red',-end=>'blue'});
rather than deferred to later. This is useful for scripts that run
for an extended period of time under FastCGI or mod_perl, and for
those destined to be crunched by Malcom Beattie's Perl compiler. Use
-it in conjunction with the methods or method familes you plan to use.
+it in conjunction with the methods or method families you plan to use.
use CGI qw(-compile :standard :html3);
to tell the server that the script is NPH. See the discussion
of NPH scripts below.
+=item -newstyle_urls
+
+Separate the name=value pairs in CGI parameter query strings with
+semicolons rather than ampersands. For example:
+
+ ?name=fred;age=24;favorite_color=3
+
+Semicolon-delimited query strings are always accepted, but will not be
+emitted by self_url() and query_string() unless the -newstyle_urls
+pragma is specified.
+
=item -autoload
This overrides the autoloader so that any function in your program
=item -private_tempfiles
-CGI.pm can process uploaded file. Ordinarily it spools the
-uploaded file to a temporary directory, then deletes the file
-when done. However, this opens the risk of eavesdropping as
-described in the file upload section.
-Another CGI script author could peek at this data during the
-upload, even if it is confidential information. On Unix systems,
-the -private_tempfiles pragma will cause the temporary file to be unlinked as soon
-as it is opened and before any data is written into it,
-eliminating the risk of eavesdropping.
-n
+CGI.pm can process uploaded file. Ordinarily it spools the uploaded
+file to a temporary directory, then deletes the file when done.
+However, this opens the risk of eavesdropping as described in the file
+upload section. Another CGI script author could peek at this data
+during the upload, even if it is confidential information. On Unix
+systems, the -private_tempfiles pragma will cause the temporary file
+to be unlinked as soon as it is opened and before any data is written
+into it, reducing, but not eliminating the risk of eavesdropping
+(there is still a potential race condition). To make life harder for
+the attacker, the program chooses tempfile names by calculating a 32
+bit checksum of the incoming HTTP headers.
+
+To ensure that the temporary file cannot be read by other CGI scripts,
+use suEXEC or a CGI wrapper program to run your script. The temporary
+file is created with mode 0600 (neither world nor group readable).
+
+The temporary directory is selected using the following algorithm:
+
+ 1. if the current user (e.g. "nobody") has a directory named
+ "tmp" in its home directory, use that (Unix systems only).
+
+ 2. if the environment variable TMPDIR exists, use the location
+ indicated.
+
+ 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp,
+ /tmp, /temp, ::Temporary Items, and \WWW_ROOT.
+
+Each of these locations is checked that it is a directory and is
+writable. If not, the algorithm tries the next choice.
+
+=back
+
+=head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS
+
+Many of the methods generate HTML tags. As described below, tag
+functions automatically generate both the opening and closing tags.
+For example:
+
+ print h1('Level 1 Header');
+
+produces
+
+ <H1>Level 1 Header</H1>
+
+There will be some times when you want to produce the start and end
+tags yourself. In this case, you can use the form start_I<tag_name>
+and end_I<tag_name>, as in:
+
+ print start_h1,'Level 1 Header',end_h1;
+
+With a few exceptions (described below), start_I<tag_name> and
+end_I<tag_name> functions are not generated automatically when you
+I<use CGI>. However, you can specify the tags you want to generate
+I<start/end> functions for by putting an asterisk in front of their
+name, or, alternatively, requesting either "start_I<tag_name>" or
+"end_I<tag_name>" in the import list.
+
+Example:
+
+ use CGI qw/:standard *table start_ul/;
+
+In this example, the following functions are generated in addition to
+the standard ones:
+
+=over 4
+
+=item 1. start_table() (generates a <TABLE> tag)
+
+=item 2. end_table() (generates a </TABLE> tag)
+
+=item 3. start_ul() (generates a <UL> tag)
+
+=item 4. end_ul() (generates a </UL> tag)
+
=back
=head1 GENERATING DYNAMIC DOCUMENTS
B<-head> tag. For example, to place the rarely-used <LINK> element in the
head section, use this:
- print $q->start_html(-head=>Link({-rel=>'next',
- -href=>'http://www.capricorn.com/s2.html'}));
+ print start_html(-head=>Link({-rel=>'next',
+ -href=>'http://www.capricorn.com/s2.html'}));
To incorporate multiple HTML elements into the <HEAD> section, just pass an
array reference:
- print $q->start_html(-head=>[
- Link({-rel=>'next',
- -href=>'http://www.capricorn.com/s2.html'}),
- Link({-rel=>'previous',
- -href=>'http://www.capricorn.com/s1.html'})
+ print start_html(-head=>[
+ Link({-rel=>'next',
+ -href=>'http://www.capricorn.com/s2.html'}),
+ Link({-rel=>'previous',
+ -href=>'http://www.capricorn.com/s1.html'})
]
);
);
print $q->(-title=>'The Riddle of the Sphinx',
- -script=>{-language=>'PERLSCRIPT'},
- -code=>'print "hello world!\n;"'
+ -script=>{-language=>'PERLSCRIPT',
+ -code=>'print "hello world!\n;"'}
);
this allows you to specify different source files for different dialects
of JavaScript. Example:
- print $q->start_html(-title=>'The Riddle of the Sphinx',
- -script=>[
- { -language => 'JavaScript1.0',
- -src => '/javascript/utilities10.js'
+ print $q->start_html(-title=>'The Riddle of the Sphinx',
+ -script=>[
+ { -language => 'JavaScript1.0',
+ -src => '/javascript/utilities10.js'
},
- { -language => 'JavaScript1.1',
- -src => '/javascript/utilities11.js'
+ { -language => 'JavaScript1.1',
+ -src => '/javascript/utilities11.js'
},
- { -language => 'JavaScript1.2',
- -src => '/javascript/utilities12.js'
+ { -language => 'JavaScript1.2',
+ -src => '/javascript/utilities12.js'
},
- { -language => 'JavaScript28.2',
- -src => '/javascript/utilities219.js'
+ { -language => 'JavaScript28.2',
+ -src => '/javascript/utilities219.js'
}
]
);
=back
+=head2 MIXING POST AND URL PARAMETERS
+
+ $color = $query->url_param('color');
+
+It is possible for a script to receive CGI parameters in the URL as
+well as in the fill-out form by creating a form that POSTs to a URL
+containing a query string (a "?" mark followed by arguments). The
+B<param()> method will always return the contents of the POSTed
+fill-out form, ignoring the URL's query string. To retrieve URL
+parameters, call the B<url_param()> method. Use it in the same way as
+B<param()>. The main difference is that it allows you to read the
+parameters, but not set them.
+
+
+Under no circumstances will the contents of the URL query string
+interfere with similarly-named CGI parameters in POSTed forms. If you
+try to mix a URL query string with a form submitted with the GET
+method, the results will not be what you expect.
+
=head1 CREATING STANDARD HTML ELEMENTS:
CGI.pm defines general HTML shortcut methods for most, if not all of
print $q->blockquote(
"Many years ago on the island of",
$q->a({href=>"http://crete.org/"},"Crete"),
- "there lived a minotaur named",
+ "there lived a Minotaur named",
$q->strong("Fred."),
),
$q->hr;
Prior to CGI.pm version 2.41, providing an empty ('') string as an
attribute argument was the same as providing undef. However, this has
-changed in order to accomodate those who want to create tags of the form
+changed in order to accommodate those who want to create tags of the form
<IMG ALT="">. The difference is shown in these two pieces of code:
CODE RESULT
Tr
Link
Delete
+ Accept
+ Sub
In addition, start_html(), end_html(), start_form(), end_form(),
start_multipart_form() and all the fill-out form tags are special.
See their respective sections.
+=head2 PRETTY-PRINTING HTML
+
+By default, all the HTML produced by these functions comes out as one
+long line without carriage returns or indentation. This is yuck, but
+it does reduce the size of the documents by 10-20%. To get
+pretty-printed output, please use L<CGI::Pretty>, a subclass
+contributed by Brian Paulsen.
+
=head1 CREATING FILL-OUT FORMS:
I<General note> The various form-creating methods all return strings
print $query->startform(-method=>$method,
-action=>$action,
- -encoding=>$encoding);
+ -enctype=>$encoding);
<... various form stuff ...>
print $query->endform;
method: POST
action: this script
- encoding: application/x-www-form-urlencoded
+ enctype: application/x-www-form-urlencoded
endform() returns the closing </FORM> tag.
-Startform()'s encoding method tells the browser how to package the various
+Startform()'s enctype argument tells the browser how to package the various
fields of the form before sending the form to the server. Two
values are possible:
The optional second parameter is the starting value for the field contents
to be used as the default file name (-default).
-The beta2 version of Netscape 2.0 currently doesn't pay any attention
-to this field, and so the starting value will always be blank. Worse,
-the field loses its "sticky" behavior and forgets its previous
-contents. The starting value field is called for in the HTML
-specification, however, and possibly later versions of Netscape will
-honor it.
+For security reasons, browsers don't pay any attention to this field,
+and so the starting value will always be blank. Worse, the field
+loses its "sticky" behavior and forgets its previous contents. The
+starting value field is called for in the HTML specification, however,
+and possibly some browser will eventually provide support for it.
=item 3.
=back
When the form is processed, you can retrieve the entered filename
-by calling param().
+by calling param():
$filename = $query->param('uploaded_file');
-In Netscape Navigator 2.0, the filename that gets returned is the full
-local filename on the B<remote user's> machine. If the remote user is
-on a Unix machine, the filename will follow Unix conventions:
-
- /path/to/the/file
-
-On an MS-DOS/Windows and OS/2 machines, the filename will follow DOS conventions:
-
- C:\PATH\TO\THE\FILE.MSW
-
-On a Macintosh machine, the filename will follow Mac conventions:
-
- HD 40:Desktop Folder:Sort Through:Reminders
+Different browsers will return slightly different things for the
+name. Some browsers return the filename only. Others return the full
+path to the file, using the path conventions of the user's machine.
+Regardless, the name returned is always the name of the file on the
+I<user's> machine, and is unrelated to the name of the temporary file
+that CGI.pm creates during upload spooling (see below).
The filename returned is also a file handle. You can read the contents
of the file using standard Perl file reading calls:
print OUTFILE $buffer;
}
+However, there are problems with the dual nature of the upload fields.
+If you C<use strict>, then Perl will complain when you try to use a
+string as a filehandle. You can get around this by placing the file
+reading code in a block containing the C<no strict> pragma. More
+seriously, it is possible for the remote user to type garbage into the
+upload field, in which case what you get from param() is not a
+filehandle at all, but a string.
+
+To be safe, use the I<upload()> function (new in version 2.47). When
+called with the name of an upload field, I<upload()> returns a
+filehandle, or undef if the parameter is not a valid filehandle.
+
+ $fh = $query->upload('uploaded_file');
+ while (<$fh>) {
+ print;
+ }
+
+This is the recommended idiom.
+
When a file is uploaded the browser usually sends along some
information along with it in the format of headers. The information
usually includes the MIME content type. Future browsers may send
If you are using a machine that recognizes "text" and "binary" data
modes, be sure to understand when and how to use them (see the Camel book).
-Otherwise you may find that binary files are corrupted during file uploads.
+Otherwise you may find that binary files are corrupted during file
+uploads.
+
+There are occasionally problems involving parsing the uploaded file.
+This usually happens when the user presses "Stop" before the upload is
+finished. In this case, CGI.pm will return undef for the name of the
+uploaded file and set I<cgi_error()> to the string "400 Bad request
+(malformed multipart POST)". This error message is designed so that
+you can incorporate it into a status code to be sent to the browser.
+Example:
+
+ $file = $query->upload('uploaded_file');
+ if (!$file && $query->cgi_error) {
+ print $query->header(-status->$query->cgi_error);
+ exit 0;
+ }
+
+You are free to create a custom HTML page to complain about the error,
+if you wish.
JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
can use the B<-rowheader> and B<-colheader> parameters. Both
of these accept a pointer to an array of headings to use.
The headings are just decorative. They don't reorganize the
-interpetation of the radio buttons -- they're still a single named
+interpretation of the radio buttons -- they're still a single named
unit.
=back
form to its value from the last time the script was called,
NOT necessarily to the defaults.
+Note that this conflicts with the Perl reset() built-in. Use
+CORE::reset() to get the original reset function.
+
=head2 CREATING A DEFAULT BUTTON
print $query->defaults('button_label')
non-Netscape browsers this form element will probably not even
display.
-=head1 NETSCAPE COOKIES
+=head1 HTTP COOKIES
-Netscape browsers versions 1.1 and higher support a so-called
-"cookie" designed to help maintain state within a browser session.
-CGI.pm has several methods that support cookies.
+Netscape browsers versions 1.1 and higher, and all versions of
+Internet Explorer, support a so-called "cookie" designed to help
+maintain state within a browser session. CGI.pm has several methods
+that support cookies.
A cookie is a name=value pair much like the named parameters in a CGI
query string. CGI scripts create one or more cookies and send
This is a time/date string (in a special GMT format) that indicates
when a cookie expires. The cookie will be saved and returned to your
script until this expiration date is reached if the user exits
-Netscape and restarts it. If an expiration date isn't specified, the cookie
-will remain active until the user quits Netscape.
+the browser and restarts it. If an expiration date isn't specified, the cookie
+will remain active until the user quits the browser.
=item 2. a domain
This is a partial or complete domain name for which the cookie is
valid. The browser will return the cookie to any host that matches
the partial domain name. For example, if you specify a domain name
-of ".capricorn.com", then Netscape will return the cookie to
+of ".capricorn.com", then the browser will return the cookie to
Web servers running on any of the machines "www.capricorn.com",
"www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
must contain at least two periods to prevent attempts to match
=back
-The interface to Netscape cookies is the B<cookie()> method:
+The interface to HTTP cookies is the B<cookie()> method:
$cookie = $query->cookie(-name=>'sessionID',
-value=>'xyzzy',
=item B<-name>
The name of the cookie (required). This can be any string at all.
-Although Netscape limits its cookie names to non-whitespace
+Although browsers limit their cookie names to non-whitespace
alphanumeric characters, CGI.pm removes this restriction by escaping
and unescaping cookies behind the scenes.
See the B<cookie.cgi> example script for some ideas on how to use
cookies effectively.
-B<NOTE:> There appear to be some (undocumented) restrictions on
-Netscape cookies. In Netscape 2.01, at least, I haven't been able to
-set more than three cookies at a time. There may also be limits on
-the length of cookies. If you need to store a lot of information,
-it's probably better to create a unique session ID, store it in a
-cookie, and use the session ID to locate an external file/database
-saved on the server's side of the connection.
-
-=head1 WORKING WITH NETSCAPE FRAMES
+=head1 WORKING WITH FRAMES
-It's possible for CGI.pm scripts to write into several browser
-panels and windows using Netscape's frame mechanism.
-There are three techniques for defining new frames programmatically:
+It's possible for CGI.pm scripts to write into several browser panels
+and windows using the HTML 4 frame mechanism. There are three
+techniques for defining new frames programmatically:
=over 4
print $q->header(-target=>'ResultsWindow');
-This will tell Netscape to load the output of your script into the
-frame named "ResultsWindow". If a frame of that name doesn't
-already exist, Netscape will pop up a new window and load your
-script's document into that. There are a number of magic names
-that you can use for targets. See the frame documents on Netscape's
-home pages for details.
+This will tell the browser to load the output of your script into the
+frame named "ResultsWindow". If a frame of that name doesn't already
+exist, the browser will pop up a new window and load your script's
+document into that. There are a number of magic names that you can
+use for targets. See the frame documents on Netscape's home pages for
+details.
=item 3. Specify the destination for the document in the <FORM> tag
</UL>
</UL>
-You can pass a value of 'true' to dump() in order to get it to
-print the results out as plain text, suitable for incorporating
-into a <PRE> section.
-
-As a shortcut, as of version 1.56 you can interpolate the entire CGI
-object into a string and it will be replaced with the a nice HTML dump
-shown above:
+As a shortcut, you can interpolate the entire CGI object into a string
+and it will be replaced with the a nice HTML dump shown above:
$query=new CGI;
print "<H2>Current Values</H2> $query\n";
=over 4
-=item B<accept()>
+=item B<Accept()>
-Return a list of MIME types that the remote browser
-accepts. If you give this method a single argument
-corresponding to a MIME type, as in
-$query->accept('text/html'), it will return a
-floating point value corresponding to the browser's
-preference for this type from 0.0 (don't want) to 1.0.
-Glob types (e.g. text/*) in the browser's accept list
-are handled correctly.
+Return a list of MIME types that the remote browser accepts. If you
+give this method a single argument corresponding to a MIME type, as in
+$query->Accept('text/html'), it will return a floating point value
+corresponding to the browser's preference for this type from 0.0
+(don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept
+list are handled correctly.
+
+Note that the capitalization changed between version 2.43 and 2.44 in
+order to avoid conflict with Perl's accept() function.
=item B<raw_cookie()>
Returns the HTTP_COOKIE variable, an HTTP extension implemented by
-Netscape browsers version 1.1 and higher. Cookies have a special
-format, and this method call just returns the raw form (?cookie
-dough). See cookie() for ways of setting and retrieving cooked
-cookies.
+Netscape browsers version 1.1 and higher, and all versions of Internet
+Explorer. Cookies have a special format, and this method call just
+returns the raw form (?cookie dough). See cookie() for ways of
+setting and retrieving cooked cookies.
Called with no parameters, raw_cookie() returns the packed cookie
structure. You can separate it into individual cookies by splitting
=item B<user_name ()>
-Attempt to obtain the remote user's name, using a variety
-of different techniques. This only works with older browsers
-such as Mosaic. Netscape does not reliably report the user
-name!
+Attempt to obtain the remote user's name, using a variety of different
+techniques. This only works with older browsers such as Mosaic.
+Newer browsers do not report the user name for privacy reasons!
=item B<request_method()>
Returns the method used to access your script, usually
one of 'POST', 'GET' or 'HEAD'.
+=item B<content_type()>
+
+Returns the content_type of data submitted in a POST, generally
+multipart/form-data or application/x-www-form-urlencoded
+
+=item B<http()>
+
+Called with no arguments returns the list of HTTP environment
+variables, including such things as HTTP_USER_AGENT,
+HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the
+like-named HTTP header fields in the request. Called with the name of
+an HTTP header field, returns its value. Capitalization and the use
+of hyphens versus underscores are not significant.
+
+For example, all three of these examples are equivalent:
+
+ $requested_language = $q->http('Accept-language');
+ $requested_language = $q->http('Accept_language');
+ $requested_language = $q->http('HTTP_ACCEPT_LANGUAGE');
+
+=item B<https()>
+
+The same as I<http()>, but operates on the HTTPS environment variables
+present when the SSL protocol is in effect. Can be used to determine
+whether SSL is turned on.
+
=back
=head1 USING NPH SCRIPTS
=back
-Since an attempt to send a POST larger than $POST_MAX bytes
-will cause a fatal error, you might want to use CGI::Carp to echo the
-fatal error message to the browser window as shown in the example
-above. Otherwise the remote user will see only a generic "Internal
-Server" error message. See the L<CGI::Carp> manual page for more
-details.
+An attempt to send a POST larger than $POST_MAX bytes will cause
+I<param()> to return an empty CGI parameter list. You can test for
+this event by checking I<cgi_error()>, either after you create the CGI
+object or, if you are using the function-oriented interface, call
+<param()> for the first time. If the POST was intercepted, then
+cgi_error() will return the message "413 POST too large".
+
+This error message is actually defined by the HTTP protocol, and is
+designed to be returned to the browser as the CGI script's status
+ code. For example:
+
+ $uploaded_file = param('upload');
+ if (!$uploaded_file && cgi_error()) {
+ print header(-status=>cgi_error());
+ exit 0;
+ }
+
+However it isn't clear that any browser currently knows what to do
+with this status code. It might be better just to create an
+HTML page that warns the user of the problem.
=head1 COMPATIBILITY WITH CGI-LIB.PL
-To make it easier to port existing programs that use cgi-lib.pl
-the compatibility routine "ReadParse" is provided. Porting is
-simple:
+To make it easier to port existing programs that use cgi-lib.pl the
+compatibility routine "ReadParse" is provided. Porting is simple:
OLD VERSION
require "cgi-lib.pl";
=head1 AUTHOR INFORMATION
-Copyright 1995-1997, Lincoln D. Stein. All rights reserved. It may
-be used and modified freely, but I do request that this copyright
-notice remain attached to the file. You may modify this module as you
-wish, but if you redistribute a modified version, please attach a note
-listing the modifications you have made.
+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.
-Address bug reports and comments to:
-lstein@genome.wi.mit.edu
+Address bug reports and comments to: lstein@cshl.org. When sending
+bug reports, please provide the version of CGI.pm, the version of
+Perl, the name and version of your Web server, and the name and
+version of the operating system you are using. If the problem is even
+remotely browser dependent, please provide information about the
+affected browers as well.
=head1 CREDITS
=item Joergen Haegg (jh@axis.se)
-=item Laurent Delfosse (delfosse@csgrad1.cs.wvu.edu)
+=item Laurent Delfosse (delfosse@delfosse.com)
=item Richard Resnick (applepi1@aol.com)
-rows=>10,
-columns=>50);
- print "<P>",$query->reset;
+ print "<P>",$query->Reset;
print $query->submit('Action','Shout');
print $query->submit('Action','Scream');
print $query->endform;
=head1 SEE ALSO
L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>,
-L<CGI::Base>, L<CGI::Form>, L<CGI::Apache>, L<CGI::Switch>,
-L<CGI::Push>, L<CGI::Fast>
+L<CGI::Base>, L<CGI::Form>, L<CGI::Push>, L<CGI::Fast>,
+L<CGI::Pretty>
=cut
projects / p5sagit/p5-mst-13.2.git / blobdiff