" if defined(@{$colheaders});
+ unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
+ $result .= "
" if @{$colheaders};
foreach (@{$colheaders}) {
- $result .= "
$_
";
+ $result .= "
$_
";
}
for ($row=0;$row<$rows;$row++) {
- $result .= "
";
- $result .= "
$rowheaders->[$row]
" if defined(@$rowheaders);
+ $result .= "
";
+ $result .= "
$rowheaders->[$row]
" if @$rowheaders;
for ($column=0;$column<$columns;$column++) {
- $result .= "
" . $elements[$column*$rows + $row] . "
"
+ $result .= "
" . $elements[$column*$rows + $row] . "
"
if defined($elements[$column*$rows + $row]);
}
- $result .= "
";
+ $result .= "";
}
- $result .= "
";
+ $result .= "
";
return $result;
}
END_OF_FUNC
@@ -1856,7 +2037,7 @@ sub radio_group {
my($name,$values,$default,$linebreak,$labels,
$rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
- $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
+ rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
ROWS,[COLUMNS,COLS],
ROWHEADERS,COLHEADERS,
[OVERRIDE,FORCE],NOLABELS],@p);
@@ -1867,26 +2048,32 @@ sub radio_group {
} 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($break) = $linebreak ? ' ' : '';
+ my($checkit) = $checked eq $_ ? qq/ checked="checked"/ : '';
+ my($break);
+ if ($linebreak) {
+ $break = $XHTML ? " " : " ";
+ }
+ else {
+ $break = '';
+ }
my($label)='';
unless (defined($nolabels) && $nolabels) {
$label = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- $label = $self->escapeHTML($label);
+ $label = $self->escapeHTML($label,1);
}
$_=$self->escapeHTML($_);
- push(@elements,qq/${label}${break}/);
+ push(@elements,$XHTML ? qq(${label}${break})
+ : qq/${label}${break}/);
}
$self->register_parameter($name);
return wantarray ? @elements : join(' ',@elements)
@@ -1915,7 +2102,7 @@ sub popup_menu {
my($self,@p) = self_or_default(@_);
my($name,$values,$default,$labels,$override,@other) =
- $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
+ rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
my($result,$selected);
if (!$override && defined($self->param($name))) {
@@ -1929,17 +2116,17 @@ sub popup_menu {
my(@values);
@values = $self->_set_values_and_labels($values,\$labels,$name);
- $result = qq/";
return $result;
}
END_OF_FUNC
@@ -1969,7 +2156,7 @@ END_OF_FUNC
sub scrolling_list {
my($self,@p) = self_or_default(@_);
my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
- = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
+ = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
my($result,@values);
@@ -1978,21 +2165,21 @@ sub scrolling_list {
$size = $size || scalar(@values);
my(%selected) = $self->previous_or_default($name,$defaults,$override);
- my($is_multiple) = $multiple ? ' MULTIPLE' : '';
- my($has_size) = $size ? " SIZE=$size" : '';
+ my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
+ my($has_size) = $size ? qq/ size="$size"/: '';
my($other) = @other ? " @other" : '';
$name=$self->escapeHTML($name);
- $result = qq/\n/;
+ $result = qq/\n/;
foreach (@values) {
- my($selectit) = $selected{$_} ? 'SELECTED' : '';
+ my($selectit) = $self->_selected($selected{$_});
my($label) = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
$label=$self->escapeHTML($label);
- my($value)=$self->escapeHTML($_);
- $result .= "\n";
}
- $result .= "\n";
+ $result .= "";
$self->register_parameter($name);
return $result;
}
@@ -2016,10 +2203,10 @@ sub hidden {
# calling scheme, so we have to special-case (darn)
my(@result,@value);
my($name,$default,$override,@other) =
- $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
+ rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
my $do_override = 0;
- if ( ref($p[0]) || substr($p[0],0,1) eq '-' || $self->use_named_parameters ) {
+ if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
@value = ref($default) ? @{$default} : $default;
$do_override = $override;
} else {
@@ -2034,8 +2221,9 @@ sub hidden {
$name=$self->escapeHTML($name);
foreach (@value) {
- $_=$self->escapeHTML($_);
- push(@result,qq//);
+ $_ = defined($_) ? $self->escapeHTML($_,1) : '';
+ push @result,$XHTML ? qq()
+ : qq();
}
return wantarray ? @result : join('',@result);
}
@@ -2055,12 +2243,13 @@ sub image_button {
my($self,@p) = self_or_default(@_);
my($name,$src,$alignment,@other) =
- $self->rearrange([NAME,SRC,ALIGN],@p);
+ rearrange([NAME,SRC,ALIGN],@p);
- my($align) = $alignment ? " ALIGN=\U$alignment" : '';
+ my($align) = $alignment ? " align=\U\"$alignment\"" : '';
my($other) = @other ? " @other" : '';
$name=$self->escapeHTML($name);
- return qq//;
+ return $XHTML ? qq()
+ : qq//;
}
END_OF_FUNC
@@ -2095,10 +2284,25 @@ END_OF_FUNC
'url' => <<'END_OF_FUNC',
sub url {
my($self,@p) = self_or_default(@_);
- my ($relative,$absolute,$full,$path_info,$query) =
- $self->rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING']],@p);
+ my ($relative,$absolute,$full,$path_info,$query,$base) =
+ rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE'],@p);
my $url;
- $full++ if !($relative || $absolute);
+ $full++ if $base || !($relative || $absolute);
+
+ my $path = $self->path_info;
+ my $script_name = $self->script_name;
+
+ # for compatibility with Apache's MultiViews
+ if (exists($ENV{REQUEST_URI})) {
+ my $index;
+ $script_name = $ENV{REQUEST_URI};
+ $script_name =~ s/\?.+$//; # strip query string
+ # and path
+ if (exists($ENV{PATH_INFO})) {
+ (my $encoded_path = $ENV{PATH_INFO}) =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
+ $script_name =~ s/$encoded_path$//i;
+ }
+ }
if ($full) {
my $protocol = $self->protocol();
@@ -2113,14 +2317,18 @@ sub url {
unless (lc($protocol) eq 'http' && $port == 80)
|| (lc($protocol) eq 'https' && $port == 443);
}
- $url .= $self->script_name;
+ return $url if $base;
+ $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;
+ $url = '' unless defined $url;
+ $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
return $url;
}
@@ -2142,7 +2350,7 @@ END_OF_FUNC
sub cookie {
my($self,@p) = self_or_default(@_);
my($name,$value,$path,$domain,$secure,$expires) =
- $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
+ rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
require CGI::Cookie;
@@ -2161,7 +2369,7 @@ sub cookie {
}
# If we get here, we're creating a new cookie
- return undef unless $name; # this is an error
+ return undef unless defined($name) && $name ne ''; # this is an error
my @param;
push(@param,'-name'=>$name);
@@ -2175,67 +2383,6 @@ sub cookie {
}
END_OF_FUNC
-# This internal routine creates an expires time exactly some number of
-# hours from the current time. It incorporates modifications from
-# Mark Fisher.
-'expire_calc' => <<'END_OF_FUNC',
-sub expire_calc {
- my($time) = @_;
- my(%mult) = ('s'=>1,
- '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
- # "+2m" -- in 2 minutes
- # "+12h" -- in 12 hours
- # "+1d" -- in 1 day
- # "+3M" -- in 3 months
- # "+2y" -- in 2 years
- # "-3m" -- 3 minutes ago(!)
- # If you don't supply one of these forms, we assume you are
- # specifying the date yourself
- my($offset);
- if (!$time || (lc($time) eq 'now')) {
- $offset = 0;
- } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
- $offset = ($mult{$2} || 1)*$1;
- } else {
- return $time;
- }
- 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.
-'expires' => <<'END_OF_FUNC',
-sub expires {
- my($time,$format) = @_;
- $format ||= 'http';
-
- 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()
- $time = expire_calc($time);
- return $time unless $time =~ /^\d+$/;
-
- # 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
-
'parse_keywordlist' => <<'END_OF_FUNC',
sub parse_keywordlist {
my($self,$tosplit) = @_;
@@ -2249,7 +2396,7 @@ END_OF_FUNC
'param_fetch' => <<'END_OF_FUNC',
sub param_fetch {
my($self,@p) = self_or_default(@_);
- my($name) = $self->rearrange([NAME],@p);
+ my($name) = rearrange([NAME],@p);
unless (exists($self->{$name})) {
$self->add_parameter($name);
$self->{$name} = [];
@@ -2295,6 +2442,15 @@ sub request_method {
}
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)
@@ -2318,10 +2474,14 @@ sub query_string {
my($eparam) = escape($param);
foreach $value ($self->param($param)) {
$value = escape($value);
+ next unless defined $value;
push(@pairs,"$eparam=$value");
}
}
- return join("&",@pairs);
+ foreach (keys %{$self->{'.fieldnames'}}) {
+ push(@pairs,".cgifields=".escape("$_"));
+ }
+ return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
}
END_OF_FUNC
@@ -2337,8 +2497,8 @@ 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);
@@ -2521,6 +2681,7 @@ END_OF_FUNC
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) {
@@ -2539,6 +2700,7 @@ sub https {
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) {
@@ -2606,6 +2768,17 @@ sub user_name {
}
END_OF_FUNC
+#### Method: nosticky
+# Set or return the NOSTICKY global flag
+####
+'nosticky' => <<'END_OF_FUNC',
+sub nosticky {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::NOSTICKY = $param if defined($param);
+ return $CGI::NOSTICKY;
+}
+END_OF_FUNC
+
#### Method: nph
# Set or return the NPH global flag
####
@@ -2633,8 +2806,12 @@ END_OF_FUNC
####
'default_dtd' => <<'END_OF_FUNC',
sub default_dtd {
- my ($self,$param) = self_or_CGI(@_);
- $CGI::DEFAULT_DTD = $param if defined($param);
+ my ($self,$param,$param2) = self_or_CGI(@_);
+ if (defined $param2 && defined $param) {
+ $CGI::DEFAULT_DTD = [ $param, $param2 ];
+ } elsif (defined $param) {
+ $CGI::DEFAULT_DTD = $param;
+ }
return $CGI::DEFAULT_DTD;
}
END_OF_FUNC
@@ -2679,9 +2856,9 @@ END_OF_FUNC
sub read_from_cmdline {
my($input,@words);
my($query_string);
- if (@ARGV) {
+ if ($DEBUG && @ARGV) {
@words = @ARGV;
- } else {
+ } elsif ($DEBUG > 1) {
require "shellwords.pl";
print STDERR "(offline mode: enter name=value pairs on standard input)\n";
chomp(@lines = ); # remove newlines
@@ -2719,19 +2896,23 @@ sub read_multipart {
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="?([^\";]*)"?/;
# Bug: Netscape doesn't escape quotation marks in file names!!!
- my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/;
+ my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\"]*)"?/;
# add this parameter to our list
$self->add_parameter($param);
# If no filename specified, then just read the data and assign it
# to our parameter list.
- unless ($filename) {
+ if ( !defined($filename) || $filename eq '' ) {
my($value) = $buffer->readBody;
push(@{$self->{$param}},$value);
next;
@@ -2749,15 +2930,19 @@ sub read_multipart {
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 CGITempFile($seqno);
+ $tmp = $tmpfile->as_string;
+ last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
+ $seqno += int rand(100);
+ }
+ die "CGI open of tmpfile: $!\n" unless defined $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;
}
@@ -2768,7 +2953,7 @@ sub read_multipart {
# Save some information about the uploaded file where we can get
# at it later.
- $self->{'.tmpfiles'}->{$filename}= {
+ $self->{'.tmpfiles'}->{fileno($filehandle)}= {
name => $tmpfile,
info => {%header},
};
@@ -2778,11 +2963,20 @@ sub read_multipart {
}
END_OF_FUNC
+'upload' =><<'END_OF_FUNC',
+sub upload {
+ my($self,$param_name) = self_or_default(@_);
+ my @param = grep(ref && fileno($_), $self->param($param_name));
+ return unless @param;
+ return wantarray ? @param : $param[0];
+}
+END_OF_FUNC
+
'tmpFileName' => <<'END_OF_FUNC',
sub tmpFileName {
my($self,$filename) = self_or_default(@_);
- return $self->{'.tmpfiles'}->{$filename}->{name} ?
- $self->{'.tmpfiles'}->{$filename}->{name}->as_string
+ return $self->{'.tmpfiles'}->{fileno($filename)}->{name} ?
+ $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string
: '';
}
END_OF_FUNC
@@ -2790,7 +2984,7 @@ END_OF_FUNC
'uploadInfo' => <<'END_OF_FUNC',
sub uploadInfo {
my($self,$filename) = self_or_default(@_);
- return $self->{'.tmpfiles'}->{$filename}->{info};
+ return $self->{'.tmpfiles'}->{fileno($filename)}->{info};
}
END_OF_FUNC
@@ -2841,10 +3035,18 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
'asString' => <<'END_OF_FUNC',
sub asString {
my $self = shift;
- my $i = $$self;
- $i=~ s/^\*(\w+::)+//; # get rid of package name
- $i =~ s/\\(.)/$1/g;
+ # get rid of package name
+ (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
+ $i =~ s/%(..)/ chr(hex($1)) /eg;
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
@@ -2860,12 +3062,13 @@ END_OF_FUNC
sub new {
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 $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
+ my $fv = ++$FH . $safename;
+ my $ref = \*{"Fh::$fv"};
+ 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::{$fv};
+ return bless $ref,$pack;
}
END_OF_FUNC
@@ -2883,10 +3086,10 @@ END_OF_AUTOLOAD
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
@@ -2924,14 +3127,15 @@ sub new {
# Netscape seems to be a little bit unreliable
# about providing boundary strings.
+ my $boundary_read = 0;
if ($boundary) {
# Under the MIME spec, the boundary consists of the
# 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|DreamPassport');
} else { # otherwise we find it ourselves
my($old);
@@ -2940,6 +3144,7 @@ sub new {
$length -= length($boundary);
chomp($boundary); # remove the CRLF
$/ = $old; # restore old line separator
+ $boundary_read++;
}
my $self = {LENGTH=>$length,
@@ -2955,7 +3160,9 @@ sub new {
my $retval = bless $self,ref $package || $package;
# Read the preamble and the topmost (boundary) line plus the CRLF.
- while ($self->read(0)) { }
+ unless ($boundary_read) {
+ while ($self->read(0)) { }
+ }
die "Malformed multipart POST\n" if $self->eof;
return $retval;
@@ -2969,9 +3176,7 @@ sub readHeader {
my($ok) = 0;
my($bad) = 0;
- if ($CGI::OS eq 'VMS') { # tssk, tssk: inconsistency alert!
- local($CRLF) = "\015\012";
- }
+ local($CRLF) = "\015\012" if $CGI::OS eq 'VMS';
do {
$self->fillBuffer($FILLUNIT);
@@ -3036,8 +3241,7 @@ sub read {
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
- # remove the CR/LF pair at the end of the boundary.
+ # and return undef.
if ($start == 0) {
# clear us out completely if we've hit the last boundary.
@@ -3048,7 +3252,8 @@ sub read {
}
# just remove the boundary.
- substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
+ substr($self->{BUFFER},0,length($self->{BOUNDARY}))='';
+ $self->{BUFFER} =~ s/^\012\015?//;
return undef;
}
@@ -3066,7 +3271,8 @@ sub read {
substr($self->{BUFFER},0,$bytesToReturn)='';
# If we hit the boundary, remove the CRLF from the end.
- return ($start > 0) ? substr($returnval,0,-2) : $returnval;
+ return (($start > 0) && ($start <= $bytes))
+ ? substr($returnval,0,-2) : $returnval;
}
END_OF_FUNC
@@ -3088,6 +3294,7 @@ sub fillBuffer {
\$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
@@ -3122,27 +3329,44 @@ END_OF_AUTOLOAD
####################################################################################
################################## TEMPORARY FILES #################################
####################################################################################
-package TempFile;
+package CGITempFile;
$SL = $CGI::SL;
$MAC = $CGI::OS eq 'MACINTOSH';
my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
unless ($TMPDIRECTORY) {
@TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
- "${SL}tmp","${SL}temp","${vol}${SL}Temporary Items",
- "${SL}WWW_ROOT");
+ "C:${SL}temp","${SL}tmp","${SL}temp",
+ "${vol}${SL}Temporary Items",
+ "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH",
+ "C:${SL}system${SL}temp");
+ unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'};
+
+ # this feature was supposed to provide per-user tmpfiles, but
+ # it is problematic.
+ # 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' and $> != 0;
+
foreach (@TEMP) {
do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
}
}
$TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
-$SEQUENCE=0;
$MAXTRIES = 5000;
# cute feature, but overload implementation broke it
# %OVERLOAD = ('""'=>'as_string');
-*TempFile::AUTOLOAD = \&CGI::AUTOLOAD;
+*CGITempFile::AUTOLOAD = \&CGI::AUTOLOAD;
+
+sub DESTROY {
+ my($self) = @_;
+ unlink $$self; # get rid of the file
+}
###############################################################################
################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
@@ -3153,21 +3377,15 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
'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;
-}
-END_OF_FUNC
-
-'DESTROY' => <<'END_OF_FUNC',
-sub DESTROY {
- my($self) = @_;
- unlink $$self; # get rid of the file
+ # untaint the darn thing
+ return unless $filename =~ m!^([a-zA-Z0-9_ '":/.\$\\-]+)$!;
+ $filename = $1;
+ return bless \$filename;
}
END_OF_FUNC
@@ -3194,7 +3412,6 @@ if ($^W) {
$MultipartBuffer::CRLF;
$MultipartBuffer::TIMEOUT;
$MultipartBuffer::INITIAL_FILLUNIT;
- $TempFile::SEQUENCE;
EOF
;
}
@@ -3294,7 +3511,7 @@ The main differences are that we now need to import a set of functions
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
@@ -3319,17 +3536,6 @@ acceptable. In fact, only the first argument needs to begin with a
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 all if you don't want to. After
-creating a CGI object, call the B method with
-a nonzero value. This will tell CGI.pm that you intend to use named
-parameters exclusively:
-
- $query = new CGI;
- $query->use_named_parameters(1);
- $field = $query->radio_group('name'=>'OS',
- 'values'=>['Unix','Windows','Macintosh'],
- 'default'=>'Unix');
-
Several routines are commonly called with just one argument. In the
case of these routines you can provide the single argument without an
argument name. header() happens to be one of these routines. In this
@@ -3346,7 +3552,7 @@ For example, the param() routine is used to set a CGI parameter to a
single or a multi-valued value. The two cases are shown below:
$q->param(-name=>'veggie',-value=>'tomato');
- $q->param(-name=>'veggie',-value=>'[tomato','tomahto','potato','potahto']);
+ $q->param(-name=>'veggie',-value=>['tomato','tomahto','potato','potahto']);
A large number of routines in CGI.pm actually aren't specifically
defined in the module, but are generated automatically as needed.
@@ -3361,10 +3567,10 @@ this:
Code Generated HTML
---- --------------
- h1()
- h1('some','contents');
some contents
- h1({-align=>left});
- h1({-align=>left},'contents');
contents
+ h1()
+ h1('some','contents');
some contents
+ h1({-align=>left});
+ h1({-align=>left},'contents');
contents
HTML tags are described in more detail later.
@@ -3387,12 +3593,18 @@ have several choices:
=over 4
-=item 1. Use another name for the argument, if one is available. For
-example, -value is an alias for -values.
+=item 1.
+
+Use another name for the argument, if one is available.
+For example, -value is an alias for -values.
+
+=item 2.
+
+Change the capitalization, e.g. -Values
-=item 2. Change the capitalization, e.g. -Values
+=item 3.
-=item 3. Put quotes around the argument name, e.g. '-values'
+Put quotes around the argument name, e.g. '-values'
=back
@@ -3495,10 +3707,11 @@ parsed keywords can be obtained as an array using the keywords() method.
@names = $query->param
If the script was invoked with a parameter list
-(e.g. "name1=value1&name2=value2&name3=value3"), the param()
-method will return the parameter names as a list. If the
-script was invoked as an script, there will be a
-single parameter named 'keywords'.
+(e.g. "name1=value1&name2=value2&name3=value3"), the param() method
+will return the parameter names as a list. If the script was invoked
+as an script and contains a string without ampersands
+(e.g. "value1+value2+value3") , there will be a single parameter named
+"keywords" containing the "+"-delimited keywords.
NOTE: As of version 1.5, the array of parameter names returned will
be in the same order as they were submitted by the browser.
@@ -3519,6 +3732,10 @@ named parameter. If the parameter is multivalued (e.g. from multiple
selections in a scrolling list), you can ask to receive an array. Otherwise
the method will return a single value.
+If a value is not given in the query string, as in the queries
+"name1=&name2=" or "name1&name2", it will be returned as an empty
+string. This feature is new in 2.63.
+
=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
$query->param('foo','an','array','of','values');
@@ -3594,6 +3811,36 @@ can manipulate in any way you like.
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 a list 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
+list 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)
@@ -3640,14 +3887,37 @@ a short example of creating multiple session records:
The file format used for save/restore is identical to that used by the
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.
+=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 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. Be ready
+for this!
+
=head2 USING THE FUNCTION-ORIENTED INTERFACE
To use the function-oriented interface, you must specify which CGI.pm
@@ -3689,9 +3959,14 @@ Import all methods that generate HTML 2.0 standard elements.
=item B<:html3>
-Import all methods that generate HTML 3.0 proposed elements (such as
+Import all methods that generate HTML 3.0 elements (such as
, and ).
+=item B<:html4>
+
+Import all methods that generate HTML 4 elements (such as
+, and ).
+
=item B<:netscape>
Import all methods that generate Netscape-specific HTML extensions.
@@ -3703,12 +3978,12 @@ Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
=item B<:standard>
-Import "standard" features, 'html2', 'html3', 'form' and 'cgi'.
+Import "standard" features, 'html2', 'html3', 'html4', 'form' and 'cgi'.
=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
@@ -3716,7 +3991,7 @@ If you import a function name that is not part of CGI.pm, the module
will treat it as a new HTML tag and generate the appropriate
subroutine. You can then use it like any other HTML tag. This is to
provide for the rapidly-evolving HTML "standard." For example, say
-Microsoft comes out with a new tag called (which causes the
+Microsoft comes out with a new tag called (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 immediately:
@@ -3769,10 +4044,10 @@ you can import. Pragmas, which are always preceded by a hyphen,
change the way that CGI.pm functions in various ways. Pragmas,
function sets, and individual functions can all be imported in the
same use() line. For example, the following use statement imports the
-standard set of functions and disables debugging mode (pragma
--no_debug):
+standard set of functions and enables debugging mode (pragma
+-debug):
- use CGI qw/:standard -no_debug/;
+ use CGI qw/:standard -debug/;
The current list of pragmas is as follows:
@@ -3812,6 +4087,25 @@ the effect of importing the compiled functions into the current
namespace. If you want to compile without importing use the
compile() method instead (see below).
+=item -nosticky
+
+This makes CGI.pm not generating the hidden fields .submit
+and .cgifields. It is very useful if you don't want to
+have the hidden fields appear in the querystring in a GET method.
+For example, a search script generated this way will have
+a very nice url with search parameters for bookmarking.
+
+=item -no_undef_params
+
+This keeps CGI.pm from including undef params in the parameter list.
+
+=item -no_xhtml
+
+By default, CGI.pm versions 2.69 and higher emit XHTML
+(http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this
+feature. Thanks to Michalis Kabrianis for this
+feature.
+
=item -nph
This makes CGI.pm produce a header appropriate for an NPH (no
@@ -3819,6 +4113,24 @@ parsed header) script. You may need to do other things as well
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.
+
+This became the default in version 2.64.
+
+=item -oldstyle_urls
+
+Separate the name=value pairs in CGI parameter query strings with
+ampersands rather than semicolons. This is no longer the default.
+
=item -autoload
This overrides the autoloader so that any function in your program
@@ -3835,31 +4147,96 @@ to the top of your script.
This turns off the command-line processing features. If you want to
run a CGI.pm script from the command line to produce HTML, and you
-don't want it pausing to request CGI parameters from standard input or
-the command line, then use this pragma:
+don't want it to read CGI parameters from the command line or STDIN,
+then use this pragma:
use CGI qw(-no_debug :standard);
-If you'd like to process the command-line parameters but not standard
-input, this should work:
+=item -debug
+
+This turns on full debugging. In addition to reading CGI arguments
+from the command-line processing, CGI.pm will pause and try to read
+arguments from STDIN, producing the message "(offline mode: enter
+name=value pairs on standard input)" features.
- use CGI qw(-no_debug :standard);
- restore_parameters(join('&',@ARGV));
-
See the section on debugging for more details.
=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
+
+
Level 1 Header
+
+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
+and end_I, as in:
+
+ print start_h1,'Level 1 Header',end_h1;
+
+With a few exceptions (described below), start_I and
+end_I functions are not generated automatically when you
+I