X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCGI.pm;h=e53c9576777643e6eb4875adf7d292f2ac59b700;hb=51cf62d8ec31d46fecbc8564c5b48c17f5776f7f;hp=0c869d726208f3cd2e9119ead21e6c91d327ed92;hpb=38b7982183d856ea25d377fcd59aae2da555ff5b;p=p5sagit%2Fp5-mst-13.2.git
diff --git a/lib/CGI.pm b/lib/CGI.pm
index 0c869d7..e53c957 100644
--- a/lib/CGI.pm
+++ b/lib/CGI.pm
@@ -28,8 +28,15 @@ $AUTOLOAD_DEBUG=0;
# 3) print header(-nph=>1)
$NPH=0;
-$CGI::revision = '$Id: CGI.pm,v 2.32 1997/3/19 10:10 lstein Exp $';
-$CGI::VERSION='2.3202';
+# Set this to 1 to make the temporary files created
+# during file uploads safe from prying eyes
+# or do...
+# 1) use CGI qw(:private_tempfiles)
+# 2) $CGI::private_tempfiles(1);
+$PRIVATE_TEMPFILES=0;
+
+$CGI::revision = '$Id: CGI.pm,v 2.36 1997/5/10 8:22 lstein Exp $';
+$CGI::VERSION='2.36';
# OVERRIDE THE OS HERE IF CGI.pm GUESSES WRONG
# $OS = 'UNIX';
@@ -87,9 +94,7 @@ $SL = {
$NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
# Turn on special checking for Doug MacEachern's modperl
-if (defined($MOD_PERL = $ENV{'GATEWAY_INTERFACE'}) &&
- $MOD_PERL =~ /^CGI-Perl/)
-{
+if (defined($ENV{'GATEWAY_INTERFACE'}) && ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/)) {
$NPH++;
$| = 1;
$SEQNO = 1;
@@ -113,7 +118,7 @@ if ($needs_binmode) {
tt 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/],
- ':html3'=>[qw/div table caption th td TR Tr super sub strike applet PARAM embed basefont/],
+ ':html3'=>[qw/div table caption th td TR Tr super sub strike applet PARAM embed basefont style span/],
':netscape'=>[qw/blink frameset frame script font fontsize center/],
':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
submit reset defaults radio_group popup_menu button autoEscape
@@ -122,7 +127,7 @@ if ($needs_binmode) {
':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
remote_addr referer server_name server_software server_port server_protocol
- virtual_host remote_ident auth_type http
+ virtual_host remote_ident auth_type http use_named_parameters
remote_user user_name header redirect import_names put/],
':ssl' => [qw/https/],
':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/],
@@ -137,6 +142,7 @@ sub import {
my ($callpack, $callfile, $callline) = caller;
foreach (@_) {
$NPH++, next if $_ eq ':nph';
+ $PRIVATE_TEMPFILES++, next if $_ eq ':private_tempfiles';
foreach (&expand_tags($_)) {
tr/a-zA-Z0-9_//cd; # don't allow weird function names
$EXPORT{$_}++;
@@ -548,8 +554,6 @@ sub all_parameters {
return @{$self->{'.parameters'}};
}
-
-
#### Method as_string
#
# synonym for "dump"
@@ -951,8 +955,9 @@ sub header {
# if the user indicates an expiration time, then we need
# both an Expires and a Date header (so that the browser is
# uses OUR clock)
- push(@header,"Expires: " . &expires($expires)) if $expires;
- push(@header,"Date: " . &expires(0)) if $expires;
+ push(@header,"Expires: " . &date(&expire_calc($expires),'http'))
+ if $expires;
+ push(@header,"Date: " . &date(&expire_calc(0),'http')) if $expires || $cookie;
push(@header,"Pragma: no-cache") if $self->cache();
push(@header,@other);
push(@header,"Content-type: $type");
@@ -986,12 +991,11 @@ END_OF_FUNC
'redirect' => <<'END_OF_FUNC',
sub redirect {
my($self,@p) = self_or_default(@_);
- my($url,$target,$cookie,$nph,@other) =
- $self->rearrange([[URI,URL],TARGET,COOKIE,NPH],@p);
+ my($url,$target,$cookie,$nph,@other) = $self->rearrange([[URI,URL],TARGET,COOKIE,NPH],@p);
$url = $url || $self->self_url;
my(@o);
foreach (@other) { push(@o,split("=")); }
- if ($MOD_PERL or exists $self->{'.req'}) {
+ if($MOD_PERL or exists $self->{'.req'}) {
my $r = $self->{'.req'} || Apache->request;
$r->header_out(Location => $url);
$r->err_header_out(Location => $url);
@@ -1021,15 +1025,19 @@ END_OF_FUNC
# $xbase -> (optional) alternative base at some remote location (-xbase)
# $target -> (optional) target window to load all links into (-target)
# $script -> (option) Javascript code (-script)
+# $no_script -> (option) Javascript
END
;
my($other) = @other ? " @other" : '';
@@ -1820,7 +1866,7 @@ END_OF_FUNC
# -path -> paths for which this cookie is valid (optional)
# -domain -> internet domain in which this cookie is valid (optional)
# -secure -> if true, cookie only passed through secure channel (optional)
-# -expires -> expiry date in format Wdy, DD-Mon-YY HH:MM:SS GMT (optional)
+# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
####
'cookie' => <<'END_OF_FUNC',
# temporary, for debugging.
@@ -1869,7 +1915,8 @@ sub cookie {
my(@constant_values);
push(@constant_values,"domain=$domain") if $domain;
push(@constant_values,"path=$path") if $path;
- push(@constant_values,"expires=".&expires($expires)) if $expires;
+ push(@constant_values,"expires=".&date(&expire_calc($expires),'cookie'))
+ if $expires;
push(@constant_values,'secure') if $secure;
my($key) = &escape($name);
@@ -1879,21 +1926,18 @@ sub cookie {
END_OF_FUNC
-# This internal routine creates an expires string exactly some number of
-# hours from the current time in GMT. This is the format
-# required by Netscape cookies, and I think it works for the HTTP
-# Expires: header as well.
-'expires' => <<'END_OF_FUNC',
-sub expires {
+# This internal routine creates an expires time exactly some number of
+# hours from the current time. It incorporates modifications from
+# Fisher Mark.
+'expire_calc' => <<'END_OF_FUNC',
+sub expire_calc {
my($time) = @_;
- my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
- my(@WDAY) = qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/;
my(%mult) = ('s'=>1,
- 'm'=>60,
- 'h'=>60*60,
- 'd'=>60*60*24,
- 'M'=>60*60*24*30,
- 'y'=>60*60*24*365);
+ 'm'=>60,
+ 'h'=>60*60,
+ 'd'=>60*60*24,
+ 'M'=>60*60*24*30,
+ 'y'=>60*60*24*365);
# format for time can be in any of the forms...
# "now" -- expire immediately
# "+180s" -- in 180 seconds
@@ -1907,19 +1951,40 @@ sub expires {
# specifying the date yourself
my($offset);
if (!$time || ($time eq 'now')) {
- $offset = 0;
+ $offset = 0;
} elsif ($time=~/^([+-]?\d+)([mhdMy]?)/) {
- $offset = ($mult{$2} || 1)*$1;
+ $offset = ($mult{$2} || 1)*$1;
} else {
- return $time;
+ return $time;
}
- my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime(time+$offset);
- $year += 1900 unless $year < 100;
- return sprintf("%s, %02d-%s-%02d %02d:%02d:%02d GMT",
- $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
+ return (time+$offset);
}
END_OF_FUNC
+# This internal routine creates date strings suitable for use in
+# cookies and HTTP headers. (They differ, unfortunately.)
+# Thanks to Fisher Mark for this.
+'date' => <<'END_OF_FUNC',
+sub date {
+ my($time,$format) = @_;
+ my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
+ my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
+
+ # pass through preformatted dates for the sake of expire_calc()
+ if ("$time" =~ m/^[^0-9]/o) {
+ return $time;
+ }
+
+ # make HTTP/cookie date string from GMT'ed time
+ # (cookies use '-' as date separator, HTTP uses ' ')
+ my($sc) = ' ';
+ $sc = '-' if $format eq "cookie";
+ my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
+ $year += 1900;
+ return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
+ $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
+}
+END_OF_FUNC
###############################################
# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
@@ -2246,8 +2311,19 @@ END_OF_FUNC
'nph' => <<'END_OF_FUNC',
sub nph {
my ($self,$param) = self_or_CGI(@_);
- $CGI::nph = $param if defined($param);
- return $CGI::nph;
+ $CGI::NPH = $param if defined($param);
+ return $CGI::NPH;
+}
+END_OF_FUNC
+
+#### Method: private_tempfiles
+# Set or return the private_tempfiles global flag
+####
+'private_tempfiles' => <<'END_OF_FUNC',
+sub private_tempfiles {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::$PRIVATE_TEMPFILES = $param if defined($param);
+ return $CGI::PRIVATE_TEMPFILES;
}
END_OF_FUNC
@@ -2330,6 +2406,7 @@ sub read_multipart {
my(%header,$body);
while (!$buffer->eof) {
%header = $buffer->readHeader;
+ die "Malformed multipart POST\n" unless %header;
# In beta1 it was "Content-disposition". In beta2 it's "Content-Disposition"
# Sheesh.
@@ -2357,15 +2434,6 @@ sub read_multipart {
my($tmpfile) = new TempFile;
my $tmp = $tmpfile->as_string;
- open (OUT,">$tmp") || die "CGI open of $tmpfile: $!\n";
- $CGI::DefaultClass->binmode(OUT) if $CGI::needs_binmode;
- chmod 0666,$tmp; # make sure anyone can delete it.
- my $data;
- while ($data = $buffer->read) {
- print OUT $data;
- }
- close OUT;
-
# Now create a new filehandle in the caller's namespace.
# The name of this filehandle just happens to be identical
# to the original filename (NOT the name of the temporary
@@ -2379,9 +2447,26 @@ sub read_multipart {
$filehandle = "\:\:$filename";
}
- open($filehandle,$tmp) || die "CGI open of $tmp: $!\n";
+ # potential security problem -- this type of line can clobber
+ # tempfile, and can be abused by malicious users.
+ # open ($filehandle,">$tmp") || die "CGI open of $tmpfile: $!\n";
+
+ # This technique causes open to fail if file already exists.
+ unless (defined(&O_RDWR)) {
+ require Fcntl;
+ import Fcntl qw/O_RDWR O_CREAT O_EXCL/;
+ }
+ sysopen($filehandle,$tmp,&O_RDWR|&O_CREAT|&O_EXCL) || die "CGI open of $tmp: $!\n";
+ unlink($tmp) if $PRIVATE_TEMPFILES;
+
$CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
+ chmod 0600,$tmp; # only the owner can tamper with it
+ my $data;
+ while (defined($data = $buffer->read)) {
+ print $filehandle $data;
+ }
+ seek($filehandle,0,0); #rewind file
push(@{$self->{$param}},$filename);
# Under Unix, it would be safe to let the temporary file
@@ -2394,7 +2479,7 @@ sub read_multipart {
# asking for $query->{$query->param('foo')}, where 'foo'
# is the name of the file upload field.
$self->{'.tmpfiles'}->{$filename}= {
- name=>$tmpfile,
+ name=>($PRIVATE_TEMPFILES ? '' : $tmpfile),
info=>{%header}
}
}
@@ -2404,7 +2489,9 @@ END_OF_FUNC
'tmpFileName' => <<'END_OF_FUNC',
sub tmpFileName {
my($self,$filename) = self_or_default(@_);
- return $self->{'.tmpfiles'}->{$filename}->{name}->as_string;
+ return $self->{'.tmpfiles'}->{$filename}->{name} ?
+ $self->{'.tmpfiles'}->{$filename}->{name}->as_string
+ : '';
}
END_OF_FUNC
@@ -2468,7 +2555,6 @@ sub new {
# Read the topmost (boundary) line plus the CRLF
my($null) = '';
$length -= $interface->read_from_client($IN,\$null,length($boundary)+2,0);
-
} else { # otherwise we find it ourselves
my($old);
($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
@@ -2497,12 +2583,15 @@ sub readHeader {
my($self) = @_;
my($end);
my($ok) = 0;
+ my($bad) = 0;
do {
$self->fillBuffer($FILLUNIT);
$ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
$ok++ if $self->{BUFFER} eq '';
+ $bad++ if !$ok && $self->{LENGTH} <= 0;
$FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
- } until $ok;
+ } until $ok || $bad;
+ return () if $bad;
my($header) = substr($self->{BUFFER},0,$end+2);
substr($self->{BUFFER},0,$end+4) = '';
@@ -2543,6 +2632,8 @@ sub read {
# Find the boundary in the buffer (it may not be there).
my $start = index($self->{BUFFER},$self->{BOUNDARY});
+ # protect against malformed multipart POST operations
+ die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0);
# If the boundary begins the data, then skip past it
# and return undef. The +2 here is a fiendish plot to
@@ -2598,7 +2689,7 @@ sub fillBuffer {
$bytesToRead,
$bufferLength);
- # An apparent bug in the Netscape Commerce server causes the read()
+ # An apparent bug in the Apache server causes the read()
# to return zero bytes repeatedly without blocking if the
# remote user aborts during a file transfer. I don't know how
# they manage this, but the workaround is to abort if we get
@@ -2728,7 +2819,10 @@ The current version of CGI.pm is available at
http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
-=head1 INSTALLATION:
+=head1 INSTALLATION
+
+CGI is a part of the base Perl installation. However, you may need
+to install a newer version someday. Therefore:
To install this package, just change to the directory in which this
file is found and type the following:
@@ -3143,7 +3237,7 @@ produce both the unofficial Location: header and the official URI:
header. This should satisfy most servers and browsers.
One hint I can offer is that relative links may not work correctly
-when when you generate a redirection to another document on your site.
+when you generate a redirection to another document on your site.
This is due to a well-intentioned optimization that some servers use.
The solution to this is to use the full URL (including the http: part)
of the document you are redirecting to.
@@ -3167,6 +3261,7 @@ expect all their scripts to be NPH.
-target=>'_blank',
-meta=>{'keywords'=>'pharaoh secret mummy',
'copyright'=>'copyright 1996 King Tut'},
+ -style=>{'src'=>'/styles/style1.css'},
-BGCOLOR=>'blue');
-or-
@@ -3205,9 +3300,33 @@ into a series of header tags that look something like this:
There is no support for the HTTP-EQUIV type of tag. This is
because you can modify the HTTP header directly with the B
-method.
+method. For example, if you want to send the Refresh: header, do it
+in the header() method:
+
+ print $q->header(-Refresh=>'10; URL=http://www.capricorn.com');
+
+The B<-style> tag is used to incorporate cascading stylesheets into
+your code. See the section on CASCADING STYLESHEETS for more information.
+
+You can place other arbitrary HTML elements to the section with the
+B<-head> tag. For example, to place the rarely-used element in the
+head section, use this:
+
+ print $q->header(-head=>link({-rel=>'next',
+ -href=>'http://www.capricorn.com/s2.html'}));
-JAVASCRIPTING: The B<-script>, B<-onLoad> and B<-onUnload> parameters
+To incorporate multiple HTML elements into the section, just pass an
+array reference:
+
+ print $q->header(-head=>[ link({-rel=>'next',
+ -href=>'http://www.capricorn.com/s2.html'}),
+ link({-rel=>'previous',
+ -href=>'http://www.capricorn.com/s1.html'})
+ ]
+ );
+
+
+JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad> and B<-onUnload> parameters
are used to add Netscape JavaScript calls to your pages. B<-script>
should point to a block of text containing JavaScript function
definitions. This block will be placed within a