X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/84601d63a7e34958da47dad1e61e27cb3bd467d1..11911e219c403b8773ab8f4e97d5fb23c092aa86:/cpan/CGI/lib/CGI.pm
diff --git a/cpan/CGI/lib/CGI.pm b/cpan/CGI/lib/CGI.pm
index c0f6752..d8d91f4 100644
--- a/cpan/CGI/lib/CGI.pm
+++ b/cpan/CGI/lib/CGI.pm
@@ -1,5 +1,5 @@
package CGI;
-require 5.004;
+require 5.008001;
use Carp 'croak';
# See the bottom of this file for the POD documentation. Search for the
@@ -16,11 +16,11 @@ use Carp 'croak';
# listing the modifications you have made.
# The most recent version and complete docs are available at:
-# http://stein.cshl.org/WWW/software/CGI/
+# http://search.cpan.org/dist/CGI.pm
# The revision is no longer being updated since moving to git.
$CGI::revision = '$Id: CGI.pm,v 1.266 2009/07/30 16:32:34 lstein Exp $';
-$CGI::VERSION='3.50';
+$CGI::VERSION='3.62';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
@@ -129,10 +129,6 @@ sub initialize_globals {
# ------------------ START OF THE LIBRARY ------------
-#### Method: endform
-# This method is DEPRECATED
-*endform = \&end_form;
-
# make mod_perlhappy
initialize_globals();
@@ -386,7 +382,7 @@ sub new {
# user is still holding any reference to them as well.
sub DESTROY {
my $self = shift;
- if ($OS eq 'WINDOWS') {
+ if ($OS eq 'WINDOWS' || $OS eq 'VMS') {
for my $href (values %{$self->{'.tmpfiles'}}) {
$href->{hndl}->DESTROY if defined $href->{hndl};
$href->{name}->DESTROY if defined $href->{name};
@@ -525,12 +521,12 @@ sub init {
# 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 (defined(@QUERY_PARAM) && !defined($initializer)) {
+ if (@QUERY_PARAM && !defined($initializer)) {
for my $name (@QUERY_PARAM) {
my $val = $QUERY_PARAM{$name}; # always an arrayref;
$self->param('-name'=>$name,'-value'=> $val);
if (defined $val and ref $val eq 'ARRAY') {
- for my $fh (grep {defined(fileno($_))} @$val) {
+ for my $fh (grep {defined($_) && ref($_) && defined(fileno($_))} @$val) {
seek($fh,0,0); # reset the filehandle.
}
@@ -648,9 +644,9 @@ sub init {
last METHOD;
}
- # If method is GET or HEAD, fetch the query from
+ # If method is GET, HEAD or DELETE, fetch the query from
# the environment.
- if ($is_xforms || $meth=~/^(GET|HEAD)$/) {
+ if ($is_xforms || $meth=~/^(GET|HEAD|DELETE)$/) {
if ($MOD_PERL) {
$query_string = $self->r->args;
} else {
@@ -664,14 +660,6 @@ sub init {
if ( $content_length > 0 ) {
$self->read_from_client(\$query_string,$content_length,0);
}
- elsif (not defined $ENV{CONTENT_LENGTH}) {
- $self->read_from_stdin(\$query_string);
- # should this be PUTDATA in case of PUT ?
- my($param) = $meth . 'DATA' ;
- $self->add_parameter($param) ;
- push (@{$self->{param}{$param}},$query_string);
- undef $query_string ;
- }
# Some people want to have their cake and eat it too!
# Uncomment this line to have the contents of the query string
# APPENDED to the POST data.
@@ -820,7 +808,7 @@ sub all_parameters {
# put a filehandle into binary mode (DOS)
sub binmode {
- return unless defined($_[1]) && defined fileno($_[1]);
+ return unless defined($_[1]) && ref ($_[1]) && defined fileno($_[1]);
CORE::binmode($_[1]);
}
@@ -1024,47 +1012,6 @@ sub read_from_client {
}
END_OF_FUNC
-'read_from_stdin' => <<'END_OF_FUNC',
-# Read data from stdin until all is read
-sub read_from_stdin {
- my($self, $buff) = @_;
- local $^W=0; # prevent a warning
-
- #
- # TODO: loop over STDIN until all is read
- #
-
- my($eoffound) = 0;
- my($localbuf) = '';
- my($tempbuf) = '';
- my($bufsiz) = 1024;
- my($res);
- while ($eoffound == 0) {
- if ( $MOD_PERL ) {
- $res = $self->r->read($tempbuf, $bufsiz, 0)
- }
- else {
- $res = read(\*STDIN, $tempbuf, $bufsiz);
- }
-
- if ( !defined($res) ) {
- # TODO: how to do error reporting ?
- $eoffound = 1;
- last;
- }
- if ( $res == 0 ) {
- $eoffound = 1;
- last;
- }
- $localbuf .= $tempbuf;
- }
-
- $$buff = $localbuf;
-
- return $res;
-}
-END_OF_FUNC
-
'delete' => <<'END_OF_FUNC',
#### Method: delete
# Deletes the named parameter entirely.
@@ -1559,7 +1506,7 @@ sub header {
$header =~ s/$CRLF(\s)/$1/g;
# All other uses of newlines are invalid input.
- if ($header =~ m/$CRLF/) {
+ if ($header =~ m/$CRLF|\015|\012/) {
# shorten very long values in the diagnostic
$header = substr($header,0,72).'...' if (length $header > 72);
die "Invalid header value contains a newline not followed by whitespace: $header";
@@ -1571,12 +1518,8 @@ sub header {
$type ||= 'text/html' unless defined($type);
- if (defined $charset) {
- $self->charset($charset);
- } else {
- $charset = $self->charset if $type =~ /^text\//;
- }
- $charset ||= '';
+ # sets if $charset is given, gets if not
+ $charset = $self->charset( $charset );
# rearrange() was designed for the HTML portion, so we
# need to fix it up a little.
@@ -1861,20 +1804,20 @@ sub _script {
my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
for $script (@scripts) {
- my($src,$code,$language);
- if (ref($script)) { # script is a hash
- ($src,$code,$type) =
- rearrange(['SRC','CODE',['LANGUAGE','TYPE']],
- '-foo'=>'bar', # a trick to allow the '-' to be omitted
- ref($script) eq 'ARRAY' ? @$script : %$script);
+ my($src,$code,$language,$charset);
+ if (ref($script)) { # script is a hash
+ ($src,$code,$type,$charset) =
+ rearrange(['SRC','CODE',['LANGUAGE','TYPE'],'CHARSET'],
+ '-foo'=>'bar', # a trick to allow the '-' to be omitted
+ ref($script) eq 'ARRAY' ? @$script : %$script);
$type ||= 'text/javascript';
unless ($type =~ m!\w+/\w+!) {
$type =~ s/[\d.]+$//;
$type = "text/$type";
}
- } else {
- ($src,$code,$type) = ('',$script, 'text/javascript');
- }
+ } else {
+ ($src,$code,$type,$charset) = ('',$script, 'text/javascript', '');
+ }
my $comment = '//'; # javascript by default
$comment = '#' if $type=~/perl|tcl/i;
@@ -1892,6 +1835,7 @@ sub _script {
my(@satts);
push(@satts,'src'=>$src) if $src;
push(@satts,'type'=>$type);
+ push(@satts,'charset'=>$charset) if ($src && $charset);
$code = $cdata_start . $code . $cdata_end if defined $code;
push(@result,$self->script({@satts},$code || ''));
}
@@ -1956,7 +1900,7 @@ sub startform {
$action = qq(action="$action");
my($other) = @other ? " @other" : '';
$self->{'.parametersToAdd'}={};
- return qq/") : "\n";
+ } else {
+ if (my @fields = $self->get_fields) {
+ return wantarray ? ("
",@fields,"
","")
+ : "
".(join '',@fields)."
\n";
+ } else {
+ return "";
+ }
+ }
+}
+END_OF_FUNC
+
#### Method: end_multipart_form
# end a multipart form
'end_multipart_form' => <<'END_OF_FUNC',
@@ -2363,7 +2324,7 @@ sub unescapeHTML {
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[&(\S*?);]{
+ $string=~ s[&([^\s&]*?);]{
local $_ = $1;
/^amp$/i ? "&" :
/^quot$/i ? '"' :
@@ -2371,7 +2332,7 @@ sub unescapeHTML {
/^lt$/i ? "<" :
/^#(\d+)$/ && $latin ? chr($1) :
/^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
- $_
+ "&$_;"
}gex;
return $string;
}
@@ -2859,7 +2820,6 @@ sub url {
my $query_str = $self->query_string;
my $rewrite_in_use = $request_uri && $request_uri !~ /^\Q$script_name/;
- undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active
my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
$uri =~ s/\?.*$//s; # remove query string
@@ -2961,6 +2921,8 @@ END_OF_FUNC
sub param_fetch {
my($self,@p) = self_or_default(@_);
my($name) = rearrange([NAME],@p);
+ return [] unless defined $name;
+
unless (exists($self->{param}{$name})) {
$self->add_parameter($name);
$self->{param}{$name} = [];
@@ -3532,11 +3494,11 @@ sub read_from_cmdline {
if ($DEBUG && @ARGV) {
@words = @ARGV;
} elsif ($DEBUG > 1) {
- require "shellwords.pl";
+ require Text::ParseWords;
print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n";
chomp(@lines = ); # remove newlines
$input = join(" ",@lines);
- @words = &shellwords($input);
+ @words = &Text::ParseWords::old_shellwords($input);
}
for (@words) {
s/\\=/%3D/g;
@@ -3636,7 +3598,7 @@ sub read_multipart {
last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
$seqno += int rand(100);
}
- die "CGI open of tmpfile: $!\n" unless defined $filehandle;
+ die "CGI.pm open of tmpfile $tmp/$filename failed: $!\n" unless defined $filehandle;
$CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
&& defined fileno($filehandle);
@@ -4271,7 +4233,10 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
sub new {
my($package,$sequence) = @_;
my $filename;
- find_tempdir() unless -w $TMPDIRECTORY;
+ unless (-w $TMPDIRECTORY) {
+ $TMPDIRECTORY = undef;
+ find_tempdir();
+ }
for (my $i = 0; $i < $MAXTRIES; $i++) {
last if ! -f ($filename = sprintf("\%s${SL}CGItemp%d", $TMPDIRECTORY, $sequence++));
}
@@ -4522,7 +4487,7 @@ HTML "standards".
$query = CGI->new;
-This will parse the input (from both POST and GET methods) and store
+This will parse the input (from POST, GET and DELETE methods) and store
it into a perl5 object called $query.
Any filehandles from file uploads will have their position reset to
@@ -5129,8 +5094,7 @@ file is created with mode 0600 (neither world nor group readable).
The temporary directory is selected using the following algorithm:
- 1. if the current user (e.g. "nobody") has a directory named
- "tmp" in its home directory, use that (Unix systems only).
+ 1. if $CGITempFile::TMPDIRECTORY is already set, use that
2. if the environment variable TMPDIR exists, use the location
indicated.
@@ -5233,7 +5197,8 @@ header() returns the Content-type: header. You can provide your own
MIME type if you choose, otherwise it defaults to text/html. An
optional second parameter specifies the status code and a human-readable
message. For example, you can specify 204, "No response" to create a
-script that tells the browser to do nothing at all.
+script that tells the browser to do nothing at all. Note that RFC 2616 expects
+the human-readable phase to be there as well as the numeric status code.
The last example shows the named argument style for passing arguments
to the CGI methods using named parameters. Recognized parameters are
@@ -5292,17 +5257,14 @@ In either case, the outgoing header will be formatted as:
P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa"
-Note that if a header value contains a carriage return, a leading space will be
-added to each new line that doesn't already have one as specified by RFC2616
-section 4.2. For example:
-
- print header( -ingredients => "ham\neggs\nbacon" );
+CGI.pm will accept valid multi-line headers when each line is separated with a
+CRLF value ("\r\n" on most platforms) followed by at least one space. For example:
-will generate
+ print header( -ingredients => "ham\r\n\seggs\r\n\sbacon" );
- Ingredients: ham
- eggs
- bacon
+Invalid multi-line header input will trigger in an exception. When multi-line headers
+are received, CGI.pm will always output them back as a single line, according to the
+folding rules of RFC 2616: the newlines will be removed, while the white space remains.
=head2 GENERATING A REDIRECTION HEADER
@@ -5324,7 +5286,7 @@ You can also use named arguments:
print $q->redirect(
-uri=>'http://somewhere.else/in/movie/land',
-nph=>1,
- -status=>301);
+ -status=>'301 Moved Permanently');
All names arguments recognized by header() are also recognized by
redirect(). However, most HTTP headers, including those generated by
@@ -5347,6 +5309,9 @@ 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.
+Note that the human-readable phrase is also expected to be present to conform
+with RFC 2616, section 6.1.
+
=head2 CREATING THE HTML DOCUMENT HEADER
print start_html(-title=>'Secrets of the Pyramids',
@@ -5358,8 +5323,7 @@ advised that changing the status to anything other than 301, 302 or
-style=>{'src'=>'/styles/style1.css'},
-BGCOLOR=>'blue');
-After creating the HTTP header, most CGI scripts will start writing
-out an HTML document. The start_html() routine creates the top of the
+The start_html() routine creates the top of the
page, along with a lot of optional information that controls the
page's appearance and behavior.
@@ -5413,6 +5377,18 @@ 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.
+The B<-dtd> argument can be used to specify a public DTD identifier string. For example:
+
+ -dtd => '-//W3C//DTD HTML 4.01 Transitional//EN')
+
+Alternatively, it can take public and system DTD identifiers as an array:
+
+ dtd => [ '-//W3C//DTD HTML 4.01 Transitional//EN', 'http://www.w3.org/TR/html4/loose.dtd' ]
+
+For the public DTD identifier to be considered, it must be valid. Otherwise it
+will be replaced by the default DTD. If the public DTD contains 'XHTML', CGI.pm
+will emit XML.
+
The B<-declare_xml> argument, when used in conjunction with XHTML,
will put a declaration at the top of the HTML header. The sole
purpose of this declaration is to declare the character set
@@ -5421,11 +5397,11 @@ a tag that specifies the encoding, allowing the HTML to pass
most validators. The default for -declare_xml is false.
You can place other arbitrary HTML elements to the section with the
-B<-head> tag. For example, to place the rarely-used element in the
+B<-head> tag. For example, to place a element in the
head section, use this:
- print start_html(-head=>Link({-rel=>'next',
- -href=>'http://www.capricorn.com/s2.html'}));
+ print start_html(-head=>Link({-rel=>'shortcut icon',
+ -href=>'favicon.ico'}));
To incorporate multiple HTML elements into the section, just pass an
array reference:
@@ -5487,12 +5463,10 @@ Use the B<-noScript> parameter to pass some HTML text that will be displayed on
browsers that do not have JavaScript (or browsers where JavaScript is turned
off).
-The