# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
-$CGI::revision = '$Id: CGI.pm,v 1.5 1998/12/06 10:19:48 lstein Exp $';
-$CGI::VERSION='2.46';
+$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;
}
}
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
# Turn on special checking for Doug MacEachern's modperl
if (exists $ENV{'GATEWAY_INTERFACE'}
&&
- ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/))
+ ($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) {
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 path_info path_translated url self_url script_name cookie Dump
- raw_cookie request_method query_string Accept user_agent remote_host
+ ':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/],
':imagemap' => [qw/Area Map/],
- ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/],
+ ':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/],
$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'
# 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 _make_tag_func {
my ($self,$tagname) = @_;
- my $func = qq#
+ my $func = qq(
sub $tagname {
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) {
die $@;
}
}
- delete($sub->{$func_name}); #free storage
+ CORE::delete($sub->{$func_name}); #free storage
return "$pack\:\:$func_name";
}
####
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}::${_}";
# 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);
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>");
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
'-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;
}
$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'};
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");
}
}
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($\) = '';
}
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(@_);
require Fcntl unless defined &Fcntl::O_RDWR;
++$FH;
my $ref = \*{'Fh::' . quotemeta($name)};
- sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL())
- || die "CGI open of $file: $!\n";
+ sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
unlink($file) if $delete;
- delete $Fh::{$FH};
+ CORE::delete $Fh::{$FH};
return bless $ref,$pack;
}
END_OF_FUNC
# BUG: IE 3.01 on the Macintosh uses just the boundary -- not
# the two extra hyphens. We do a special case here on the user-agent!!!!
- $boundary = "--$boundary" unless CGI::user_agent('MSIE 3\.0[12]; ?Mac');
+ $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac');
} else { # otherwise we find it ourselves
my($old);
my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
unless ($TMPDIRECTORY) {
@TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
- "C:${SL}temp","${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
;
}
For example, using the object oriented style, here is how you create
a simple "Hello World" HTML page:
- #!/usr/local/bin/perl
+ #!/usr/local/bin/perl -w
use CGI; # load CGI routines
$q = new CGI; # create new CGI object
print $q->header, # create the HTTP header
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
=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
=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.
+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
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'
}
]
);
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;
=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
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";
projects / p5sagit/p5-mst-13.2.git / commitdiff