# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
-$CGI::revision = '$Id: CGI.pm,v 1.112 2003/04/28 13:35:56 lstein Exp $';
-$CGI::VERSION='2.93';
+$CGI::revision = '$Id: CGI.pm,v 1.165 2004/04/12 20:37:26 lstein Exp $';
+$CGI::VERSION=3.05;
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
# $CGITempFile::TMPDIRECTORY = '/usr/tmp';
-use CGI::Util qw(rearrange make_attributes unescape escape expires);
+use CGI::Util qw(rearrange make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic);
#use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
# 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
$TAINTED = substr("$0$^X",0,0);
}
-my @SAVED_SYMBOLS;
-
$MOD_PERL = 0; # no mod_perl by default
+@SAVED_SYMBOLS = ();
# >>>>> Here are some globals that you might want to adjust <<<<<<
sub initialize_globals {
# Other globals that you shouldn't worry about.
undef $Q;
$BEEN_THERE = 0;
+ $DTD_PUBLIC_IDENTIFIER = "";
undef @QUERY_PARAM;
undef %EXPORT;
undef $QUERY_CHARSET;
# ------------------ START OF THE LIBRARY ------------
+*end_form = \&endform;
+
# make mod_perlhappy
initialize_globals();
if (defined $mod_perl::VERSION) {
if ($mod_perl::VERSION >= 1.99) {
$MOD_PERL = 2;
+ require Apache::Response;
require Apache::RequestRec;
require Apache::RequestUtil;
require APR::Pool;
}
if ($needs_binmode) {
- $CGI::DefaultClass->binmode(main::STDOUT);
- $CGI::DefaultClass->binmode(main::STDIN);
- $CGI::DefaultClass->binmode(main::STDERR);
+ $CGI::DefaultClass->binmode(\*main::STDOUT);
+ $CGI::DefaultClass->binmode(\*main::STDIN);
+ $CGI::DefaultClass->binmode(\*main::STDERR);
}
%EXPORT_TAGS = (
base body Link nextid title meta kbd start_html end_html
input Select option comment charset escapeHTML/],
':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param
- embed basefont style span layer ilayer font frameset frame script small big/],
+ embed basefont style span layer ilayer font frameset frame script small big Area Map/],
':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
ins label legend noframes noscript object optgroup Q
thead tbody tfoot/],
start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump
raw_cookie request_method query_string Accept user_agent remote_host content_type
- remote_addr referer server_name server_software server_port server_protocol
- virtual_host remote_ident auth_type http
+ remote_addr referer server_name server_software server_port server_protocol virtual_port
+ virtual_host remote_ident auth_type http append
save_parameters restore_parameters param_fetch
remote_user user_name header redirect import_names put
Delete Delete_all url_param cgi_error/],
':ssl' => [qw/https/],
- ':imagemap' => [qw/Area Map/],
':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
':html' => [qw/:html2 :html3 :html4 :netscape/],
':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
sub new {
my($class,@initializer) = @_;
my $self = {};
+
bless $self,ref $class || $class || $DefaultClass;
if (ref($initializer[0])
&& (UNIVERSAL::isa($initializer[0],'Apache')
)) {
$self->r(shift @initializer);
}
+ if (ref($initializer[0])
+ && (UNIVERSAL::isa($initializer[0],'CODE'))) {
+ $self->upload_hook(shift @initializer, shift @initializer);
+ }
if ($MOD_PERL) {
$self->r(Apache->request) unless $self->r;
my $r = $self->r;
return $self;
}
-# We provide a DESTROY method so that the autoloader
-# doesn't bother trying to find it.
-sub DESTROY { }
+# We provide a DESTROY method so that we can ensure that
+# temporary files are closed (via Fh->DESTROY) before they
+# are unlinked (via CGITempFile->DESTROY) because it is not
+# possible to unlink an open file on Win32. We explicitly
+# call DESTROY on each, rather than just undefing them and
+# letting Perl DESTROY them by garbage collection, in case the
+# user is still holding any reference to them as well.
+sub DESTROY {
+ my $self = shift;
+ foreach my $href (values %{$self->{'.tmpfiles'}}) {
+ $href->{hndl}->DESTROY if defined $href->{hndl};
+ $href->{name}->DESTROY if defined $href->{name};
+ }
+}
sub r {
my $self = shift;
$r;
}
+sub upload_hook {
+ my ($self,$hook,$data) = self_or_default(@_);
+ $self->{'.upload_hook'} = $hook;
+ $self->{'.upload_data'} = $data;
+}
+
#### Method: param
# Returns the value(s)of a named parameter.
# If invoked in a list context, returns the
# avoid unreasonably large postings
if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
- $self->cgi_error("413 Request entity too large");
- last METHOD;
- }
+ # quietly read and discard the post
+ my $buffer;
+ my $max = $content_length;
+ while ($max > 0 &&
+ (my $bytes = $MOD_PERL
+ ? $self->r->read($buffer,$max < 10000 ? $max : 10000)
+ : read(STDIN,$buffer,$max < 10000 ? $max : 10000)
+ )) {
+ $self->cgi_error("413 Request entity too large");
+ last METHOD;
+ }
+ }
# Process multipart postings, but only if the initializer is
# not defined.
last METHOD;
}
+ if (defined($fh) && ($fh ne '')) {
+ while (<$fh>) {
+ chomp;
+ last if /^=/;
+ push(@lines,$_);
+ }
+ # massage back into standard format
+ if ("@lines" =~ /=/) {
+ $query_string=join("&",@lines);
+ } else {
+ $query_string=join("+",@lines);
+ }
+ last METHOD;
+ }
+
# last chance -- treat it as a string
$initializer = $$initializer if ref($initializer) eq 'SCALAR';
$query_string = $initializer;
}
if ($meth eq 'POST') {
- $self->read_from_client(\*STDIN,\$query_string,$content_length,0)
+ $self->read_from_client(\$query_string,$content_length,0)
if $content_length > 0;
# Some people want to have their cake and eat it too!
# Uncomment this line to have the contents of the query string
# Check the command line and then the standard input for data.
# We use the shellwords package in order to behave the way that
# UN*X programmers expect.
- $query_string = read_from_cmdline() if $DEBUG;
+ if ($DEBUG)
+ {
+ my $cmdline_ret = read_from_cmdline();
+ $query_string = $cmdline_ret->{'query_string'};
+ if (defined($cmdline_ret->{'subpath'}))
+ {
+ $self->path_info($cmdline_ret->{'subpath'});
+ }
+ }
}
# YL: Begin Change for XML handler 10/19/2001
if ($meth eq 'POST'
&& defined($ENV{'CONTENT_TYPE'})
- && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded| ) {
+ && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
+ && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
my($param) = 'POSTDATA' ;
$self->add_parameter($param) ;
push (@{$self->{$param}},$query_string);
# Special case. Erase everything if there is a field named
# .defaults.
if ($self->param('.defaults')) {
- undef %{$self};
+ $self->delete_all();
}
# Associative array containing our defined fieldnames
# put a filehandle into binary mode (DOS)
sub binmode {
+ return unless defined($_[1]) && defined fileno($_[1]);
CORE::binmode($_[1]);
}
my(\@attr) = make_attributes(\$a,\$q->{'escape'});
\$attr = " \@attr" if \@attr;
} else {
- unshift \@rest,\$a;
+ unshift \@rest,\$a if defined \$a;
}
);
if ($tagname=~/start_(\w+)/i) {
$func .= qq! return "<\L/$1\E>"; } !;
} else {
$func .= qq#
-\# return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@_;
- return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest && defined(\$rest[0]);
+ return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest;
my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
my \@result = map { "\$tag\$_\$untag" }
(ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest";
$XHTML=0, next if /^[:-]no_?xhtml$/;
$USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
$PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
- $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
+ $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
$EXPORT{$_}++, next if /^[:-]any$/;
$compile++, next if /^[:-]compile$/;
$NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/;
'new_MultipartBuffer' => <<'END_OF_FUNC',
# Create a new multipart buffer
sub new_MultipartBuffer {
- my($self,$boundary,$length,$filehandle) = @_;
- return MultipartBuffer->new($self,$boundary,$length,$filehandle);
+ my($self,$boundary,$length) = @_;
+ return MultipartBuffer->new($self,$boundary,$length);
}
END_OF_FUNC
'read_from_client' => <<'END_OF_FUNC',
# Read data from a file handle
sub read_from_client {
- my($self, $fh, $buff, $len, $offset) = @_;
+ my($self, $buff, $len, $offset) = @_;
local $^W=0; # prevent a warning
- return undef unless defined($fh);
- return read($fh, $$buff, $len, $offset);
+ return $MOD_PERL
+ ? $self->r->read($$buff, $len, $offset)
+ : read(\*STDIN, $$buff, $len, $offset);
}
END_OF_FUNC
####
sub delete {
my($self,@p) = self_or_default(@_);
- my($name) = rearrange([NAME],@p);
- my @to_delete = ref($name) eq 'ARRAY' ? @$name : ($name);
+ my(@names) = rearrange([NAME],@p);
+ my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
my %to_delete;
foreach my $name (@to_delete)
{
$to_delete{$name}++;
}
@{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
- return wantarray ? () : undef;
+ return;
}
END_OF_FUNC
'delete_all' => <<'EOF',
sub delete_all {
my($self) = self_or_default(@_);
- my @param = $self->param;
+ my @param = $self->param();
$self->delete(@param);
}
EOF
push(@result,"<ul>");
foreach $param ($self->param) {
my($name)=$self->escapeHTML($param);
- push(@result,"<li><strong>$param</strong>");
+ push(@result,"<li><strong>$param</strong></li>");
push(@result,"<ul>");
foreach $value ($self->param($param)) {
$value = $self->escapeHTML($value);
- $value =~ s/\n/<br>\n/g;
- push(@result,"<li>$value");
+ $value =~ s/\n/<br \/>\n/g;
+ push(@result,"<li>$value</li>");
}
push(@result,"</ul>");
}
$self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
$type = SERVER_PUSH($boundary);
return $self->header(
- -nph => 1,
+ -nph => 0,
-type => $type,
(map { split "=", $_, 2 } @other),
) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
my($self,@p) = self_or_default(@_);
my(@header);
- return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE;
+ return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE;
my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) =
rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
'redirect' => <<'END_OF_FUNC',
sub redirect {
my($self,@p) = self_or_default(@_);
- my($url,$target,$cookie,$nph,@other) = rearrange([[LOCATION,URI,URL],TARGET,['COOKIE','COOKIES'],NPH],@p);
+ my($url,$target,$status,$cookie,$nph,@other) =
+ rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p);
+ $status = '302 Moved' unless defined $status;
$url ||= $self->self_url;
my(@o);
foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
unshift(@o,
- '-Status' => '302 Moved',
+ '-Status' => $status,
'-Location'=> $url,
'-nph' => $nph);
unshift(@o,'-Target'=>$target) if $target;
$encoding = 'iso-8859-1' unless defined $encoding;
- # strangely enough, the title needs to be escaped as HTML
- # while the author needs to be escaped as a URL
- $title = $self->escapeHTML($title || 'Untitled Document');
- $author = $self->escape($author);
- $lang = 'en-US' unless defined $lang;
+ # Need to sort out the DTD before it's okay to call escapeHTML().
my(@result,$xml_dtd);
if ($dtd) {
if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
if (ref($dtd) && ref($dtd) eq 'ARRAY') {
push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">));
+ $DTD_PUBLIC_IDENTIFIER = $dtd->[0];
} else {
push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
+ $DTD_PUBLIC_IDENTIFIER = $dtd;
}
+
+ # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to
+ # call escapeHTML(). Strangely enough, the title needs to be escaped as
+ # HTML while the author needs to be escaped as a URL.
+ $title = $self->escapeHTML($title || 'Untitled Document');
+ $author = $self->escape($author);
+
+ if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2)/i) {
+ $lang = "" unless defined $lang;
+ $XHTML = 0;
+ }
+ else {
+ $lang = 'en-US' unless defined $lang;
+ }
+
push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml" lang="$lang" xml:lang="$lang"><head><title>$title</title>)
: ($lang ? qq(<html lang="$lang">) : "<html>")
. "<head><title>$title</title>");
push(@result,ref($head) ? @$head : $head) if $head;
# handle the infrequently-used -style and -script parameters
- push(@result,$self->_style($style)) if defined $style;
+ push(@result,$self->_style($style)) if defined $style;
push(@result,$self->_script($script)) if defined $script;
# handle -noscript parameter
my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
- if (ref($style)) {
- my($src,$code,$verbatim,$stype,@other) =
- rearrange([SRC,CODE,VERBATIM,TYPE],
- '-foo'=>'bar', # a trick to allow the '-' to be omitted
- ref($style) eq 'ARRAY' ? @$style : %$style);
- $type = $stype if $stype;
-
- 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,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" />)
- : qq(<link rel="stylesheet" type="$type" href="$src">)) if $src;
+ my @s = ref($style) eq 'ARRAY' ? @$style : $style;
+
+ for my $s (@s) {
+ if (ref($s)) {
+ my($src,$code,$verbatim,$stype,$foo,@other) =
+ rearrange([qw(SRC CODE VERBATIM TYPE FOO)],
+ ('-foo'=>'bar',
+ ref($s) eq 'ARRAY' ? @$s : %$s));
+ $type = $stype if $stype;
+ my $other = @other ? join ' ',@other : '';
+
+ 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,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
+ : qq(<link rel="stylesheet" type="$type" href="$src"$other>)) if $src;
+ }
}
- }
- else
- { # Otherwise, push the single -src, if it exists.
- 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,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
+ : qq(<link rel="stylesheet" type="$type" href="$src"$other>)
+ ) if $src;
+ }
+ if ($verbatim) {
+ my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim;
+ push(@result, "<style type=\"text/css\">\n$_\n</style>") foreach @v;
+ }
+ my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code;
+ push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) foreach @c;
+
+ } else {
+ my $src = $s;
+ push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
+ : qq(<link rel="stylesheet" type="$type" href="$src"$other>));
}
- if ($verbatim) {
- push(@result, "<style type=\"text/css\">\n$verbatim\n</style>");
- }
- push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code;
- } else {
- push(@result,style({'type'=>$type},"$cdata_start\n$style\n$cdata_end"));
}
@result;
}
$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) unless defined $type;
- push(@satts,'type'=>$type);
- $code = "$cdata_start$code$cdata_end" if defined $code;
- push(@result,script({@satts},$code || ''));
+ my ($cdata_start,$cdata_end);
+ if ($XHTML) {
+ $cdata_start = "$comment<![CDATA[\n";
+ $cdata_end .= "\n$comment]]>";
+ } else {
+ $cdata_start = "\n<!-- Hide script\n";
+ $cdata_end = $comment;
+ $cdata_end .= " End script hiding -->\n";
+ }
+ my(@satts);
+ push(@satts,'src'=>$src) if $src;
+ push(@satts,'language'=>$language) unless defined $type;
+ push(@satts,'type'=>$type);
+ $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 = lc($method) || 'post';
- $enctype = $enctype || &URL_ENCODED;
- unless (defined $action) {
- $action = $self->url(-absolute=>1,-path=>1);
- if (length($ENV{QUERY_STRING})>0) {
- $action .= "?$ENV{QUERY_STRING}";
+ $method = $self->escapeHTML(lc($method) || 'post');
+ $enctype = $self->escapeHTML($enctype || &URL_ENCODED);
+ if (defined $action) {
+ $action = $self->escapeHTML($action);
+ }
+ else {
+ $action = $self->escapeHTML($self->url(-absolute=>1,-path=>1));
+ if (exists $ENV{QUERY_STRING} && length($ENV{QUERY_STRING})>0) {
+ $action .= "?".$self->escapeHTML($ENV{QUERY_STRING},1);
}
}
$action = qq(action="$action");
END_OF_FUNC
-#### Method: end_form
-# synonym for endform
-'end_form' => <<'END_OF_FUNC',
-sub end_form {
- &endform;
-}
-END_OF_FUNC
-
-
'_textfield' => <<'END_OF_FUNC',
sub _textfield {
my($self,$tag,@p) = self_or_default(@_);
$label=$self->escapeHTML($label);
$value=$self->escapeHTML($value,1);
- my($name) = ' name=".submit"' unless $NOSTICKY;
+ my $name = $NOSTICKY ? '' : ' name=".submit"';
$name = qq/ name="$label"/ if defined($label);
$value = defined($value) ? $value : $label;
my $val = '';
sub reset {
my($self,@p) = self_or_default(@_);
my($label,$value,@other) = rearrange(['NAME',['VALUE','LABEL']],@p);
- warn "label = $label, value = $value";
$label=$self->escapeHTML($label);
$value=$self->escapeHTML($value,1);
my ($name) = ' name=".reset"';
: qq/<input type="checkbox" name="$name" value="$_"$checked$other$attribs>${label}${break}/);
}
$self->register_parameter($name);
- return wantarray ? @elements : join(' ',@elements)
+ return wantarray ? @elements : join(' ',@elements)
unless defined($columns) || defined($rows);
$rows = 1 if $rows && $rows < 1;
$cols = 1 if $cols && $cols < 1;
$toencode =~ s{&}{&}gso;
$toencode =~ s{<}{<}gso;
$toencode =~ s{>}{>}gso;
- $toencode =~ s{"}{"}gso;
+ if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) {
+ # $quot; was accidentally omitted from the HTML 3.2 DTD -- see
+ # <http://validator.w3.org/docs/errors.html#bad-entity> /
+ # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>.
+ $toencode =~ s{"}{"}gso;
+ }
+ else {
+ $toencode =~ s{"}{"}gso;
+ }
my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' ||
uc $self->{'.charset'} eq 'WINDOWS-1252';
if ($latin) { # bug in some browsers
# unescape HTML -- used internally
'unescapeHTML' => <<'END_OF_FUNC',
sub unescapeHTML {
+ # hack to work around earlier hacks
+ push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
my ($self,$string) = CGI::self_or_default(@_);
return undef unless defined($string);
my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
$name=$self->escapeHTML($name);
foreach (@value) {
$_ = defined($_) ? $self->escapeHTML($_,1) : '';
- push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" />)
- : qq(<input type="hidden" name="$name" value="$_">);
+ push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />)
+ : qq(<input type="hidden" name="$name" value="$_" @other>);
}
return wantarray ? @result : join('',@result);
}
if (exists($ENV{REQUEST_URI})) {
my $index;
$script_name = unescape($ENV{REQUEST_URI});
- $script_name =~ s/\?.+$//; # strip query string
+ $script_name =~ s/\?.+$//s; # strip query string
# and path
if (exists($ENV{PATH_INFO})) {
- my $encoded_path = quotemeta($ENV{PATH_INFO});
- $script_name =~ s/$encoded_path$//i;
+ my $encoded_path = unescape($ENV{PATH_INFO});
+ $script_name =~ s/\Q$encoded_path\E$//i;
}
}
if ($full) {
my $protocol = $self->protocol();
$url = "$protocol://";
- my $vh = http('host');
+ my $vh = http('x_forwarded_host') || http('host');
if ($vh) {
$url .= $vh;
} else {
$url .= server_name();
my $port = $self->server_port;
$url .= ":" . $port
- unless (lc($protocol) eq 'http' && $port == 80)
+ unless (lc($protocol) eq 'http' && $port == 80)
|| (lc($protocol) eq 'https' && $port == 443);
}
return $url if $base;
######
'virtual_host' => <<'END_OF_FUNC',
sub virtual_host {
- my $vh = http('host') || server_name();
+ my $vh = http('x_forwarded_host') || http('host') || server_name();
$vh =~ s/:\d+$//; # get rid of port number
return $vh;
}
}
END_OF_FUNC
+#### Method: virtual_port
+# Return the server port, taking virtual hosts into account
+####
+'virtual_port' => <<'END_OF_FUNC',
+sub virtual_port {
+ my($self) = self_or_default(@_);
+ my $vh = $self->http('x_forwarded_host') || $self->http('host');
+ if ($vh) {
+ return ($vh =~ /:(\d+)$/)[0] || '80';
+ } else {
+ return $self->server_port();
+ }
+}
+END_OF_FUNC
+
#### Method: server_port
# Return the tcp/ip port the server is running on
####
sub read_from_cmdline {
my($input,@words);
my($query_string);
+ my($subpath);
if ($DEBUG && @ARGV) {
@words = @ARGV;
} elsif ($DEBUG > 1) {
require "shellwords.pl";
- print STDERR "(offline mode: enter name=value pairs on standard input)\n";
+ print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n";
chomp(@lines = <STDIN>); # remove newlines
$input = join(" ",@lines);
@words = &shellwords($input);
} else {
$query_string = join('+',@words);
}
- return $query_string;
+ if ($query_string =~ /^(.*?)\?(.*)$/)
+ {
+ $query_string = $2;
+ $subpath = $1;
+ }
+ return { 'query_string' => $query_string, 'subpath' => $subpath };
}
END_OF_FUNC
#####
'read_multipart' => <<'END_OF_FUNC',
sub read_multipart {
- my($self,$boundary,$length,$filehandle) = @_;
- my($buffer) = $self->new_MultipartBuffer($boundary,$length,$filehandle);
+ my($self,$boundary,$length) = @_;
+ my($buffer) = $self->new_MultipartBuffer($boundary,$length);
return unless $buffer;
my(%header,$body);
my $filenumber = 0;
return;
}
- my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
+ my($param)= $header{'Content-Disposition'}=~/ name="([^;]*)"/;
$param .= $TAINTED;
# Bug: Netscape doesn't escape quotation marks in file names!!!
- my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\"]*)"?/;
+ my($filename) = $header{'Content-Disposition'}=~/ filename="([^;]*)"/;
# Test for Opera's multiple upload feature
my($multipart) = ( defined( $header{'Content-Type'} ) &&
$header{'Content-Type'} =~ /multipart\/mixed/ ) ?
$seqno += int rand(100);
}
die "CGI open of tmpfile: $!\n" unless defined $filehandle;
- $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
+ && defined fileno($filehandle);
# if this is an multipart/mixed attachment, save the header
- # together with the body for lateron parsing with an external
+ # together with the body for later parsing with an external
# MIME parser module
if ( $multipart ) {
foreach ( keys %header ) {
my ($data);
local($\) = '';
- while (defined($data = $buffer->read)) {
+ my $totalbytes;
+ while (defined($data = $buffer->read)) {
+ if (defined $self->{'.upload_hook'})
+ {
+ $totalbytes += length($data);
+ &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'});
+ }
print $filehandle $data;
- }
+ }
# back up to beginning of file
seek($filehandle,0,0);
# Save some information about the uploaded file where we can get
# at it later.
$self->{'.tmpfiles'}->{fileno($filehandle)}= {
+ hndl => $filehandle,
name => $tmpfile,
info => {%header},
};
return '' unless defined($attributes->{$element});
$attribs = ' ';
foreach my $attrib (keys %{$attributes->{$element}}) {
- $attrib =~ s/^-//;
- $attribs .= "@{[lc($attrib)]}=\"$attributes->{$element}{$attrib}\" ";
+ (my $clean_attrib = $attrib) =~ s/^-//;
+ $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" ";
}
$attribs =~ s/ $//;
return $attribs;
######################## MultipartBuffer ####################
package MultipartBuffer;
+use constant DEBUG => 0;
+
# how many bytes to read at a time. We use
# a 4K buffer by default.
$INITIAL_FILLUNIT = 1024 * 4;
'new' => <<'END_OF_FUNC',
sub new {
- my($package,$interface,$boundary,$length,$filehandle) = @_;
+ my($package,$interface,$boundary,$length) = @_;
$FILLUNIT = $INITIAL_FILLUNIT;
- my $IN;
- if ($filehandle) {
- my($package) = caller;
- # force into caller's package if necessary
- $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
- }
- $IN = "main::STDIN" unless $IN;
-
- $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode;
+ $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always
# If the user types garbage into the file upload field,
# then Netscape passes NOTHING to the server (not good).
} else { # otherwise we find it ourselves
my($old);
($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
- $boundary = <$IN>; # BUG: This won't work correctly under mod_perl
+ $boundary = <STDIN>; # BUG: This won't work correctly under mod_perl
$length -= length($boundary);
chomp($boundary); # remove the CRLF
$/ = $old; # restore old line separator
my $self = {LENGTH=>$length,
BOUNDARY=>$boundary,
- IN=>$IN,
INTERFACE=>$interface,
BUFFER=>'',
};
unless ($boundary_read) {
while ($self->read(0)) { }
}
- die "Malformed multipart POST\n" if $self->eof;
+ die "Malformed multipart POST: data truncated\n" if $self->eof;
return $retval;
}
my($ok) = 0;
my($bad) = 0;
- local($CRLF) = "\015\012" if $CGI::OS eq 'VMS';
+ local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC;
do {
$self->fillBuffer($FILLUNIT);
} until $ok || $bad;
return () if $bad;
+ #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines!
+
my($header) = substr($self->{BUFFER},0,$end+2);
substr($self->{BUFFER},0,$end+4) = '';
my %return;
+ if ($CGI::EBCDIC) {
+ warn "untranslated header=$header\n" if DEBUG;
+ $header = CGI::Util::ascii2ebcdic($header);
+ warn "translated header=$header\n" if DEBUG;
+ }
+
# 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($self) = @_;
my($data);
my($returnval)='';
+
+ #EBCDIC NOTE: want to translate returnval into EBCDIC HERE
+
while (defined($data = $self->read)) {
$returnval .= $data;
}
+
+ if ($CGI::EBCDIC) {
+ warn "untranslated body=$returnval\n" if DEBUG;
+ $returnval = CGI::Util::ascii2ebcdic($returnval);
+ warn "translated body=$returnval\n" if DEBUG;
+ }
return $returnval;
}
END_OF_FUNC
my($self,$bytes) = @_;
# default number of bytes to read
- $bytes = $bytes || $FILLUNIT;
+ $bytes = $bytes || $FILLUNIT;
# Fill up our internal buffer in such a way that the boundary
# is never split between reads.
$self->fillBuffer($bytes);
+ my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY};
+ my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--';
+
# Find the boundary in the buffer (it may not be there).
- my $start = index($self->{BUFFER},$self->{BOUNDARY});
+ my $start = index($self->{BUFFER},$boundary_start);
+
+ warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if DEBUG;
# protect against malformed multipart POST operations
die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0);
+
+ #EBCDIC NOTE: want to translate boundary search into ASCII here.
+
# If the boundary begins the data, then skip past it
# and return undef.
if ($start == 0) {
# clear us out completely if we've hit the last boundary.
- if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
+ if (index($self->{BUFFER},$boundary_end)==0) {
$self->{BUFFER}='';
$self->{LENGTH}=0;
return undef;
}
# just remove the boundary.
- substr($self->{BUFFER},0,length($self->{BOUNDARY}))='';
+ substr($self->{BUFFER},0,length($boundary_start))='';
$self->{BUFFER} =~ s/^\012\015?//;
return undef;
}
# leave enough bytes in the buffer to allow us to read
# the boundary. Thanks to Kevin Hendrick for finding
# this one.
- $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1);
+ $bytesToReturn = $bytes - (length($boundary_start)+1);
}
my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
$bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead;
- # Try to read some data. We may hang here if the browser is screwed up.
- my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN},
- \$self->{BUFFER},
+ # Try to read some data. We may hang here if the browser is screwed up.
+ my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER},
$bytesToRead,
$bufferLength);
+ warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if DEBUG;
$self->{BUFFER} = '' unless defined $self->{BUFFER};
# An apparent bug in the Apache server causes the read()
####################################################################################
package CGITempFile;
-$SL = $CGI::SL;
-$MAC = $CGI::OS eq 'MACINTOSH';
-my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
-unless ($TMPDIRECTORY) {
+sub find_tempdir {
+ undef $TMPDIRECTORY;
+ $SL = $CGI::SL;
+ $MAC = $CGI::OS eq 'MACINTOSH';
+ my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
+ unless ($TMPDIRECTORY) {
@TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
"C:${SL}temp","${SL}tmp","${SL}temp",
"${vol}${SL}Temporary Items",
# unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0;
foreach (@TEMP) {
- do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
+ do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
}
+ }
+ $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
}
-$TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
+find_tempdir();
+
$MAXTRIES = 5000;
# cute feature, but overload implementation broke it
sub new {
my($package,$sequence) = @_;
my $filename;
+ find_tempdir() unless -w $TMPDIRECTORY;
for (my $i = 0; $i < $MAXTRIES; $i++) {
last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++));
}
feature. Thanks to Michalis Kabrianis <kabrianis@hellug.gr> for this
feature.
+If start_html()'s -dtd parameter specifies an HTML 2.0 or 3.2 DTD,
+XHTML will automatically be disabled without needing to use this
+pragma.
+
=item -nph
This makes CGI.pm produce a header appropriate for an NPH (no
you use redirection like this, you should B<not> print out a header as
well.
-One hint I can offer is that relative links may not work correctly
-when you generate a redirection to another document on your site.
-This is due to a well-intentioned optimization that some servers use.
-The solution to this is to use the full URL (including the http: part)
-of the document you are redirecting to.
+You should always use full URLs (including the http: or ftp: part) in
+redirection requests. Relative URLs will not work correctly.
You can also use named arguments:
print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
- -nph=>1);
+ -nph=>1,
+ -status=>301);
The B<-nph> parameter, if set to a true value, will issue the correct
headers to work with a NPH (no-parse-header) script. This is important
-to use with certain servers, such as Microsoft Internet Explorer, which
+to use with certain servers, such as Microsoft IIS, which
expect all their scripts to be NPH.
+The B<-status> parameter will set the status of the redirect. HTTP
+defines three different possible redirection status codes:
+
+ 301 Moved Permanently
+ 302 Found
+ 303 See Other
+
+The default if not specified is 302, which means "moved temporarily."
+You may change the status to another status code if you wish. Be
+advised that changing the status to anything other than 301, 302 or
+303 will probably break redirection.
+
=head2 CREATING THE HTML DOCUMENT HEADER
print $query->start_html(-title=>'Secrets of the Pyramids',
information.
The B<-lang> argument is used to incorporate a language attribute into
-the <html> tag. The default if not specified is "en-US" for US
-English. For example:
+the <html> tag. For example:
print $q->start_html(-lang=>'fr-CA');
-To leave off the lang attribute, as you must do if you want to generate
-legal HTML 3.2 or earlier, pass the empty string (-lang=>'').
+The default if not specified is "en-US" for US English, unless the
+-dtd parameter specifies an HTML 2.0 or 3.2 DTD, in which case the
+lang attribute is left off. You can force the lang attribute to left
+off in other cases by passing an empty string (-lang=>'').
The B<-encoding> argument can be used to specify the character set for
XHTML. It defaults to iso-8859-1 if not specified.
=head2 MIXING POST AND URL PARAMETERS
- $color = $query->url_param('color');
+ $color = $query->url_param('color');
It is possible for a script to receive CGI parameters in the URL as
well as in the fill-out form by creating a form that POSTs to a URL
$query = new CGI;
$query->autoEscape(undef);
+I<A Lurking Trap!> Some of the form-element generating methods return
+multiple tags. In a scalar context, the tags will be concatenated
+together with spaces, or whatever is the current value of the $"
+global. In a list context, the methods will return a list of
+elements, allowing you to modify them if you wish. Usually you will
+not notice this behavior, but beware of this:
+
+ printf("%s\n",$query->end_form())
+
+end_form() produces several tags, and only the first of them will be
+printed because the format only expects one value.
+
+<p>
+
+
=head2 CREATING AN ISINDEX TAG
print $query->isindex(-action=>$action);
print;
}
-In an array context, upload() will return an array of filehandles.
+In an list context, upload() will return an array of filehandles.
This makes it possible to create forms that use the same name for
multiple upload fields.
You are free to create a custom HTML page to complain about the error,
if you wish.
+You can set up a callback that will be called whenever a file upload
+is being read during the form processing. This is much like the
+UPLOAD_HOOK facility available in Apache::Request, with the exception
+that the first argument to the callback is an Apache::Upload object,
+here it's the remote filename.
+
+ $q = CGI->new();
+ $q->upload_hook(\&hook,$data);
+
+ sub hook
+ {
+ my ($filename, $buffer, $bytes_read, $data) = @_;
+ print "Read $bytes_read bytes of $filename\n";
+ }
+
+If using the function-oriented interface, call the CGI::upload_hook()
+method before calling param() or any other CGI functions:
+
+ CGI::upload_hook(\&hook,$data);
+
+This method is not exported by default. You will have to import it
+explicitly if you wish to use it without the CGI:: prefix.
+
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
associative array with the attribute's name as the key and the
attribute's value as the value.
+=back
+
=head2 CREATING A SCROLLING LIST
print $query->scrolling_list('list_name',
The first argument (-name) is optional. You can give the button a
name if you have several submission buttons in your form and you want
-to distinguish between them. The name will also be used as the
-user-visible label. Be aware that a few older browsers don't deal with this correctly and
-B<never> send back a value from a button.
+to distinguish between them.
=item 2.
The second argument (-value) is also optional. This gives the button
-a value that will be passed to your script in the query string.
+a value that will be passed to your script in the query string. The
+name will also be used as the user-visible label.
+
+=item 3.
+
+You can use -label as an alias for -value. I always get confused
+about which of -name and -value changes the user-visible label on the
+button.
=back
CGI.pm has limited support for HTML3's cascading style sheets (css).
To incorporate a stylesheet into your document, pass the
start_html() method a B<-style> parameter. The value of this
-parameter may be a scalar, in which case it is incorporated directly
-into a <style> section, or it may be a hash reference. In the latter
+parameter may be a scalar, in which case it is treated as the source
+URL for the stylesheet, or it may be a hash reference. In the latter
case you should provide the hash with one or more of B<-src> or
B<-code>. B<-src> points to a URL where an externally-defined
stylesheet can be found. B<-code> points to a scalar value to be
);
print end_html;
-Pass an array reference to B<-style> in order to incorporate multiple
-stylesheets into your document.
+Pass an array reference to B<-code> or B<-src> in order to incorporate
+multiple stylesheets into your document.
Should you wish to incorporate a verbatim stylesheet that includes
arbitrary formatting in the header, you may pass a -verbatim tag to
@import url("/server-common/css/main.css");
</style>
+Any additional arguments passed in the -style value will be
+incorporated into the <link> tag. For example:
+
+ start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'],
+ -media => 'all'});
+
+This will give:
+
+ <link rel="stylesheet" type="text/css" href="/styles/print.css" media="all"/>
+ <link rel="stylesheet" type="text/css" href="/styles/layout.css" media="all"/>
+
+<p>
+
+To make more complicated <link> tags, use the Link() function
+and pass it to start_html() in the -head argument, as in:
+
+ @h = (Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/ss.css',-media=>'all'}),
+ Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'}));
+ print start_html({-head=>\@h})
+
=head1 DEBUGGING
If you are running the script from the command line or in the perl
your_script.pl "name1='I am a long value'" "name2=two\ words"
+Finally, you can set the path info for the script by prefixing the first
+name/value parameter with the path followed by a question mark (?):
+
+ your_script.pl /your/path/here?name1=value1&name2=value2
+
=head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
The Dump() method produces a string consisting of all the query's
Return the port that the server is listening on.
+=item B<virtual_port ()>
+
+Like server_port() except that it takes virtual hosts into account.
+Use this when running with virtual hosts.
+
=item B<server_software ()>
Returns the server software and version number.
NEW VERSION
use CGI;
- CGI::ReadParse
+ CGI::ReadParse;
print "The value of the antique is $in{antique}.\n";
CGI.pm's ReadParse() routine creates a tied variable named %in,
https://perl5.git.perl.org / perl5.git / blobdiff