");
}
@@ -1181,7 +1253,8 @@ sub multipart_start {
# rearrange() was designed for the HTML portion, so we
# need to fix it up a little.
foreach (@other) {
- next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
+ # Don't use \s because of perl bug 21951
+ next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
}
push(@header,@other);
@@ -1229,11 +1302,11 @@ sub header {
return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE;
- my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,@other) =
+ my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) =
rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
'STATUS',['COOKIE','COOKIES'],'TARGET',
'EXPIRES','NPH','CHARSET',
- 'ATTACHMENT'],@p);
+ 'ATTACHMENT','P3P'],@p);
$nph ||= $NPH;
if (defined $charset) {
@@ -1245,13 +1318,13 @@ sub header {
# 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;
- $header = ucfirst($header);
+ # Don't use \s because of perl bug 21951
+ next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
+ ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
}
$type ||= 'text/html' unless defined($type);
- $type .= "; charset=$charset" if $type ne '' and $type =~ m!^text/! and $type !~ /\bcharset\b/;
+ $type .= "; charset=$charset" if $type ne '' and $type =~ m!^text/! and $type !~ /\bcharset\b/ and $charset ne '';
# Maybe future compatibility. Maybe not.
my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
@@ -1260,6 +1333,10 @@ sub header {
push(@header,"Status: $status") if $status;
push(@header,"Window-Target: $target") if $target;
+ if ($p3p) {
+ $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
+ push(@header,qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p"));
+ }
# push all the cookies -- there may be several
if ($cookie) {
my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
@@ -1278,12 +1355,10 @@ sub header {
push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
push(@header,map {ucfirst $_} @other);
push(@header,"Content-Type: $type") if $type ne '';
-
my $header = join($CRLF,@header)."${CRLF}${CRLF}";
if ($MOD_PERL and not $nph) {
- my $r = Apache->request;
- $r->send_cgi_header($header);
- return '';
+ $self->r->send_cgi_header($header);
+ return '';
}
return $header;
}
@@ -1313,18 +1388,19 @@ END_OF_FUNC
'redirect' => <<'END_OF_FUNC',
sub redirect {
my($self,@p) = self_or_default(@_);
- my($url,$target,$cookie,$nph,@other) = rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p);
+ my($url,$target,$cookie,$nph,@other) = rearrange([[LOCATION,URI,URL],TARGET,['COOKIE','COOKIES'],NPH],@p);
$url ||= $self->self_url;
my(@o);
foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
unshift(@o,
- '-Status'=>'302 Moved',
- '-Location'=>$url,
- '-nph'=>$nph);
+ '-Status' => '302 Moved',
+ '-Location'=> $url,
+ '-nph' => $nph);
unshift(@o,'-Target'=>$target) if $target;
- unshift(@o,'-Cookie'=>$cookie) if $cookie;
unshift(@o,'-Type'=>'');
- return $self->header(@o);
+ my @unescaped;
+ unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
+ return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped);
}
END_OF_FUNC
@@ -1361,7 +1437,7 @@ sub start_html {
# while the author needs to be escaped as a URL
$title = $self->escapeHTML($title || 'Untitled Document');
$author = $self->escape($author);
- $lang ||= 'en-US';
+ $lang = 'en-US' unless defined $lang;
my(@result,$xml_dtd);
if ($dtd) {
if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
@@ -1383,7 +1459,8 @@ sub start_html {
push(@result,qq());
}
push(@result,$XHTML ? qq($title)
- : qq($title));
+ : ($lang ? qq() : "")
+ . "$title");
if (defined $author) {
push(@result,$XHTML ? ""
: "");
@@ -1432,28 +1509,35 @@ sub _style {
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
+ my($src,$code,$verbatim,$stype,$foo,@other) =
+ rearrange([SRC,CODE,VERBATIM,TYPE],
+ '-foo'=>'bar', # trick to allow dash to be omitted
ref($style) eq 'ARRAY' ? @$style : %$style);
- $type = $stype if $stype;
+ $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)
+ { # If it is, push a LINK tag for each one
+ foreach $src (@$src)
{
- push(@result,$XHTML ? qq()
- : qq()) if $src;
+ push(@result,$XHTML ? qq()
+ : qq()) if $src;
}
}
else
{ # Otherwise, push the single -src, if it exists.
- push(@result,$XHTML ? qq()
- : qq()
+ push(@result,$XHTML ? qq()
+ : qq()
) if $src;
}
- push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code;
+ if ($verbatim) {
+ push(@result, "");
+ }
+ 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"));
+ my $src = $style;
+ push(@result,$XHTML ? qq()
+ : qq());
}
@result;
}
@@ -1487,17 +1571,21 @@ sub _script {
$comment = '#' if $type=~/perl|tcl/i;
$comment = "'" if $type=~/vbscript/i;
- my $cdata_start = "\n\n";
-
- my(@satts);
- push(@satts,'src'=>$src) if $src;
- push(@satts,'language'=>$language);
- 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";
+ } else {
+ $cdata_start = "\n\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;
}
@@ -1551,9 +1639,9 @@ sub startform {
$method = lc($method) || 'post';
$enctype = $enctype || &URL_ENCODED;
unless (defined $action) {
- $action = $self->url(-absolute=>1,-path=>1);
+ $action = $self->escapeHTML($self->url(-absolute=>1,-path=>1));
if (length($ENV{QUERY_STRING})>0) {
- $action .= "?$ENV{QUERY_STRING}";
+ $action .= "?".$self->escapeHTML($ENV{QUERY_STRING},1);
}
}
$action = qq(action="$action");
@@ -1604,8 +1692,8 @@ sub endform {
if ( $NOSTICKY ) {
return wantarray ? ("") : "\n";
} else {
- return wantarray ? ($self->get_fields,"") :
- $self->get_fields ."\n";
+ return wantarray ? ("
",$self->get_fields,"
","") :
+ "
".$self->get_fields ."
\n";
}
}
END_OF_FUNC
@@ -1624,7 +1712,7 @@ END_OF_FUNC
sub _textfield {
my($self,$tag,@p) = self_or_default(@_);
my($name,$default,$size,$maxlength,$override,@other) =
- rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
+ rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
my $current = $override ? $default :
(defined($self->param($name)) ? $self->param($name) : $default);
@@ -1779,7 +1867,7 @@ sub submit {
my($name) = ' name=".submit"' unless $NOSTICKY;
$name = qq/ name="$label"/ if defined($label);
$value = defined($value) ? $value : $label;
- my($val) = '';
+ my $val = '';
$val = qq/ value="$value"/ if defined($value);
my($other) = @other ? " @other" : '';
return $XHTML ? qq()
@@ -1798,12 +1886,17 @@ END_OF_FUNC
'reset' => <<'END_OF_FUNC',
sub reset {
my($self,@p) = self_or_default(@_);
- my($label,@other) = rearrange([NAME],@p);
+ my($label,$value,@other) = rearrange(['NAME',['VALUE','LABEL']],@p);
$label=$self->escapeHTML($label);
- my($value) = defined($label) ? qq/ value="$label"/ : '';
+ $value=$self->escapeHTML($value,1);
+ my ($name) = ' name=".reset"';
+ $name = qq/ name="$label"/ if defined($label);
+ $value = defined($value) ? $value : $label;
+ my($val) = '';
+ $val = qq/ value="$value"/ if defined($value);
my($other) = @other ? " @other" : '';
- return $XHTML ? qq()
- : qq();
+ return $XHTML ? qq()
+ : qq();
}
END_OF_FUNC
@@ -1950,6 +2043,8 @@ sub checkbox_group {
$self->register_parameter($name);
return wantarray ? @elements : join(' ',@elements)
unless defined($columns) || defined($rows);
+ $rows = 1 if $rows && $rows < 1;
+ $cols = 1 if $cols && $cols < 1;
return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
}
END_OF_FUNC
@@ -2395,11 +2490,11 @@ sub url {
# for compatibility with Apache's MultiViews
if (exists($ENV{REQUEST_URI})) {
my $index;
- $script_name = $ENV{REQUEST_URI};
+ $script_name = unescape($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;
+ my $encoded_path = quotemeta($ENV{PATH_INFO});
$script_name =~ s/$encoded_path$//i;
}
}
@@ -2900,6 +2995,17 @@ sub private_tempfiles {
return $CGI::PRIVATE_TEMPFILES;
}
END_OF_FUNC
+#### Method: close_upload_files
+# Set or return the close_upload_files global flag
+####
+'close_upload_files' => <<'END_OF_FUNC',
+sub close_upload_files {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::CLOSE_UPLOAD_FILES = $param if defined($param);
+ return $CGI::CLOSE_UPLOAD_FILES;
+}
+END_OF_FUNC
+
#### Method: default_dtd
# Set or return the default_dtd global
@@ -3007,13 +3113,17 @@ sub read_multipart {
# Bug: Netscape doesn't escape quotation marks in file names!!!
my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\"]*)"?/;
+ # Test for Opera's multiple upload feature
+ my($multipart) = ( defined( $header{'Content-Type'} ) &&
+ $header{'Content-Type'} =~ /multipart\/mixed/ ) ?
+ 1 : 0;
# 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.
- if ( !defined($filename) || $filename eq '' ) {
+ if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) {
my($value) = $buffer->readBody;
$value .= $TAINTED;
push(@{$self->{$param}},$value);
@@ -3032,6 +3142,11 @@ sub read_multipart {
last UPLOADS;
}
+ # set the filename to some recognizable value
+ if ( ( !defined($filename) || $filename eq '' ) && $multipart ) {
+ $filename = "multipart/mixed";
+ }
+
# choose a relatively unpredictable tmpfile sequence number
my $seqno = unpack("%16C*",join('',localtime,values %ENV));
for (my $cnt=10;$cnt>0;$cnt--) {
@@ -3043,6 +3158,16 @@ sub read_multipart {
die "CGI open of tmpfile: $!\n" unless defined $filehandle;
$CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
+ # if this is an multipart/mixed attachment, save the header
+ # together with the body for lateron parsing with an external
+ # MIME parser module
+ if ( $multipart ) {
+ foreach ( keys %header ) {
+ print $filehandle "$_: $header{$_}${CRLF}";
+ }
+ print $filehandle "${CRLF}";
+ }
+
my ($data);
local($\) = '';
while (defined($data = $buffer->read)) {
@@ -3051,6 +3176,12 @@ sub read_multipart {
# back up to beginning of file
seek($filehandle,0,0);
+
+ ## Close the filehandle if requested this allows a multipart MIME
+ ## upload to contain many files, and we won't die due to too many
+ ## open file handles. The user can access the files using the hash
+ ## below.
+ close $filehandle if $CLOSE_UPLOAD_FILES;
$CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
# Save some information about the uploaded file where we can get
@@ -3378,9 +3509,9 @@ sub read {
return undef;
}
- my $bytesToReturn;
+ my $bytesToReturn;
if ($start > 0) { # read up to the boundary
- $bytesToReturn = $start > $bytes ? $bytes : $start;
+ $bytesToReturn = $start-2 > $bytes ? $bytes : $start;
} else { # read the requested number of bytes
# leave enough bytes in the buffer to allow us to read
# the boundary. Thanks to Kevin Hendrick for finding
@@ -3392,7 +3523,7 @@ sub read {
substr($self->{BUFFER},0,$bytesToReturn)='';
# If we hit the boundary, remove the CRLF from the end.
- return (($start > 0) && ($start <= $bytes))
+ return ($bytesToReturn==$start)
? substr($returnval,0,-2) : $returnval;
}
END_OF_FUNC
@@ -3452,10 +3583,12 @@ END_OF_AUTOLOAD
####################################################################################
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",
@@ -3473,11 +3606,14 @@ unless ($TMPDIRECTORY) {
# 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
@@ -3502,6 +3638,7 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
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++));
}
@@ -3860,6 +3997,11 @@ 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.
+
+If the parameter does not exist at all, then param() will return undef
+in a scalar context, and the empty list in a list context.
+
+
=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
$query->param('foo','an','array','of','values');
@@ -3898,7 +4040,12 @@ If no namespace is given, this method will assume 'Q'.
WARNING: don't import anything into 'main'; this is a major security
risk!!!!
-In older versions, this method was called B. As of version 2.20,
+NOTE 1: Variable names are transformed as necessary into legal Perl
+variable names. All non-legal characters are transformed into
+underscores. If you need to keep the original names, you should use
+the param() method instead to access CGI variables by name.
+
+NOTE 2: In older versions, this method was called B. As of version 2.20,
this name has been removed completely to avoid conflict with the built-in
Perl module B operator.
@@ -4451,7 +4598,7 @@ such as expiration time. Use the cookie() method to create and retrieve
session cookies.
The B<-nph> parameter, if set to a true value, will issue the correct
-headers to work with an NPH (no-parse-header) script. This is important
+headers to work with a NPH (no-parse-header) script. This is important
to use with certain servers that expect all their scripts to be NPH.
The B<-charset> parameter can be used to control the character set
@@ -4464,6 +4611,17 @@ the user to save it to disk. The value of the argument is the
suggested name for the saved file. In order for this to work, you may
have to set the B<-type> to "application/octet-stream".
+The B<-p3p> parameter will add a P3P tag to the outgoing header. The
+parameter can be an arrayref or a space-delimited string of P3P tags.
+For example:
+
+ print header(-p3p=>[qw(CAO DSP LAW CURa)]);
+ print header(-p3p=>'CAO DSP LAW CURa');
+
+In either case, the outgoing header will be formatted as:
+
+ P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa"
+
=head2 GENERATING A REDIRECTION HEADER
print $query->redirect('http://somewhere.else/in/movie/land');
@@ -4488,8 +4646,8 @@ You can also use named arguments:
-nph=>1);
The B<-nph> parameter, if set to a true value, will issue the correct
-headers to work with an NPH (no-parse-header) script. This is important
-to use with certain servers, such as Microsoft Internet Explorer, which
+headers to work with a NPH (no-parse-header) script. This is important
+to use with certain servers, such as Microsoft IIS, which
expect all their scripts to be NPH.
=head2 CREATING THE HTML DOCUMENT HEADER
@@ -4553,6 +4711,9 @@ English. 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 B<-encoding> argument can be used to specify the character set for
XHTML. It defaults to iso-8859-1 if not specified.
@@ -4785,7 +4946,7 @@ Generate just the protocol and net location, as in http://www.foo.com:8000
=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
@@ -4873,19 +5034,19 @@ you prefer:
Sometimes an HTML tag attribute has no argument. For example, ordered
-lists can be marked as COMPACT. The syntax for this is an argument
+lists can be marked as COMPACT. The syntax for this is an argument that
that points to an undef string:
print ol({compact=>undef},li('one'),li('two'),li('three'));
Prior to CGI.pm version 2.41, providing an empty ('') string as an
attribute argument was the same as providing undef. However, this has
-changed in order to accommodate those who want to create tags of the form
+changed in order to accommodate those who want to create tags of the form
. The difference is shown in these two pieces of code:
- CODE RESULT
- img({alt=>undef})
- img({alt=>''})
+ CODE RESULT
+ img({alt=>undef})
+ img({alt=>''})
=head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
@@ -5540,6 +5701,8 @@ a pointer to an associative array relating menu values to another
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',
@@ -6001,7 +6164,6 @@ field.
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
@@ -6300,6 +6462,43 @@ http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information.
Pass an array reference to B<-style> 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
+the -style hash, as follows:
+
+print $q->start_html (-STYLE => {-verbatim => '@import
+url("/server-common/css/'.$cssFile.'");',
+ -src => '/server-common/css/core.css'});
+
+
+
+This will generate an HTML header that contains this:
+
+
+
+
+Any additional arguments passed in the -style value will be
+incorporated into the tag. For example:
+
+ start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'],
+ -media => 'all'});
+
+This will give:
+
+
+
+
+
+
+To make more complicated 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
@@ -6435,7 +6634,6 @@ Returns either the remote host name or IP address.
if the former is unavailable.
=item B
-
Return the script name as a partial URL, for self-refering
scripts.