package CGI;
require 5.004;
+use Carp 'croak';
# See the bottom of this file for the POD documentation. Search for the
# string '=head'.
# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
-$CGI::revision = '$Id: CGI.pm,v 1.39 2000/07/28 03:00:03 lstein Exp $';
-$CGI::VERSION='2.70';
+$CGI::revision = '$Id: CGI.pm,v 1.49 2001/02/04 23:08:39 lstein Exp $';
+$CGI::VERSION='2.753';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
# $TempFile::TMPDIRECTORY = '/usr/tmp';
use CGI::Util qw(rearrange make_attributes unescape escape expires);
-use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
- 'DTD/xhtml1-transitional.dtd'];
+use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
+ 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
# >>>>> Here are some globals that you might want to adjust <<<<<<
sub initialize_globals {
# separate the name=value pairs by semicolons rather than ampersands
$USE_PARAM_SEMICOLONS = 1;
+ # Do not include undefined params parsed from query string
+ # use CGI qw(-no_undef_params);
+ $NO_UNDEF_PARAMS = 0;
+
# Other globals that you shouldn't worry about.
undef $Q;
$BEEN_THERE = 0;
undef @QUERY_PARAM;
undef %EXPORT;
+ undef $QUERY_CHARSET;
+ undef %QUERY_FIELDNAMES;
# prevent complaints by mod_perl
1;
$OS = $Config::Config{'osname'};
}
}
-if ($OS=~/Win/i) {
+if ($OS =~ /^MSWin/i) {
$OS = 'WINDOWS';
-} elsif ($OS=~/vms/i) {
+} elsif ($OS =~ /^VMS/i) {
$OS = 'VMS';
-} elsif ($OS=~/bsdos/i) {
- $OS = 'UNIX';
-} elsif ($OS=~/dos/i) {
+} elsif ($OS =~ /^dos/i) {
$OS = 'DOS';
-} elsif ($OS=~/^MacOS$/i) {
+} elsif ($OS =~ /^MacOS/i) {
$OS = 'MACINTOSH';
-} elsif ($OS=~/os2/i) {
+} elsif ($OS =~ /^os2/i) {
$OS = 'OS2';
+} elsif ($OS =~ /^epoc/i) {
+ $OS = 'EPOC';
} else {
$OS = 'UNIX';
}
# The path separator is a slash, backslash or semicolon, depending
# on the paltform.
$SL = {
- UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/'
+ UNIX=>'/', OS2=>'\\', EPOC=>'/',
+ WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/'
}->{$OS};
# This no longer seems to be necessary
':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
':html' => [qw/:html2 :html3 :netscape/],
':standard' => [qw/:html2 :html3 :form :cgi/],
- ':push' => [qw/multipart_init multipart_start multipart_end/],
+ ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
':all' => [qw/:html2 :html3 :netscape :form :cgi :internal/]
);
# if we get called more than once, we want to initialize
# ourselves from the original query (which may be gone
# if it was read from STDIN originally.)
- if (@QUERY_PARAM && !defined($initializer)) {
+ if (defined(@QUERY_PARAM) && !defined($initializer)) {
foreach (@QUERY_PARAM) {
$self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
}
+ $self->charset($QUERY_CHARSET);
+ $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
return;
}
$fh = to_filehandle($initializer) if $initializer;
+ # set charset to the safe ISO-8859-1
+ $self->charset('ISO-8859-1');
+
METHOD: {
# avoid unreasonably large postings
# We now have the query string in hand. We do slightly
# different things for keyword lists and parameter lists.
- if (defined $query_string && $query_string) {
+ if (defined $query_string && length $query_string) {
if ($query_string =~ /[&=;]/) {
$self->parse_params($query_string);
} else {
$self->delete('.submit');
$self->delete('.cgifields');
- # set charset to the safe ISO-8859-1
- $self->charset('ISO-8859-1');
$self->save_request unless $initializer;
}
next unless defined $_;
$QUERY_PARAM{$_}=$self->{$_};
}
+ $QUERY_CHARSET = $self->charset;
+ %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
}
sub parse_params {
my($param,$value);
foreach (@pairs) {
($param,$value) = split('=',$_,2);
+ next if $NO_UNDEF_PARAMS and not $value;
$value = '' unless defined $value;
$param = unescape($param);
$value = unescape($value);
unless (%$sub) {
my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
eval "package $pack; $$auto";
- die $@ if $@;
+ croak("$AUTOLOAD: $@") if $@;
$$auto = ''; # Free the unneeded storage (but don't undef it!!!)
}
my($code) = $sub->{$func_name};
$code = $CGI::DefaultClass->_make_tag_func($func_name);
}
}
- die "Undefined subroutine $AUTOLOAD\n" unless $code;
+ croak("Undefined subroutine $AUTOLOAD\n") unless $code;
eval "package $pack; $code";
if ($@) {
$@ =~ s/ at .*\n//;
- die $@;
+ croak("$AUTOLOAD: $@");
}
}
CORE::delete($sub->{$func_name}); #free storage
$PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
$EXPORT{$_}++, next if /^[:-]any$/;
$compile++, next if /^[:-]compile$/;
+ $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/;
# This is probably extremely evil code -- to be deleted some day.
if (/^[-]autoload$/) {
END_OF_FUNC
'SERVER_PUSH' => <<'END_OF_FUNC',
-sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; }
+sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
END_OF_FUNC
'new_MultipartBuffer' => <<'END_OF_FUNC',
print $filehandle "$escaped_param=",escape("$value"),"\n";
}
}
+ foreach (keys %{$self->{'.fieldnames'}}) {
+ print $filehandle ".cgifields=",escape("$_"),"\n";
+ }
print $filehandle "=\n"; # end of record
}
END_OF_FUNC
#### Method: multipart_init
# Return a Content-Type: style header for server-push
-# This has to be NPH, and it is advisable to set $| = 1
+# This has to be NPH on most web servers, and it is advisable to set $| = 1
#
# Many thanks to Ed Jordan <ed@fidalgo.net> for this
-# contribution
+# contribution, updated by Andrew Benham (adsb@bigfoot.com)
####
'multipart_init' => <<'END_OF_FUNC',
sub multipart_init {
my($self,@p) = self_or_default(@_);
my($boundary,@other) = rearrange([BOUNDARY],@p);
$boundary = $boundary || '------- =_aaaaaaaaaa0';
- $self->{'separator'} = "\n--$boundary\n";
+ $self->{'separator'} = "$CRLF--$boundary$CRLF";
+ $self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
$type = SERVER_PUSH($boundary);
return $self->header(
-nph => 1,
-type => $type,
(map { split "=", $_, 2 } @other),
- ) . $self->multipart_end;
+ ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
}
END_OF_FUNC
# Return a Content-Type: style header for server-push, start of section
#
# Many thanks to Ed Jordan <ed@fidalgo.net> for this
-# contribution
+# contribution, updated by Andrew Benham (adsb@bigfoot.com)
####
'multipart_start' => <<'END_OF_FUNC',
sub multipart_start {
+ my(@header);
my($self,@p) = self_or_default(@_);
my($type,@other) = rearrange([TYPE],@p);
$type = $type || 'text/html';
- return $self->header(
- -type => $type,
- (map { split "=", $_, 2 } @other),
- );
+ push(@header,"Content-Type: $type");
+
+ # rearrange() was designed for the HTML portion, so we
+ # need to fix it up a little.
+ foreach (@other) {
+ next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
+ ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
+ }
+ push(@header,@other);
+ my $header = join($CRLF,@header)."${CRLF}${CRLF}";
+ return $header;
}
END_OF_FUNC
#### Method: multipart_end
-# Return a Content-Type: style header for server-push, end of section
+# Return a MIME boundary separator for server-push, end of section
#
# Many thanks to Ed Jordan <ed@fidalgo.net> for this
# contribution
END_OF_FUNC
+#### Method: multipart_final
+# Return a MIME boundary separator for server-push, end of all sections
+#
+# Contributed by Andrew Benham (adsb@bigfoot.com)
+####
+'multipart_final' => <<'END_OF_FUNC',
+sub multipart_final {
+ my($self,@p) = self_or_default(@_);
+ return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF;
+}
+END_OF_FUNC
+
+
#### Method: header
# Return a Content-Type: style header
#
# need to fix it up a little.
foreach (@other) {
next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
- ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.unescapeHTML($value)/e;
+ ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
}
$type ||= 'text/html' unless defined($type);
# Maybe future compatibility. Maybe not.
my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
+ push(@header,"Server: " . &server_software()) if $nph;
push(@header,"Status: $status") if $status;
push(@header,"Window-Target: $target") if $target;
# uses OUR clock)
push(@header,"Expires: " . expires($expires,'http'))
if $expires;
- push(@header,"Date: " . expires(0,'http')) if $expires || $cookie;
+ push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
push(@header,"Pragma: no-cache") if $self->cache();
push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
push(@header,@other);
$title = $self->escapeHTML($title || 'Untitled Document');
$author = $self->escape($author);
$lang ||= 'en-US';
- my(@result);
+ my(@result,$xml_dtd);
if ($dtd) {
if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
$dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
} else {
$dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
}
+
+ $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
+ $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
+ push @result,q(<?xml version="1.0" encoding="utf-8"?>) if $xml_dtd;
+
if (ref($dtd) && ref($dtd) eq 'ARRAY') {
- push(@result,qq(<!DOCTYPE HTML\n\tPUBLIC "$dtd->[0]"\n\t"$dtd->[1]">));
+ push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t"$dtd->[1]">));
} else {
- push(@result,qq(<!DOCTYPE HTML\n\tPUBLIC "$dtd">));
+ push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
}
push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml" lang="$lang"><head><title>$title</title>)
: qq(<html lang="$lang"><head><title>$title</title>));
if (defined $author) {
push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
- : "<link rev=made href=\"mailto:$author\">");
+ : "<link rev=\"made\" href=\"mailto:$author\">");
}
if ($base || $xbase || $target) {
my ($self,$style) = @_;
my (@result);
my $type = 'text/css';
+
+ my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
+ my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
+
if (ref($style)) {
my($src,$code,$stype,@other) =
rearrange([SRC,CODE,TYPE],
'-foo'=>'bar', # a trick to allow the '-' to be omitted
ref($style) eq 'ARRAY' ? @$style : %$style);
$type = $stype if $stype;
- #### Here is new code for checking for array reference in -src tag (6/20/00 -- JJN) #####
- #### This should be passed in like this --> -src=>{['style1.css','style2.css','style3.css']}
if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
{ # If it is, push a LINK tag for each one.
foreach $src (@$src)
{
- push(@result,qq/<link rel="stylesheet" type="$type" href="$src">/) if $src;
+ push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" />)
+ : qq(<link rel="stylesheet" type="$type" href="$src">/)) if $src;
}
}
else
{ # Otherwise, push the single -src, if it exists.
- push(@result,qq/<link rel="stylesheet" type="$type" href="$src">/) if $src;
+ push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" />)
+ : qq(<link rel="stylesheet" type="$type" href="$src">)
+ ) if $src;
}
- #### End new code ####
- push(@result,style({'type'=>$type},"<!--\n$code\n-->")) if $code;
+ push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code;
} else {
- push(@result,style({'type'=>$type},"<!--\n$style\n-->"));
+ push(@result,style({'type'=>$type},"$cdata_start\n$style\n$cdata_end"));
}
@result;
}
sub _script {
my ($self,$script) = @_;
my (@result);
+
my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
foreach $script (@scripts) {
my($src,$code,$language);
} else {
($src,$code,$language, $type) = ('',$script,'JavaScript', 'text/javascript');
}
+
+ my $comment = '//'; # javascript by default
+ $comment = '#' if $type=~/perl|tcl/i;
+ $comment = "'" if $type=~/vbscript/i;
+
+ my $cdata_start = "\n<!-- Hide script\n";
+ $cdata_start .= "$comment<![CDATA[\n" if $XHTML;
+ my $cdata_end = $XHTML ? "\n$comment]]>" : $comment;
+ $cdata_end .= " End script hiding -->\n";
+
my(@satts);
push(@satts,'src'=>$src) if $src;
push(@satts,'language'=>$language);
push(@satts,'type'=>$type);
- $code = "<!-- Hide script\n$code\n// End script hiding -->"
- if $code && $type=~/javascript/i;
- $code = "<!-- Hide script\n$code\n\# End script hiding -->"
- if $code && $type=~/perl/i;
- $code = "<!-- Hide script\n$code\n\# End script hiding -->"
- if $code && $type=~/tcl/i;
- $code = "<!-- Hide script\n$code\n' End script hiding -->"
- if $code && $type=~/vbscript/i;
+ $code = "$cdata_start$code$cdata_end" if defined $code;
push(@result,script({@satts},$code || ''));
}
@result;
my($method,$action,$enctype,@other) =
rearrange([METHOD,ACTION,ENCTYPE],@p);
- $method = uc($method) || 'POST';
+ $method = lc($method) || 'post';
$enctype = $enctype || &URL_ENCODED;
- $action = $action ? qq(action="$action") : qq 'action="' . $self->script_name . '"';
+ unless (defined $action) {
+ $action = $self->url(-absolute=>1,-path=>1);
+ $action .= "?$ENV{QUERY_STRING}" if $ENV{QUERY_STRING};
+ }
+ $action = qq(action="$action");
my($other) = @other ? " @other" : '';
$self->{'.parametersToAdd'}={};
return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
my $current = $override ? $default :
(defined($self->param($name)) ? $self->param($name) : $default);
- $current = defined($current) ? $self->escapeHTML($current) : '';
+ $current = defined($current) ? $self->escapeHTML($current,1) : '';
$name = defined($name) ? $self->escapeHTML($name) : '';
- my($s) = defined($size) ? qq/ size=$size/ : '';
- my($m) = defined($maxlength) ? qq/ maxlength=$maxlength/ : '';
+ my($s) = defined($size) ? qq/ size="$size"/ : '';
+ my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : '';
my($other) = @other ? " @other" : '';
# this entered at cristy's request to fix problems with file upload fields
# and WebTV -- not sure it won't break stuff
[ONCLICK,SCRIPT]],@p);
$label=$self->escapeHTML($label);
- $value=$self->escapeHTML($value);
+ $value=$self->escapeHTML($value,1);
$script=$self->escapeHTML($script);
my($name) = '';
- $name = qq/ NAME="$label"/ if $label;
+ $name = qq/ name="$label"/ if $label;
$value = $value || $label;
my($val) = '';
$val = qq/ value="$value"/ if $value;
my($label,$value,@other) = rearrange([NAME,[VALUE,LABEL]],@p);
$label=$self->escapeHTML($label);
- $value=$self->escapeHTML($value);
+ $value=$self->escapeHTML($value,1);
my($name) = ' name=".submit"' unless $NOSTICKY;
$name = qq/ name="$label"/ if defined($label);
my($label,@other) = rearrange([[NAME,VALUE]],@p);
- $label=$self->escapeHTML($label);
+ $label=$self->escapeHTML($label,1);
$label = $label || "Defaults";
my($value) = qq/ value="$label"/;
my($other) = @other ? " @other" : '';
- return $XHTML ? qq(<input type="submit" value".defaults"$value$other />)
+ return $XHTML ? qq(<input type="submit" name=".defaults"$value$other />)
: qq/<input type="submit" NAME=".defaults"$value$other>/;
}
END_OF_FUNC
if (!$override && ($self->{'.fieldnames'}->{$name} ||
defined $self->param($name))) {
- $checked = grep($_ eq $value,$self->param($name)) ? ' checked="yes"' : '';
+ $checked = grep($_ eq $value,$self->param($name)) ? ' checked' : '';
} else {
- $checked = $checked ? qq/ checked="yes"/ : '';
+ $checked = $checked ? qq/ checked/ : '';
}
my($the_label) = defined $label ? $label : $name;
$name = $self->escapeHTML($name);
- $value = $self->escapeHTML($value);
+ $value = $self->escapeHTML($value,1);
$the_label = $self->escapeHTML($the_label);
my($other) = @other ? " @other" : '';
$self->register_parameter($name);
my($other) = @other ? " @other" : '';
foreach (@values) {
- $checked = $checked{$_} ? qq/ checked="yes"/ : '';
+ $checked = $checked{$_} ? qq/ checked/ : '';
$label = '';
unless (defined($nolabels) && $nolabels) {
$label = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
$label = $self->escapeHTML($label);
}
- $_ = $self->escapeHTML($_);
+ $_ = $self->escapeHTML($_,1);
push(@elements,$XHTML ? qq(<input type="checkbox" name="$name" value="$_"$checked$other />${label}${break})
: qq/<input type="checkbox" name="$name" value="$_"$checked$other>${label}${break}/);
}
# Escape HTML -- used internally
'escapeHTML' => <<'END_OF_FUNC',
sub escapeHTML {
- my ($self,$toencode) = CGI::self_or_default(@_);
+ my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
return undef unless defined($toencode);
return $toencode if ref($self) && $self->{'dontescape'};
$toencode =~ s{&}{&}gso;
$toencode =~ s{<}{<}gso;
$toencode =~ s{>}{>}gso;
$toencode =~ s{"}{"}gso;
- if (uc $self->{'.charset'} eq 'ISO-8859-1' or
- uc $self->{'.charset'} eq 'WINDOWS-1252') { # bug
+ my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' ||
+ uc $self->{'.charset'} eq 'WINDOWS-1252';
+ if ($latin) { # bug in some browsers
+ $toencode =~ s{'}{'}gso;
$toencode =~ s{\x8b}{‹}gso;
$toencode =~ s{\x9b}{›}gso;
- }
+ if (defined $newlinestoo && $newlinestoo) {
+ $toencode =~ s{\012}{ }gso;
+ $toencode =~ s{\015}{ }gso;
+ }
+ }
return $toencode;
}
END_OF_FUNC
sub unescapeHTML {
my ($self,$string) = CGI::self_or_default(@_);
return undef unless defined($string);
- my $latin = $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i;
+ my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
+ : 1;
# thanks to Randal Schwartz for the correct solution to this one
$string=~ s[&(.*?);]{
local $_ = $1;
my($other) = @other ? " @other" : '';
foreach (@values) {
- my($checkit) = $checked eq $_ ? qq/ checked="yes"/ : '';
+ my($checkit) = $checked eq $_ ? qq/ checked/ : '';
my($break);
if ($linebreak) {
- $break = $XHTML ? "<br />" : "<br>";
+ $break = $XHTML ? "<br />" : "<br>";
}
else {
- $break = '';
+ $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,$XHTML ? qq(<input type="radio" name="$name" value="$_"$checkit$other />${label}${break})
$result = qq/<select name="$name"$other>\n/;
foreach (@values) {
- my($selectit) = defined($selected) ? ($selected eq $_ ? qq/selected="yes"/ : '' ) : '';
+ my($selectit) = defined($selected) ? ($selected eq $_ ? qq/selected/ : '' ) : '';
my($label) = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
my($value) = $self->escapeHTML($_);
- $label=$self->escapeHTML($label);
+ $label=$self->escapeHTML($label,1);
$result .= "<option $selectit value=\"$value\">$label</option>\n";
}
$size = $size || scalar(@values);
my(%selected) = $self->previous_or_default($name,$defaults,$override);
- my($is_multiple) = $multiple ? qq/ multiple="yes"/ : '';
+ my($is_multiple) = $multiple ? qq/ multiple/ : '';
my($has_size) = $size ? qq/ size="$size"/: '';
my($other) = @other ? " @other" : '';
$name=$self->escapeHTML($name);
$result = qq/<select name="$name"$has_size$is_multiple$other>\n/;
foreach (@values) {
- my($selectit) = $selected{$_} ? qq/selected="yes"/ : '';
+ my($selectit) = $selected{$_} ? qq/selected/ : '';
my($label) = $_;
$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
$label=$self->escapeHTML($label);
- my($value)=$self->escapeHTML($_);
+ my($value)=$self->escapeHTML($_,1);
$result .= "<option $selectit value=\"$value\">$label</option>\n";
}
$result .= "</select>\n";
$name=$self->escapeHTML($name);
foreach (@value) {
- $_ = defined($_) ? $self->escapeHTML($_) : '';
- push(@result,$XHTMl ? qq(<input type="hidden" name="$name" value="$_" />)
- : qq/<input type="hidden" name="$name" value="$_">/);
+ $_ = defined($_) ? $self->escapeHTML($_,1) : '';
+ push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" />)
+ : qq(<input type="hidden" name="$name" value="$_">);
}
return wantarray ? @result : join('',@result);
}
'url' => <<'END_OF_FUNC',
sub url {
my($self,@p) = self_or_default(@_);
- my ($relative,$absolute,$full,$path_info,$query) =
- 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;
- if (exists($ENV{REQUEST_URI})) {
- my $index;
- $script_name = $ENV{REQUEST_URI};
- # strip query string
- substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0;
- # and path
- if (exists($ENV{PATH_INFO})) {
- my $decoded_path = unescape($ENV{PATH_INFO});
- substr($script_name,$index) = '' if ($index = rindex($script_name,$decoded_path)) >= 0;
- }
- } else {
- $script_name = $self->script_name;
- }
+ my $script_name = $self->script_name;
+
+# If anybody knows why I ever wrote this please tell me!
+# if (exists($ENV{REQUEST_URI})) {
+# my $index;
+# $script_name = $ENV{REQUEST_URI};
+# # strip query string
+# substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0;
+# # and path
+# if (exists($ENV{PATH_INFO})) {
+# (my $encoded_path = $ENV{PATH_INFO}) =~ s!([^a-zA-Z0-9_./-])!uc sprintf("%%%02x",ord($1))!eg;;
+# substr($script_name,$index) = '' if ($index = rindex($script_name,$encoded_path)) >= 0;
+# }
+# } else {
+# $script_name = $self->script_name;
+# }
if ($full) {
my $protocol = $self->protocol();
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;
}
# 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);
push(@pairs,"$eparam=$value");
}
}
+ foreach (keys %{$self->{'.fieldnames'}}) {
+ push(@pairs,".cgifields=".escape("$_"));
+ }
return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
}
END_OF_FUNC
'upload' =><<'END_OF_FUNC',
sub upload {
my($self,$param_name) = self_or_default(@_);
- my $param = $self->param($param_name);
- return unless $param;
- return unless ref($param) && fileno($param);
- return $param;
+ my @param = grep(ref && fileno($_), $self->param($param_name));
+ return unless @param;
+ return wantarray ? @param : $param[0];
}
END_OF_FUNC
my $self = shift;
# get rid of package name
(my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
- $i =~ s/\\(.)/$1/g;
+ $i =~ s/%(..)/ chr(hex($1)) /eg;
return $i;
# BEGIN DEAD CODE
# This was an extremely clever patch that allowed "use strict refs".
sub new {
my($pack,$name,$file,$delete) = @_;
require Fcntl unless defined &Fcntl::O_RDWR;
- my $fv = ++$FH . quotemeta($name);
- warn unless *{"Fh::$fv"};
+ (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;
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.
}
# 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;
}
@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");
+ "${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
last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
}
# untaint the darn thing
- return unless $filename =~ m!^([a-zA-Z0-9_ '":/.\$\\]+)$!;
+ return unless $filename =~ m!^([a-zA-Z0-9_ '":/.\$\\-]+)$!;
$filename = $1;
return bless \$filename;
}
=over 4
-=item 1. Use another name for the argument, if one is available. For
-example, -value is an alias for -values.
+=item 1.
-=item 2. Change the capitalization, e.g. -Values
+Use another name for the argument, if one is available.
+For example, -value is an alias for -values.
-=item 3. Put quotes around the argument name, e.g. '-values'
+=item 2.
+
+Change the capitalization, e.g. -Values
+
+=item 3.
+
+Put quotes around the argument name, e.g. '-values'
=back
parameters' values. The Vars() method does this. Called in a scalar
context, it returns the parameter list as a tied hash reference.
Changing a key changes the value of the parameter in the underlying
-CGI parameter list. Called in an array context, it returns the
+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
-array context, multivalued parameters will be returned as a packed
+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
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
the <HTML> tag. The default if not specified is "en-US" for US
English. For example:
- print $q->header(-lang=>'fr-CA');
+ print $q->start_html(-lang=>'fr-CA');
You can place other arbitrary HTML elements to the <HEAD> section with the
B<-head> tag. For example, to place the rarely-used <LINK> element in the
And here's how to create an HTTP-EQUIV <META> tag:
- print header(-head=>meta({-http_equiv => 'Content-Type',
- -content => 'text/html'}))
+ print start_html(-head=>meta({-http_equiv => 'Content-Type',
+ -content => 'text/html'}))
JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
$absolute_url = $query->url(-absolute=>1);
$url_with_path = $query->url(-path_info=>1);
$url_with_path_and_query = $query->url(-path_info=>1,-query=>1);
+ $netloc = $query->url(-base => 1);
B<url()> returns the script's URL in a variety of formats. Called
without any arguments, it returns the full form of the URL, including
B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided
as a synonym.
+=item B<-base>
+
+Generate just the protocol and net location, as in http://www.foo.com:8000
+
=back
=head2 MIXING POST AND URL PARAMETERS
print;
}
+In an array context, upload() will return an array of filehandles.
+This makes it possible to create forms that use the same name for
+multiple upload fields.
+
This is the recommended idiom.
When a file is uploaded the browser usually sends along some
You are free to create a custom HTML page to complain about the error,
if you wish.
+If you are using CGI.pm on a Windows platform and find that binary
+files get slightly larger when uploaded but that text files remain the
+same, then you have forgotten to activate binary mode on the output
+filehandle. Be sure to call binmode() on any handle that you create
+to write the uploaded file to disk.
+
JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
recognized. See textfield() for details.
The second argument (-src) is also required and specifies the URL
=item 3.
+
The third option (-align, optional) is an alignment type, and may be
TOP, BOTTOM or MIDDLE
-value=>\%answers);
print $query->header(-cookie=>[$cookie1,$cookie2]);
-To retrieve a cookie, request it by name by calling cookie()
-method without the B<-value> parameter:
+To retrieve a cookie, request it by name by calling cookie() method
+without the B<-value> parameter:
use CGI;
$query = new CGI;
- %answers = $query->cookie(-name=>'answers');
- # $query->cookie('answers') will work too!
+ $riddle = $query->cookie('riddle_name');
+ %answers = $query->cookie('answers');
+
+Cookies created with a single scalar value, such as the "riddle_name"
+cookie, will be returned in that form. Cookies with array and hash
+values can also be retrieved.
The cookie and CGI namespaces are separate. If you have a parameter
named 'answers' and a cookie named 'answers', the values retrieved by
if the former is unavailable.
=item B<script_name()>
+
Return the script name as a partial URL, for self-refering
scripts.
When using virtual hosts, returns the name of the host that
the browser attempted to contact
+=item B<server_port ()>
+
+Return the port that the server is listening on.
+
=item B<server_software ()>
Returns the server software and version number.
CGI->nph(1)
-=item By using B<-nph> parameters in the B<header()> and B<redirect()> statements:
+=item By using B<-nph> parameters
+
+in the B<header()> and B<redirect()> statements:
print $q->header(-nph=>1);
=head1 Server Push
-CGI.pm provides three simple functions for producing multipart
+CGI.pm provides four simple functions for producing multipart
documents of the type needed to implement server push. These
functions were graciously provided by Ed Jordan <ed@fidalgo.net>. To
import these into your namespace, you must import the ":push" set.
#!/usr/local/bin/perl
use CGI qw/:push -nph/;
$| = 1;
- print multipart_init(-boundary=>'----------------here we go!');
- while (1) {
+ print multipart_init(-boundary=>'----here we go!');
+ foreach (0 .. 4) {
print multipart_start(-type=>'text/plain'),
- "The current time is ",scalar(localtime),"\n",
- multipart_end;
+ "The current time is ",scalar(localtime),"\n";
+ if ($_ < 4) {
+ print multipart_end;
+ } else {
+ print multipart_final;
+ }
sleep 1;
}
This script initializes server push by calling B<multipart_init()>.
-It then enters an infinite loop in which it begins a new multipart
-section by calling B<multipart_start()>, prints the current local time,
+It then enters a loop in which it begins a new multipart section by
+calling B<multipart_start()>, prints the current local time,
and ends a multipart section with B<multipart_end()>. It then sleeps
-a second, and begins again.
+a second, and begins again. On the final iteration, it ends the
+multipart section with B<multipart_final()> rather than with
+B<multipart_end()>.
=over 4
multipart_end()
End a part. You must remember to call multipart_end() once for each
-multipart_start().
+multipart_start(), except at the end of the last part of the multipart
+document when multipart_final() should be called instead of multipart_end().
+
+=item multipart_final()
+
+ multipart_final()
+
+End all parts. You should call multipart_final() rather than
+multipart_end() at the end of the last part of the multipart document.
=back
Users interested in server push applications should also have a look
at the CGI::Push module.
+Only Netscape Navigator supports server push. Internet Explorer
+browsers do not.
+
=head1 Avoiding Denial of Service Attacks
A potential problem with CGI.pm is that, by default, it attempts to
https://perl5.git.perl.org / perl5.git / blobdiff