";
return $result;
}
END_OF_FUNC
@@ -1549,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);
@@ -1560,27 +2048,36 @@ sub radio_group {
} else {
$checked = $default;
}
+ 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 $checked;
+ $checked = $values[0] unless defined($checked) && $checked ne '';
$name=$self->escapeHTML($name);
- my(@elements);
- my(@values) = $values ? @$values : $self->param($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) && $labels->{$_};
- $label = $self->escapeHTML($label);
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ $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) unless $columns;
+ return wantarray ? @elements : join(' ',@elements)
+ unless defined($columns) || defined($rows);
return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
}
END_OF_FUNC
@@ -1605,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))) {
@@ -1616,18 +2113,20 @@ sub popup_menu {
$name=$self->escapeHTML($name);
my($other) = @other ? " @other" : '';
- my(@values) = $values ? @$values : $self->param($name);
- $result = qq/";
return $result;
}
END_OF_FUNC
@@ -1657,29 +2156,30 @@ 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);
- my(@values) = $values ? @$values : $self->param($name);
+ my($result,@values);
+ @values = $self->_set_values_and_labels($values,\$labels,$name);
+
$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) && $labels->{$_};
+ $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;
}
@@ -1703,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 ( 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 {
@@ -1721,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);
}
@@ -1742,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
@@ -1760,16 +2262,8 @@ END_OF_FUNC
####
'self_url' => <<'END_OF_FUNC',
sub self_url {
- my($self) = self_or_default(@_);
- my($query_string) = $self->query_string;
- my $protocol = $self->protocol();
- my $name = "$protocol://" . $self->server_name;
- $name .= ":" . $self->server_port
- unless $self->server_port == 80;
- $name .= $self->script_name;
- $name .= $self->path_info if $self->path_info;
- return $name unless $query_string;
- return "$name?$query_string";
+ my($self,@p) = self_or_default(@_);
+ return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
}
END_OF_FUNC
@@ -1789,13 +2283,53 @@ END_OF_FUNC
####
'url' => <<'END_OF_FUNC',
sub url {
- my($self) = self_or_default(@_);
- my $protocol = $self->protocol();
- my $name = "$protocol://" . $self->server_name;
- $name .= ":" . $self->server_port
- unless $self->server_port == 80;
- $name .= $self->script_name;
- return $name;
+ my($self,@p) = self_or_default(@_);
+ my ($relative,$absolute,$full,$path_info,$query,$base) =
+ rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE'],@p);
+ my $url;
+ $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();
+ $url = "$protocol://";
+ my $vh = http('host');
+ if ($vh) {
+ $url .= $vh;
+ } else {
+ $url .= server_name();
+ my $port = $self->server_port;
+ $url .= ":" . $port
+ unless (lc($protocol) eq 'http' && $port == 80)
+ || (lc($protocol) eq 'https' && $port == 443);
+ }
+ return $url if $base;
+ $url .= $script_name;
+ } elsif ($relative) {
+ ($url) = $script_name =~ m!([^/]+)$!;
+ } elsif ($absolute) {
+ $url = $script_name;
+ }
+
+ $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;
}
END_OF_FUNC
@@ -1810,107 +2344,68 @@ 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.
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;
# if no value is supplied, then we retrieve the
# value of the cookie, if any. For efficiency, we cache the parsed
- # cookie in our state variables.
- unless (defined($value)) {
- unless ($self->{'.cookies'}) {
- my(@pairs) = split("; ",$self->raw_cookie);
- foreach (@pairs) {
- my($key,$value) = split("=");
- my(@values) = map unescape($_),split('&',$value);
- $self->{'.cookies'}->{unescape($key)} = [@values];
- }
- }
+ # cookies in our state variables.
+ unless ( defined($value) ) {
+ $self->{'.cookies'} = CGI::Cookie->fetch
+ unless $self->{'.cookies'};
# If no name is supplied, then retrieve the names of all our cookies.
return () unless $self->{'.cookies'};
- return wantarray ? @{$self->{'.cookies'}->{$name}} : $self->{'.cookies'}->{$name}->[0]
- if defined($name) && $name ne '';
- return keys %{$self->{'.cookies'}};
- }
- my(@values);
-
- # Pull out our parameters.
- if (ref($value)) {
- if (ref($value) eq 'ARRAY') {
- @values = @$value;
- } elsif (ref($value) eq 'HASH') {
- @values = %$value;
- }
- } else {
- @values = ($value);
+ return keys %{$self->{'.cookies'}} unless $name;
+ return () unless $self->{'.cookies'}->{$name};
+ return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
}
- @values = map escape($_),@values;
- # I.E. requires the path to be present.
- ($path = $ENV{'SCRIPT_NAME'})=~s![^/]+$!! unless $path;
+ # If we get here, we're creating a new cookie
+ return undef unless defined($name) && $name ne ''; # this is an error
- 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,'secure') if $secure;
+ my @param;
+ push(@param,'-name'=>$name);
+ push(@param,'-value'=>$value);
+ push(@param,'-domain'=>$domain) if $domain;
+ push(@param,'-path'=>$path) if $path;
+ push(@param,'-expires'=>$expires) if $expires;
+ push(@param,'-secure'=>$secure) if $secure;
- my($key) = &escape($name);
- my($cookie) = join("=",$key,join("&",@values));
- return join("; ",$cookie,@constant_values);
+ return new CGI::Cookie(@param);
}
END_OF_FUNC
+'parse_keywordlist' => <<'END_OF_FUNC',
+sub parse_keywordlist {
+ my($self,$tosplit) = @_;
+ $tosplit = unescape($tosplit); # unescape the keywords
+ $tosplit=~tr/+/ /; # pluses to spaces
+ my(@keywords) = split(/\s+/,$tosplit);
+ return @keywords;
+}
+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 {
- 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);
- # 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 || ($time eq 'now')) {
- $offset = 0;
- } elsif ($time=~/^([+-]?\d+)([mhdMy]?)/) {
- $offset = ($mult{$2} || 1)*$1;
- } else {
- return $time;
+'param_fetch' => <<'END_OF_FUNC',
+sub param_fetch {
+ my($self,@p) = self_or_default(@_);
+ my($name) = rearrange([NAME],@p);
+ unless (exists($self->{$name})) {
+ $self->add_parameter($name);
+ $self->{$name} = [];
}
- 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 $self->{$name};
}
END_OF_FUNC
-
###############################################
# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
###############################################
@@ -1921,7 +2416,19 @@ END_OF_FUNC
####
'path_info' => <<'END_OF_FUNC',
sub path_info {
- return $ENV{'PATH_INFO'};
+ my ($self,$info) = self_or_default(@_);
+ if (defined($info)) {
+ $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
+ $self->{'.path_info'} = $info;
+ } elsif (! defined($self->{'.path_info'}) ) {
+ $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ?
+ $ENV{'PATH_INFO'} : '';
+
+ # hack to fix broken path info in IIS
+ $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS;
+
+ }
+ return $self->{'.path_info'};
}
END_OF_FUNC
@@ -1935,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)
@@ -1955,13 +2471,17 @@ sub query_string {
my($self) = self_or_default(@_);
my($param,$value,@pairs);
foreach $param ($self->param) {
- my($eparam) = &escape($param);
+ my($eparam) = escape($param);
foreach $value ($self->param($param)) {
- $value = &escape($value);
+ $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
@@ -1977,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);
@@ -2027,14 +2547,28 @@ sub user_agent {
END_OF_FUNC
-#### Method: cookie
-# Returns the magic cookie for the session.
-# To set the magic cookie for new transations,
-# try print $q->header('-Set-cookie'=>'my cookie')
+#### Method: raw_cookie
+# Returns the magic cookies for the session.
+# The cookies are not parsed or altered in any way, i.e.
+# cookies are returned exactly as given in the HTTP
+# headers. If a cookie name is given, only that cookie's
+# value is returned, otherwise the entire raw cookie
+# is returned.
####
'raw_cookie' => <<'END_OF_FUNC',
sub raw_cookie {
- my($self) = self_or_CGI(@_);
+ my($self,$key) = self_or_CGI(@_);
+
+ require CGI::Cookie;
+
+ if (defined($key)) {
+ $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
+ unless $self->{'.raw_cookies'};
+
+ return () unless $self->{'.raw_cookies'};
+ return () unless $self->{'.raw_cookies'}->{$key};
+ return $self->{'.raw_cookies'}->{$key};
+ }
return $self->http('cookie') || $ENV{'COOKIE'} || '';
}
END_OF_FUNC
@@ -2045,7 +2579,9 @@ END_OF_FUNC
######
'virtual_host' => <<'END_OF_FUNC',
sub virtual_host {
- return http('host') || server_name();
+ my $vh = http('host') || server_name();
+ $vh =~ s/:\d+$//; # get rid of port number
+ return $vh;
}
END_OF_FUNC
@@ -2081,7 +2617,7 @@ END_OF_FUNC
####
'script_name' => <<'END_OF_FUNC',
sub script_name {
- return $ENV{'SCRIPT_NAME'} if $ENV{'SCRIPT_NAME'};
+ return $ENV{'SCRIPT_NAME'} if defined($ENV{'SCRIPT_NAME'});
# These are for debugging
return "/$0" unless $0=~/^\//;
return $0;
@@ -2145,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) {
@@ -2163,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) {
@@ -2179,7 +2717,7 @@ END_OF_FUNC
sub protocol {
local($^W)=0;
my $self = shift;
- return 'https' if $self->https() eq 'ON';
+ return 'https' if uc($self->https()) eq 'ON';
return 'https' if $self->server_port == 443;
my $prot = $self->server_protocol;
my($protocol,$version) = split('/',$prot);
@@ -2230,14 +2768,51 @@ 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
####
'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
+
+#### Method: default_dtd
+# Set or return the default_dtd global
+####
+'default_dtd' => <<'END_OF_FUNC',
+sub default_dtd {
+ 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
@@ -2271,30 +2846,30 @@ END_OF_FUNC
'get_fields' => <<'END_OF_FUNC',
sub get_fields {
my($self) = @_;
- return $self->hidden('-name'=>'.cgifields',
- '-values'=>[keys %{$self->{'.parametersToAdd'}}],
- '-override'=>1);
+ return $self->CGI::hidden('-name'=>'.cgifields',
+ '-values'=>[keys %{$self->{'.parametersToAdd'}}],
+ '-override'=>1);
}
END_OF_FUNC
'read_from_cmdline' => <<'END_OF_FUNC',
sub read_from_cmdline {
- require "shellwords.pl";
my($input,@words);
my($query_string);
- if (@ARGV) {
- $input = join(" ",@ARGV);
- } else {
+ if ($DEBUG && @ARGV) {
+ @words = @ARGV;
+ } elsif ($DEBUG > 1) {
+ require "shellwords.pl";
print STDERR "(offline mode: enter name=value pairs on standard input)\n";
- chomp(@lines = <>); # remove newlines
+ chomp(@lines = ); # remove newlines
$input = join(" ",@lines);
+ @words = &shellwords($input);
+ }
+ foreach (@words) {
+ s/\\=/%3D/g;
+ s/\\&/%26/g;
}
- # minimal handling of escape characters
- $input=~s/\\=/%3D/g;
- $input=~s/\\&/%26/g;
-
- @words = &shellwords($input);
if ("@words"=~/=/) {
$query_string = join('&',@words);
} else {
@@ -2314,94 +2889,124 @@ END_OF_FUNC
#####
'read_multipart' => <<'END_OF_FUNC',
sub read_multipart {
- my($self,$boundary,$length) = @_;
- my($buffer) = $self->new_MultipartBuffer($boundary,$length);
+ my($self,$boundary,$length,$filehandle) = @_;
+ my($buffer) = $self->new_MultipartBuffer($boundary,$length,$filehandle);
return unless $buffer;
my(%header,$body);
+ my $filenumber = 0;
while (!$buffer->eof) {
%header = $buffer->readHeader;
- # In beta1 it was "Content-disposition". In beta2 it's "Content-Disposition"
- # Sheesh.
- my($key) = $header{'Content-disposition'} ? 'Content-disposition' : 'Content-Disposition';
- my($param)= $header{$key}=~/ name="([^\"]*)"/;
+ unless (%header) {
+ $self->cgi_error("400 Bad request (malformed multipart POST)");
+ return;
+ }
+
+ my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
- # possible bug: our regular expression expects the filename= part to fall
- # at the end of the line. Netscape doesn't escape quotation marks in file names!!!
- my($filename) = $header{$key}=~/ filename="(.*)"$/;
+ # Bug: Netscape doesn't escape quotation marks in file names!!!
+ 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;
}
- # If we get here, then we are dealing with a potentially large
- # uploaded form. Save the data to a temporary file, then open
- # the file for reading.
- 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
- # file, which is hidden!)
- my($filehandle);
- if ($filename=~/^[a-zA-Z_]/) {
- my($frame,$cp)=(1);
- do { $cp = caller($frame++); } until !eval("'$cp'->isaCGI()");
- $filehandle = "$cp\:\:$filename";
- } else {
- $filehandle = "\:\:$filename";
- }
+ my ($tmpfile,$tmp,$filehandle);
+ UPLOADS: {
+ # If we get here, then we are dealing with a potentially large
+ # uploaded form. Save the data to a temporary file, then open
+ # the file for reading.
- open($filehandle,$tmp) || die "CGI open of $tmp: $!\n";
- $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
-
- push(@{$self->{$param}},$filename);
-
- # Under Unix, it would be safe to let the temporary file
- # be deleted immediately. However, I fear that other operating
- # systems are not so forgiving. Therefore we save a reference
- # to the temporary file in the CGI object so that the file
- # isn't unlinked until the CGI object itself goes out of
- # scope. This is a bit hacky, but it has the interesting side
- # effect that one can access the name of the tmpfile by
- # asking for $query->{$query->param('foo')}, where 'foo'
- # is the name of the file upload field.
- $self->{'.tmpfiles'}->{$filename}= {
- name=>$tmpfile,
- info=>{%header}
- }
+ # skip the file if uploads disabled
+ if ($DISABLE_UPLOADS) {
+ while (defined($data = $buffer->read)) { }
+ last UPLOADS;
+ }
+
+ # 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;
+
+ my ($data);
+ local($\) = '';
+ while (defined($data = $buffer->read)) {
+ print $filehandle $data;
+ }
+
+ # back up to beginning of file
+ seek($filehandle,0,0);
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
+
+ # Save some information about the uploaded file where we can get
+ # at it later.
+ $self->{'.tmpfiles'}->{fileno($filehandle)}= {
+ name => $tmpfile,
+ info => {%header},
+ };
+ push(@{$self->{$param}},$filehandle);
+ }
}
}
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}->as_string;
+ return $self->{'.tmpfiles'}->{fileno($filename)}->{name} ?
+ $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string
+ : '';
}
END_OF_FUNC
-'uploadInfo' => <<'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
+
+# internal routine, don't use
+'_set_values_and_labels' => <<'END_OF_FUNC',
+sub _set_values_and_labels {
+ my $self = shift;
+ my ($v,$l,$n) = @_;
+ $$l = $v if ref($v) eq 'HASH' && !ref($$l);
+ return $self->param($n) if !defined($v);
+ return $v if !ref($v);
+ return ref($v) eq 'HASH' ? keys %$v : @$v;
+}
+END_OF_FUNC
+
+'_compile_all' => <<'END_OF_FUNC',
+sub _compile_all {
+ foreach (@_) {
+ next if defined(&$_);
+ $AUTOLOAD = "CGI::$_";
+ _compile();
+ }
}
END_OF_FUNC
@@ -2409,30 +3014,102 @@ END_OF_FUNC
END_OF_AUTOLOAD
;
-# Globals and stubs for other packages that we use
-package MultipartBuffer;
+#########################################################
+# Globals and stubs for other packages that we use.
+#########################################################
-# how many bytes to read at a time. We use
-# a 5K buffer by default.
-$FILLUNIT = 1024 * 5;
-$TIMEOUT = 10*60; # 10 minute timeout
-$SPIN_LOOP_MAX = 1000; # bug fix for some Netscape servers
-$CRLF=$CGI::CRLF;
+################### Fh -- lightweight filehandle ###############
+package Fh;
+use overload
+ '""' => \&asString,
+ 'cmp' => \&compare,
+ 'fallback'=>1;
-#reuse the autoload function
-*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
+$FH='fh00000';
+
+*Fh::AUTOLOAD = \&CGI::AUTOLOAD;
-###############################################################################
-################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
-###############################################################################
$AUTOLOADED_ROUTINES = ''; # prevent -w error
$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
%SUBS = (
+'asString' => <<'END_OF_FUNC',
+sub asString {
+ my $self = shift;
+ # 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
-'new' => <<'END_OF_FUNC',
-sub new {
- my($package,$interface,$boundary,$length,$filehandle) = @_;
- my $IN;
+'compare' => <<'END_OF_FUNC',
+sub compare {
+ my $self = shift;
+ my $value = shift;
+ return "$self" cmp $value;
+}
+END_OF_FUNC
+
+'new' => <<'END_OF_FUNC',
+sub new {
+ my($pack,$name,$file,$delete) = @_;
+ require Fcntl unless defined &Fcntl::O_RDWR;
+ (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;
+ CORE::delete $Fh::{$fv};
+ return bless $ref,$pack;
+}
+END_OF_FUNC
+
+'DESTROY' => <<'END_OF_FUNC',
+sub DESTROY {
+ my $self = shift;
+ close $self;
+}
+END_OF_FUNC
+
+);
+END_OF_AUTOLOAD
+
+######################## MultipartBuffer ####################
+package MultipartBuffer;
+
+# how many bytes to read at a time. We use
+# 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
+*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
+
+# avoid autoloader warnings
+sub DESTROY {}
+
+###############################################################################
+################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
+###############################################################################
+$AUTOLOADED_ROUTINES = ''; # prevent -w error
+$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
+%SUBS = (
+
+'new' => <<'END_OF_FUNC',
+sub new {
+ my($package,$interface,$boundary,$length,$filehandle) = @_;
+ $FILLUNIT = $INITIAL_FILLUNIT;
+ my $IN;
if ($filehandle) {
my($package) = caller;
# force into caller's package if necessary
@@ -2450,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
- $boundary = "--$boundary";
- # Read the topmost (boundary) line plus the CRLF
- my($null) = '';
- $length -= $interface->read_from_client($IN,\$null,length($boundary)+2,0);
+
+ # 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\s+3\.0[12];\s*Mac|DreamPassport');
} else { # otherwise we find it ourselves
my($old);
@@ -2466,6 +3144,7 @@ sub new {
$length -= length($boundary);
chomp($boundary); # remove the CRLF
$/ = $old; # restore old line separator
+ $boundary_read++;
}
my $self = {LENGTH=>$length,
@@ -2478,7 +3157,15 @@ sub new {
$FILLUNIT = length($boundary)
if length($boundary) > $FILLUNIT;
- return bless $self,ref $package || $package;
+ my $retval = bless $self,ref $package || $package;
+
+ # Read the preamble and the topmost (boundary) line plus the CRLF.
+ unless ($boundary_read) {
+ while ($self->read(0)) { }
+ }
+ die "Malformed multipart POST\n" if $self->eof;
+
+ return $retval;
}
END_OF_FUNC
@@ -2487,18 +3174,35 @@ sub readHeader {
my($self) = @_;
my($end);
my($ok) = 0;
+ my($bad) = 0;
+
+ local($CRLF) = "\015\012" if $CGI::OS eq 'VMS';
+
do {
$self->fillBuffer($FILLUNIT);
$ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
$ok++ if $self->{BUFFER} eq '';
- $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
- } until $ok;
+ $bad++ if !$ok && $self->{LENGTH} <= 0;
+ # this was a bad idea
+ # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
+ } until $ok || $bad;
+ return () if $bad;
my($header) = substr($self->{BUFFER},0,$end+2);
substr($self->{BUFFER},0,$end+4) = '';
my %return;
- while ($header=~/^([\w-]+): (.*)$CRLF/mog) {
- $return{$1}=$2;
+
+
+ # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
+ # (Folding Long Header Fields), 3.4.3 (Comments)
+ # and 3.4.5 (Quoted-Strings).
+
+ my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
+ $header=~s/$CRLF\s+/ /og; # merge continuation lines
+ while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
+ my ($field_name,$field_value) = ($1,$2); # avoid taintedness
+ $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
+ $return{$field_name}=$field_value;
}
return %return;
}
@@ -2533,10 +3237,11 @@ 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
- # 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.
@@ -2547,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;
}
@@ -2565,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
@@ -2587,8 +3294,9 @@ sub fillBuffer {
\$self->{BUFFER},
$bytesToRead,
$bufferLength);
+ $self->{BUFFER} = '' unless defined $self->{BUFFER};
- # 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
@@ -2621,22 +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","${SL}Temporary Items");
+ @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
+ "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 = "." unless $TMPDIRECTORY;
-$SEQUENCE="CGItemp${$}0000";
+$TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
+$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 ####################
@@ -2647,17 +3377,15 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
'new' => <<'END_OF_FUNC',
sub new {
- my($package) = @_;
- $SEQUENCE++;
- my $directory = "${TMPDIRECTORY}${SL}${SEQUENCE}";
- return bless \$directory;
-}
-END_OF_FUNC
-
-'DESTROY' => <<'END_OF_FUNC',
-sub DESTROY {
- my($self) = @_;
- unlink $$self; # get rid of the file
+ my($package,$sequence) = @_;
+ my $filename;
+ for (my $i = 0; $i < $MAXTRIES; $i++) {
+ last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
+ }
+ # untaint the darn thing
+ return unless $filename =~ m!^([a-zA-Z0-9_ '":/.\$\\-]+)$!;
+ $filename = $1;
+ return bless \$filename;
}
END_OF_FUNC
@@ -2683,13 +3411,12 @@ if ($^W) {
$MultipartBuffer::SPIN_LOOP_MAX;
$MultipartBuffer::CRLF;
$MultipartBuffer::TIMEOUT;
- $MultipartBuffer::FILLUNIT;
- $TempFile::SEQUENCE;
+ $MultipartBuffer::INITIAL_FILLUNIT;
EOF
;
}
-$revision;
+1;
__END__
@@ -2697,66 +3424,215 @@ __END__
CGI - Simple Common Gateway Interface Class
+=head1 SYNOPSIS
+
+ # CGI script that creates a fill-out form
+ # and echoes back its values.
+
+ use CGI qw/:standard/;
+ print header,
+ start_html('A Simple Example'),
+ h1('A Simple Example'),
+ start_form,
+ "What's your name? ",textfield('name'),p,
+ "What's the combination?", p,
+ checkbox_group(-name=>'words',
+ -values=>['eenie','meenie','minie','moe'],
+ -defaults=>['eenie','minie']), p,
+ "What's your favorite color? ",
+ popup_menu(-name=>'color',
+ -values=>['red','green','blue','chartreuse']),p,
+ submit,
+ end_form,
+ hr;
+
+ if (param()) {
+ print "Your name is",em(param('name')),p,
+ "The keywords are: ",em(join(", ",param('words'))),p,
+ "Your favorite color is ",em(param('color')),
+ hr;
+ }
+
=head1 ABSTRACT
-This perl library uses perl5 objects to make it easy to create
-Web fill-out forms and parse their contents. This package
-defines CGI objects, entities that contain the values of the
-current query string and other state variables.
-Using a CGI object's methods, you can examine keywords and parameters
-passed to your script, and create forms whose initial values
-are taken from the current query (thereby preserving state
-information).
+This perl library uses perl5 objects to make it easy to create Web
+fill-out forms and parse their contents. This package defines CGI
+objects, entities that contain the values of the current query string
+and other state variables. Using a CGI object's methods, you can
+examine keywords and parameters passed to your script, and create
+forms whose initial values are taken from the current query (thereby
+preserving state information). The module provides shortcut functions
+that produce boilerplate HTML, reducing typing and coding errors. It
+also provides functionality for some of the more advanced features of
+CGI scripting, including support for file uploads, cookies, cascading
+style sheets, server push, and frames.
+
+CGI.pm also provides a simple function-oriented programming style for
+those who don't need its object-oriented features.
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 DESCRIPTION
-To install this package, just change to the directory in which this
-file is found and type the following:
+=head2 PROGRAMMING STYLE
+
+There are two styles of programming with CGI.pm, an object-oriented
+style and a function-oriented style. In the object-oriented style you
+create one or more CGI objects and then use object methods to create
+the various elements of the page. Each CGI object starts out with the
+list of named parameters that were passed to your CGI script by the
+server. You can modify the objects, save them to a file or database
+and recreate them. Because each object corresponds to the "state" of
+the CGI script, and because each object's parameter list is
+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 how you create
+a simple "Hello World" HTML page:
+
+ #!/usr/local/bin/perl -w
+ use CGI; # load CGI routines
+ $q = new CGI; # create new CGI object
+ print $q->header, # create the HTTP header
+ $q->start_html('hello world'), # start the HTML
+ $q->h1('hello world'), # level 1 header
+ $q->end_html; # end the HTML
+
+In the function-oriented style, there is one default CGI object that
+you rarely deal with directly. Instead you just call functions to
+retrieve CGI parameters, create HTML tags, manage cookies, and so
+on. This provides you with a cleaner programming interface, but
+limits you to using one CGI object at a time. The following example
+prints the same page, but uses the function-oriented interface.
+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/perl
+ use CGI qw/:standard/; # load standard CGI routines
+ print header, # create the HTTP header
+ start_html('hello world'), # start the HTML
+ h1('hello world'), # level 1 header
+ end_html; # end the HTML
+
+The examples in this document mainly use the object-oriented style.
+See HOW TO IMPORT FUNCTIONS for important information on
+function-oriented programming in CGI.pm
+
+=head2 CALLING CGI.PM ROUTINES
+
+Most CGI.pm routines accept several arguments, sometimes as many as 20
+optional ones! To simplify this interface, all routines use a named
+argument calling style that looks like this:
+
+ print $q->header(-type=>'image/gif',-expires=>'+3d');
+
+Each argument name is preceded by a dash. Neither case nor order
+matters in the argument list. -type, -Type, and -TYPE are all
+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.
+
+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
+case, the single argument is the document type.
+
+ print $q->header('text/html');
+
+Other such routines are documented below.
+
+Sometimes named arguments expect a scalar, sometimes a reference to an
+array, and sometimes a reference to a hash. Often, you can pass any
+type of argument and the routine will do whatever is most appropriate.
+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']);
+
+A large number of routines in CGI.pm actually aren't specifically
+defined in the module, but are generated automatically as needed.
+These are the "HTML shortcuts," routines that generate HTML tags for
+use in dynamically-generated pages. HTML tags have both attributes
+(the attribute="value" pairs within the tag itself) and contents (the
+part between the opening and closing pairs.) To distinguish between
+attributes and contents, CGI.pm uses the convention of passing HTML
+attributes as a hash reference as the first argument, and the
+contents, if any, as any subsequent arguments. It works out like
+this:
+
+ Code Generated HTML
+ ---- --------------
+ h1()
+ h1('some','contents');
some contents
+ h1({-align=>left});
+ h1({-align=>left},'contents');
contents
+
+HTML tags are described in more detail later.
+
+Many newcomers to CGI.pm are puzzled by the difference between the
+calling conventions for the HTML shortcuts, which require curly braces
+around the HTML tag attributes, and the calling conventions for other
+routines, which manage to generate attributes without the curly
+brackets. Don't be confused. As a convenience the curly braces are
+optional in all but the HTML shortcuts. If you like, you can use
+curly braces when calling any routine that takes named arguments. For
+example:
+
+ print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
+
+If you use the B<-w> switch, you will be warned that some CGI.pm argument
+names conflict with built-in Perl functions. The most frequent of
+these is the -values argument, used to create multi-valued menus,
+radio button clusters and the like. To get around this warning, you
+have several choices:
- perl Makefile.PL
- make
- make install
+=over 4
-This will copy CGI.pm to your perl library directory for use by all
-perl scripts. You probably must be root to do this. Now you can
-load the CGI routines in your Perl scripts with the line:
+=item 1.
- use CGI;
+Use another name for the argument, if one is available.
+For example, -value is an alias for -values.
+
+=item 2.
-If you don't have sufficient privileges to install CGI.pm in the Perl
-library directory, you can put CGI.pm into some convenient spot, such
-as your home directory, or in cgi-bin itself and prefix all Perl
-scripts that call it with something along the lines of the following
-preamble:
+Change the capitalization, e.g. -Values
- use lib '/home/davis/lib';
- use CGI;
+=item 3.
-If you are using a version of perl earlier than 5.002 (such as NT perl), use
-this instead:
+Put quotes around the argument name, e.g. '-values'
- BEGIN {
- unshift(@INC,'/home/davis/lib');
- }
- use CGI;
+=back
-The CGI distribution also comes with a cute module called L.
-It redefines the die(), warn(), confess() and croak() error routines
-so that they write nicely formatted error messages into the server's
-error log (or to the output stream of your choice). This avoids long
-hours of groping through the error and access logs, trying to figure
-out which CGI script is generating error messages. If you choose,
-you can even have fatal error messages echoed to the browser to avoid
-the annoying and uninformative "Server Error" message.
+Many routines will do something useful with a named argument that it
+doesn't recognize. For example, you can produce non-standard HTTP
+header fields by providing them as named arguments:
-=head1 DESCRIPTION
+ print $q->header(-type => 'text/html',
+ -cost => 'Three smackers',
+ -annoyance_level => 'high',
+ -complaints_to => 'bit bucket');
-=head2 CREATING A NEW QUERY OBJECT:
+This will produce the following nonstandard HTTP header:
+
+ HTTP/1.0 200 OK
+ Cost: Three smackers
+ Annoyance-level: high
+ Complaints-to: bit bucket
+ Content-type: text/html
+
+Notice the way that underscores are translated automatically into
+hyphens. HTML-generating routines perform a different type of
+translation.
+
+This feature allows you to keep up with the rapidly changing HTTP and
+HTML "standards".
+
+=head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
$query = new CGI;
@@ -2767,12 +3643,12 @@ it into a perl5 object called $query.
$query = new CGI(INPUTFILE);
-If you provide a file handle to the new() method, it
-will read parameters from the file (or STDIN, or whatever). The
-file can be in any of the forms describing below under debugging
-(i.e. a series of newline delimited TAG=VALUE pairs will work).
-Conveniently, this type of file is created by the save() method
-(see below). Multiple records can be saved and restored.
+If you provide a file handle to the new() method, it will read
+parameters from the file (or STDIN, or whatever). The file can be in
+any of the forms describing below under debugging (i.e. a series of
+newline delimited TAG=VALUE pairs will work). Conveniently, this type
+of file is created by the save() method (see below). Multiple records
+can be saved and restored.
Perl purists will be pleased to know that this syntax accepts
references to file handles, or even references to filehandle globs,
@@ -2780,6 +3656,18 @@ which is the "official" way to pass a filehandle:
$query = new CGI(\*STDIN);
+You can also initialize the CGI object with a FileHandle or IO::File
+object.
+
+If you are using the function-oriented interface and want to
+initialize CGI state from a file handle, the way to do this is with
+B. This will (re)initialize the
+default CGI object from the indicated file handle.
+
+ open (IN,"test.in") || die;
+ restore_parameters(IN);
+ close IN;
+
You can also initialize the query object from an associative array
reference:
@@ -2792,11 +3680,20 @@ or from a properly formatted, URL-escaped query string:
$query = new CGI('dinosaur=barney&color=purple');
+or from a previously existing CGI object (currently this clones the
+parameter list, but none of the other object-specific fields, such as
+autoescaping):
+
+ $old_query = new CGI;
+ $new_query = new CGI($old_query);
+
To create an empty query, initialize it from an empty string or hash:
- $empty_query = new CGI("");
- -or-
- $empty_query = new CGI({});
+ $empty_query = new CGI("");
+
+ -or-
+
+ $empty_query = new CGI({});
=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
@@ -2810,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.
@@ -2834,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');
@@ -2855,7 +3757,7 @@ in more detail later:
=head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
- $query->append(-name=>;'foo',-values=>['yet','more','values']);
+ $query->append(-name=>'foo',-values=>['yet','more','values']);
This adds a value or list of values to the named parameter. The
values are appended to the end of the parameter if it already exists.
@@ -2884,14 +3786,62 @@ This completely clears a parameter. It sometimes useful for
resetting parameters that you don't want passed down between
script invocations.
+If you are using the function call interface, use "Delete()" instead
+to avoid conflicts with Perl's built-in delete operator.
+
=head2 DELETING ALL PARAMETERS:
-$query->delete_all();
+ $query->delete_all();
This clears the CGI object completely. It might be useful to ensure
that all the defaults are taken when you create a fill-out form.
-=head2 SAVING THE STATE OF THE FORM TO A FILE:
+Use Delete_all() instead if you are using the function call interface.
+
+=head2 DIRECT ACCESS TO THE PARAMETER LIST:
+
+ $q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
+ unshift @{$q->param_fetch(-name=>'address')},'George Munster';
+
+If you need access to the parameter list in a way that isn't covered
+by the methods above, you can obtain a direct reference to it by
+calling the B method with the name of the . This
+will return an array reference to the named parameters, which you then
+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)
@@ -2937,120 +3887,378 @@ 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.
-=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
+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;
+ }
- $myself = $query->self_url;
- print "I'm talking to myself.";
+When using the function-oriented interface (see the next section),
+errors may only occur the first time you call I. Be ready
+for this!
-self_url() will return a URL, that, when selected, will reinvoke
-this script with all its state information intact. This is most
-useful when you want to jump around within the document using
-internal anchors but you don't want to disrupt the current contents
-of the form(s). Something like this will do the trick.
+=head2 USING THE FUNCTION-ORIENTED INTERFACE
- $myself = $query->self_url;
- print "See table 1";
- print "See table 2";
- print "See for yourself";
+To use the function-oriented interface, you must specify which CGI.pm
+routines or sets of routines to import into your script's namespace.
+There is a small overhead associated with this importation, but it
+isn't much.
-If you don't want to get the whole query string, call
-the method url() to return just the URL for the script:
+ use CGI ;
- $myself = $query->url;
- print "No query string in this baby!\n";
+The listed methods will be imported into the current package; you can
+call them directly without creating a CGI object first. This example
+shows how to import the B and B
+methods, and then use them directly:
-You can also retrieve the unprocessed query string with query_string():
+ use CGI 'param','header';
+ print header('text/plain');
+ $zipcode = param('zipcode');
- $the_string = $query->query_string;
+More frequently, you'll import common sets of functions by referring
+to the groups by name. All function sets are preceded with a ":"
+character as in ":html3" (for tags defined in the HTML 3 standard).
-=head2 COMPATIBILITY WITH CGI-LIB.PL
+Here is a list of the function sets you can import:
-To make it easier to port existing programs that use cgi-lib.pl
-the compatibility routine "ReadParse" is provided. Porting is
-simple:
+=over 4
-OLD VERSION
- require "cgi-lib.pl";
- &ReadParse;
- print "The value of the antique is $in{antique}.\n";
+=item B<:cgi>
-NEW VERSION
- use CGI;
- CGI::ReadParse
- print "The value of the antique is $in{antique}.\n";
+Import all CGI-handling methods, such as B, B
+and the like.
-CGI.pm's ReadParse() routine creates a tied variable named %in,
-which can be accessed to obtain the query variables. Like
-ReadParse, you can also provide your own variable. Infrequently
-used features of ReadParse, such as the creation of @in and $in
-variables, are not supported.
+=item B<:form>
-Once you use ReadParse, you can retrieve the query object itself
-this way:
+Import all fill-out form generating methods, such as B.
- $q = $in{CGI};
- print $q->textfield(-name=>'wow',
- -value=>'does this really work?');
+=item B<:html2>
-This allows you to start using the more interesting features
-of CGI.pm without rewriting your old scripts from scratch.
+Import all methods that generate HTML 2.0 standard elements.
+
+=item B<:html3>
+
+Import all methods that generate HTML 3.0 elements (such as
+
, and ).
-=head2 CALLING CGI FUNCTIONS THAT TAKE MULTIPLE ARGUMENTS
+=item B<:html4>
-In versions of CGI.pm prior to 2.0, it could get difficult to remember
-the proper order of arguments in CGI function calls that accepted five
-or six different arguments. As of 2.0, there's a better way to pass
-arguments to the various CGI functions. In this style, you pass a
-series of name=>argument pairs, like this:
+Import all methods that generate HTML 4 elements (such as
+, and ).
- $field = $query->radio_group(-name=>'OS',
- -values=>[Unix,Windows,Macintosh],
- -default=>'Unix');
+=item B<:netscape>
-The advantages of this style are that you don't have to remember the
-exact order of the arguments, and if you leave out a parameter, in
-most cases it will default to some reasonable value. If you provide
-a parameter that the method doesn't recognize, it will usually do
-something useful with it, such as incorporating it into the HTML form
-tag. For example if Netscape decides next week to add a new
-JUSTIFICATION parameter to the text field tags, you can start using
-the feature without waiting for a new version of CGI.pm:
+Import all methods that generate Netscape-specific HTML extensions.
- $field = $query->textfield(-name=>'State',
- -default=>'gaseous',
- -justification=>'RIGHT');
+=item B<:html>
-This will result in an HTML tag that looks like this:
+Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
+'netscape')...
-
+=item B<:standard>
-Parameter names are case insensitive: you can use -name, or -Name or
--NAME. You don't have to use the hyphen 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:
+Import "standard" features, 'html2', 'html3', 'html4', 'form' and 'cgi'.
- $query = new CGI;
- $query->use_named_parameters(1);
- $field = $query->radio_group('name'=>'OS',
- 'values'=>['Unix','Windows','Macintosh'],
- 'default'=>'Unix');
+=item B<:all>
+
+Import all the available methods. For the full list, see the CGI.pm
+code, where the variable %EXPORT_TAGS is defined.
+
+=back
+
+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
+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:
+
+ use CGI qw/:standard :html3 gradient/;
+ print gradient({-start=>'red',-end=>'blue'});
+
+Note that in the interests of execution speed CGI.pm does B use
+the standard L syntax for specifying load symbols. This may
+change in the future.
+
+If you import any of the state-maintaining CGI or form-generating
+methods, a default CGI object will be created and initialized
+automatically the first time you use any of the methods that require
+one to be present. This includes B, B,
+B and the like. (If you need direct access to the CGI
+object, you can find it in the global variable B<$CGI::Q>). By
+importing CGI.pm methods, you can create visually elegant scripts:
+
+ use CGI qw/:standard/;
+ print
+ header,
+ start_html('Simple Script'),
+ h1('Simple Script'),
+ start_form,
+ "What's your name? ",textfield('name'),p,
+ "What's the combination?",
+ checkbox_group(-name=>'words',
+ -values=>['eenie','meenie','minie','moe'],
+ -defaults=>['eenie','moe']),p,
+ "What's your favorite color?",
+ popup_menu(-name=>'color',
+ -values=>['red','green','blue','chartreuse']),p,
+ submit,
+ end_form,
+ hr,"\n";
+
+ if (param) {
+ print
+ "Your name is ",em(param('name')),p,
+ "The keywords are: ",em(join(", ",param('words'))),p,
+ "Your favorite color is ",em(param('color')),".\n";
+ }
+ print end_html;
+
+=head2 PRAGMAS
+
+In addition to the function sets, there are a number of pragmas that
+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 enables debugging mode (pragma
+-debug):
+
+ use CGI qw/:standard -debug/;
+
+The current list of pragmas is as follows:
+
+=over 4
+
+=item -any
+
+When you I