summaryrefslogtreecommitdiff
path: root/cpan/CGI
diff options
context:
space:
mode:
authorChris 'BinGOs' Williams <chris@bingosnet.co.uk>2011-01-05 23:35:15 +0000
committerChris 'BinGOs' Williams <chris@bingosnet.co.uk>2011-01-05 23:35:15 +0000
commit2a1594f630b57637ddd7a38daaa1e17f66da396a (patch)
tree62a9f16cef549dcd9994838e14e178b4dbc5c3b7 /cpan/CGI
parentb220e8cd5bb9b66ed60b059f802b49aabb4b520e (diff)
downloadperl-2a1594f630b57637ddd7a38daaa1e17f66da396a.tar.gz
Update CGI to CPAN version 3.51
[DELTA] Version 3.51 [NEW FEATURES] - A new option to set $CGI::Carp::TO_BROWSER = 0, allows you to explicitly exclude a particular scope from triggering printing to the browser when fatatlsToBrowser is set. (RT#62783, Thanks to papowell) - The <script> tag now supports the "charset" attribute. (RT#62907, Thanks to Fabrice Metge) - In CGI::Cookie, "Max-Age" is now supported for better spec compliance. (Mark Stosberg) [BUG FIXES] - Setting charset() now works for all content types, not just "text/*". (RT#57945, Thanks to Yanick and Gerv.) - support for user temporary directories ($HOME/tmp) was commented out in 2.61 but the documentation wasn't updated (Peter Gervai, Niko Tyni) - setting $CGITempFile::TMPDIRECTORY before loading CGI.pm has been working but undocumented since 3.12 (which listed it in Changes as $CGI::TMPDIRECTORY) (Peter Gervai, Niko Tyni) - unfortunately the previous change broke the runtime check for looking for a new temporary directory if the current one suddenly became unwritable (Peter Gervai, Niko Tyni) - A bug was fixed in CGI::Carp triggered by certain death cases in the BEGIN phase of parent classes. (RT#57224, Thanks to UNERA, Yanick Champoux, Mark Stosberg) - CGI::Cookie->new() now follows the documentation and returns undef if the -name and -value args aren't provided. This new behavior is also consistent with the docs and code of CGI::Simple::Cookie. (Mark Stosberg) - CGI::Cookie->parse() now trims leading and trailing whitespace from cookie elements as intended. The change also makes this part of the parsing identical to CGI::Simple::Cookie (Mark Stosberg) - Temp file handling was improved (RT#62762) [SECURITY] - Further improvements have been made to guard against newline injections in headers. (Thanks to Max Kanat-Alexander, Yanick Champoux, Mark Stosberg) [PERFORMANCE] - Make EBCDIC a compile-time constant so there's zero overhead (and less compiled code) in subroutines that test for it. (Tim Bunce) - If you just want to use CGI::Cookie, CGI.pm will no longer be loaded unless you call the bake() method, which requires it. (Mark Stosberg) [DOCUMENTATION] - quit referring to the <link> tag as being "rarely used". (Victor Sanders) - typo and whitespace fixes (RT#62785, thanks to scop@cpan.org) - The -dtd argument to start_html() is now documented (RT#60473, Thanks to giecrilj and steve@fisharerojo.org) - CGI::Carp doc are updated to reflect that it can work with mod_perl 2.0. - when creating a temporary file in the directory fails, the error message could indicate the root of the problem better (Peter Gervai, Niko Tyni) [INTERNALS] - Re-fixing https test in http.t. (RT#54768, thanks to SPROUT) - param_fetch no longer triggers a warning when called with no arguments (ysth, Mark Stosberg)
Diffstat (limited to 'cpan/CGI')
-rw-r--r--cpan/CGI/Changes57
-rw-r--r--cpan/CGI/lib/CGI.pm163
-rw-r--r--cpan/CGI/lib/CGI/Carp.pm41
-rw-r--r--cpan/CGI/lib/CGI/Cookie.pm230
-rw-r--r--cpan/CGI/lib/CGI/Pretty.pm2
-rw-r--r--cpan/CGI/lib/CGI/Push.pm4
-rw-r--r--cpan/CGI/lib/CGI/Util.pm25
-rw-r--r--cpan/CGI/t/carp.t31
-rw-r--r--cpan/CGI/t/charset.t27
-rw-r--r--cpan/CGI/t/cookie.t162
-rw-r--r--cpan/CGI/t/headers.t47
-rw-r--r--cpan/CGI/t/html.t11
-rw-r--r--cpan/CGI/t/param_fetch.t26
13 files changed, 573 insertions, 253 deletions
diff --git a/cpan/CGI/Changes b/cpan/CGI/Changes
index 4b197ecbde..0647ef530d 100644
--- a/cpan/CGI/Changes
+++ b/cpan/CGI/Changes
@@ -1,3 +1,59 @@
+Version 3.51
+
+ [NEW FEATURES]
+ - A new option to set $CGI::Carp::TO_BROWSER = 0, allows you to explicitly
+ exclude a particular scope from triggering printing to the browser when
+ fatatlsToBrowser is set. (RT#62783, Thanks to papowell)
+ - The <script> tag now supports the "charset" attribute.
+ (RT#62907, Thanks to Fabrice Metge)
+ - In CGI::Cookie, "Max-Age" is now supported for better spec compliance.
+ (Mark Stosberg)
+
+ [BUG FIXES]
+ - Setting charset() now works for all content types, not just "text/*".
+ (RT#57945, Thanks to Yanick and Gerv.)
+ - support for user temporary directories ($HOME/tmp) was commented out
+ in 2.61 but the documentation wasn't updated (Peter Gervai, Niko Tyni)
+ - setting $CGITempFile::TMPDIRECTORY before loading CGI.pm has been
+ working but undocumented since 3.12 (which listed it in Changes as
+ $CGI::TMPDIRECTORY) (Peter Gervai, Niko Tyni)
+ - unfortunately the previous change broke the runtime check for looking
+ for a new temporary directory if the current one suddenly became
+ unwritable (Peter Gervai, Niko Tyni)
+ - A bug was fixed in CGI::Carp triggered by certain death cases in
+ the BEGIN phase of parent classes.
+ (RT#57224, Thanks to UNERA, Yanick Champoux, Mark Stosberg)
+ - CGI::Cookie->new() now follows the documentation and returns undef
+ if the -name and -value args aren't provided. This new behavior is also
+ consistent with the docs and code of CGI::Simple::Cookie. (Mark Stosberg)
+ - CGI::Cookie->parse() now trims leading and trailing whitespace from cookie
+ elements as intended. The change also makes this part of the parsing
+ identical to CGI::Simple::Cookie (Mark Stosberg)
+ - Temp file handling was improved (RT#62762)
+
+ [SECURITY]
+ - Further improvements have been made to guard against newline injections
+ in headers. (Thanks to Max Kanat-Alexander, Yanick Champoux, Mark Stosberg)
+
+ [PERFORMANCE]
+ - Make EBCDIC a compile-time constant so there's zero overhead (and less
+ compiled code) in subroutines that test for it. (Tim Bunce)
+ - If you just want to use CGI::Cookie, CGI.pm will no longer be loaded
+ unless you call the bake() method, which requires it. (Mark Stosberg)
+
+ [DOCUMENTATION]
+ - quit referring to the <link> tag as being "rarely used". (Victor Sanders)
+ - typo and whitespace fixes (RT#62785, thanks to scop@cpan.org)
+ - The -dtd argument to start_html() is now documented
+ (RT#60473, Thanks to giecrilj and steve@fisharerojo.org)
+ - CGI::Carp doc are updated to reflect that it can work with mod_perl 2.0.
+ - when creating a temporary file in the directory fails, the error message
+ could indicate the root of the problem better (Peter Gervai, Niko Tyni)
+
+ [INTERNALS]
+ - Re-fixing https test in http.t. (RT#54768, thanks to SPROUT)
+ - param_fetch no longer triggers a warning when called with no arguments (ysth, Mark Stosberg)
+
Version 3.50
[SECURITY]
@@ -23,6 +79,7 @@ Version 3.49
Thanks to Alex Vandiver (RT#51109)
2. Suppress uninitialized warnings under -w. Thanks to burak. (RT#50301)
3. url() now uses virtual_port() instead of server_port(). Thanks to MKANAT and Yanick Champoux. (RT#51562)
+ 4. CGI::Carp now properly handles stringifiable objects, like Exception::Class throws (RT#39904)
[SECURITY]
1. embedded newlines are now filtered out of header values in header().
diff --git a/cpan/CGI/lib/CGI.pm b/cpan/CGI/lib/CGI.pm
index c0f6752dae..d320d7f3a9 100644
--- a/cpan/CGI/lib/CGI.pm
+++ b/cpan/CGI/lib/CGI.pm
@@ -1,5 +1,5 @@
package CGI;
-require 5.004;
+require 5.006;
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.51';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
@@ -1559,7 +1559,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 +1571,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 +1857,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 +1888,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 || ''));
}
@@ -2961,6 +2958,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} = [];
@@ -3636,7 +3635,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 +4270,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++));
}
@@ -5129,8 +5131,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.
@@ -5358,8 +5359,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 +5413,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 <?xml> declaration at the top of the HTML header. The sole
purpose of this declaration is to declare the character set
@@ -5421,11 +5433,11 @@ a <meta> 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 <head> section with the
-B<-head> tag. For example, to place the rarely-used <link> element in the
+B<-head> tag. For example, to place a <link> 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 <head> section, just pass an
array reference:
@@ -5487,12 +5499,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 <script> tag, has several attributes including "type" and src.
-The latter is particularly interesting, as it allows you to keep the
-JavaScript code in a file or CGI script rather than cluttering up each
-page with the source. To use these attributes pass a HASH reference
-in the B<-script> parameter containing one or more of -type, -src, or
--code:
+The <script> tag, has several attributes including "type", "charset" and "src".
+"src" allows you to keep JavaScript code in an external file. To use these
+attributes pass a HASH reference in the B<-script> parameter containing one or
+more of -type, -src, or -code:
print $q->start_html(-title=>'The Riddle of the Sphinx',
-script=>{-type=>'JAVASCRIPT',
@@ -5528,7 +5538,7 @@ of JavaScript. Example:
);
The option "-language" is a synonym for -type, and is supported for
-backwad compatibility.
+backwards compatibility.
The old-style positional parameters are as follows:
@@ -5673,14 +5683,8 @@ method, the results will not be what you expect.
=head1 CREATING STANDARD HTML ELEMENTS:
-CGI.pm defines general HTML shortcut methods for most, if not all of
-the HTML 3 and HTML 4 tags. HTML shortcuts are named after a single
-HTML element and return a fragment of HTML text that you can then
-print or manipulate as you like. Each shortcut returns a fragment of
-HTML code that you can append to a string, save to a file, or, most
-commonly, print out so that it displays in the browser window.
-
-This example shows how to use the HTML methods:
+CGI.pm defines general HTML shortcut methods for many HTML tags. HTML shortcuts are named after a single
+HTML element and return a fragment of HTML text. Example:
print $q->blockquote(
"Many years ago on the island of",
@@ -5936,7 +5940,7 @@ autoEscape() method with a false value immediately after creating the CGI object
$query->autoEscape(0);
Note that autoEscape() is exclusively used to effect the behavior of how some
-CGI.pm HTML generation fuctions handle escaping. Calling escapeHTML()
+CGI.pm HTML generation functions handle escaping. Calling escapeHTML()
explicitly will always escape the HTML.
I<A Lurking Trap!> Some of the form-element generating methods return
@@ -5986,7 +5990,7 @@ action and form encoding that you specify. The defaults are:
method: POST
action: this script
enctype: application/x-www-form-urlencoded for non-XHTML
- multipart/form-data for XHTML, see mulitpart/form-data below.
+ multipart/form-data for XHTML, see multipart/form-data below.
end_form() returns the closing </form> tag.
@@ -6229,7 +6233,7 @@ recognized. See textfield() for details.
=head3 Basics
-When the form is processed, you can retrieve an L<IO::Handle> compatibile
+When the form is processed, you can retrieve an L<IO::Handle> compatible
handle for a file upload field like this:
$lightweight_fh = $q->upload('field_name');
@@ -6317,7 +6321,7 @@ if you wish.
CGI.pm gives you low-level access to file upload management through
a file upload hook. You can use this feature to completely turn off
the temp file storage of file uploads, or potentially write your own
-file upload progess meter.
+file upload progress meter.
This is much like the UPLOAD_HOOK facility available in L<Apache::Request>, with
the exception that the first argument to the callback is an L<Apache::Upload>
@@ -6370,7 +6374,7 @@ param() is not a filehandle at all, but a string.
To solve this problem the upload() method was added, which always returns a
lightweight filehandle. This generally works well, but will have trouble
interoperating with some other modules because the file handle is not derived
-from L<IO::Handle>. So that brings us to current recommedation given above,
+from L<IO::Handle>. So that brings us to current recommendation given above,
which is to call the handle() method on the file handle returned by upload().
That upgrades the handle to an IO::Handle. It's a big win for compatibility for
a small penalty of loading IO::Handle the first time you call it.
@@ -7609,7 +7613,7 @@ Returns the remote host IP address, or
127.0.0.1 if the address is unavailable.
=item B<script_name()>
-Return the script name as a partial URL, for self-refering
+Return the script name as a partial URL, for self-referring
scripts.
=item B<referer()>
@@ -7726,7 +7730,7 @@ Prefix in Name.
=item In the B<use> statement
-Simply add the "-nph" pragmato the list of symbols to be imported into
+Simply add the "-nph" pragma to the list of symbols to be imported into
your script:
use CGI qw(:standard -nph)
@@ -7912,11 +7916,13 @@ To make it easier to port existing programs that use cgi-lib.pl the
compatibility routine "ReadParse" is provided. Porting is simple:
OLD VERSION
+
require "cgi-lib.pl";
&ReadParse;
print "The value of the antique is $in{antique}.\n";
NEW VERSION
+
use CGI;
CGI::ReadParse();
print "The value of the antique is $in{antique}.\n";
@@ -7924,19 +7930,68 @@ NEW VERSION
CGI.pm's ReadParse() routine creates a tied variable named %in,
which can be accessed to obtain the query variables. Like
ReadParse, you can also provide your own variable. Infrequently
-used features of ReadParse, such as the creation of @in and $in
+used features of ReadParse, such as the creation of @in and $in
variables, are not supported.
Once you use ReadParse, you can retrieve the query object itself
this way:
$q = $in{CGI};
- print textfield(-name=>'wow',
- -value=>'does this really work?');
+ print $q->textfield(-name=>'wow',
+ -value=>'does this really work?');
This allows you to start using the more interesting features
of CGI.pm without rewriting your old scripts from scratch.
+An even simpler way to mix cgi-lib calls with CGI.pm calls is to import both the
+C<:cgi-lib> and C<:standard> method:
+
+ use CGI qw(:cgi-lib :standard);
+ &ReadParse;
+ print "The price of your purchase is $in{price}.\n";
+ print textfield(-name=>'price', -default=>'$1.99');
+
+=head2 Cgi-lib functions that are available in CGI.pm
+
+In compatability mode, the following cgi-lib.pl functions are
+available for your use:
+
+ ReadParse()
+ PrintHeader()
+ HtmlTop()
+ HtmlBot()
+ SplitParam()
+ MethGet()
+ MethPost()
+
+=head2 Cgi-lib functions that are not available in CGI.pm
+
+ * Extended form of ReadParse()
+ The extended form of ReadParse() that provides for file upload
+ spooling, is not available.
+
+ * MyBaseURL()
+ This function is not available. Use CGI.pm's url() method instead.
+
+ * MyFullURL()
+ This function is not available. Use CGI.pm's self_url() method
+ instead.
+
+ * CgiError(), CgiDie()
+ These functions are not supported. Look at CGI::Carp for the way I
+ prefer to handle error messages.
+
+ * PrintVariables()
+ This function is not available. To achieve the same effect,
+ just print out the CGI object:
+
+ use CGI qw(:standard);
+ $q = CGI->new;
+ print h1("The Variables Are"),$q;
+
+ * PrintEnv()
+ This function is not available. You'll have to roll your own if you really need it.
+
=head1 AUTHOR INFORMATION
The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is
@@ -7947,7 +8002,7 @@ bug reports, please provide the version of CGI.pm, the version of
Perl, the name and version of your Web server, and the name and
version of the operating system you are using. If the problem is even
remotely browser dependent, please provide information about the
-affected browers as well.
+affected browsers as well.
=head1 CREDITS
diff --git a/cpan/CGI/lib/CGI/Carp.pm b/cpan/CGI/lib/CGI/Carp.pm
index 5f9911b32e..9d644d9c94 100644
--- a/cpan/CGI/lib/CGI/Carp.pm
+++ b/cpan/CGI/lib/CGI/Carp.pm
@@ -116,7 +116,7 @@ occur in the early compile phase will be seen.
Nonfatal errors will still be directed to the log file only (unless redirected
with carpout).
-Note that fatalsToBrowser does B<not> work with mod_perl version 2.0
+Note that fatalsToBrowser may B<not> work well with mod_perl version 2.0
and higher.
=head2 Changing the default message
@@ -183,6 +183,28 @@ attempting to set SIG{__DIE__} yourself, you may interfere with
this module's functionality, or this module may interfere with
your module's functionality.
+=head2 SUPPRESSING PERL ERRORS APPEARING IN THE BROWSER WINDOW
+
+A problem sometimes encountered when using fatalsToBrowser is
+when a C<die()> is done inside an C<eval> body or expression.
+Even though the
+fatalsToBrower support takes precautions to avoid this,
+you still may get the error message printed to STDOUT.
+This may have some undesireable effects when the purpose of doing the
+eval is to determine which of several algorithms is to be used.
+
+By setting C<$CGI::Carp::TO_BROWSER> to 0 you can suppress printing the C<die> messages
+but without all of the complexity of using C<set_die_handler>.
+You can localize this effect to inside C<eval> bodies if this is desireable:
+For example:
+
+ eval {
+ local $CGI::Carp::TO_BROWSER = 0;
+ die "Fatal error messages not sent browser"
+ }
+ # $@ will contain error message
+
+
=head1 MAKING WARNINGS APPEAR AS HTML COMMENTS
It is now also possible to make non-fatal errors appear as HTML
@@ -245,6 +267,8 @@ non-overridden program name
=head1 CHANGE LOG
+3.51 Added $CGI::Carp::TO_BROWSER
+
1.29 Patch from Peter Whaite to fix the unfixable problem of CGI::Carp
not behaving correctly in an eval() context.
@@ -321,9 +345,10 @@ use File::Spec;
$main::SIG{__WARN__}=\&CGI::Carp::warn;
-$CGI::Carp::VERSION = '3.45';
+$CGI::Carp::VERSION = '3.51';
$CGI::Carp::CUSTOM_MSG = undef;
$CGI::Carp::DIE_HANDLER = undef;
+$CGI::Carp::TO_BROWSER = 1;
# fancy import routine detects and handles 'errorWrap' specially.
@@ -421,23 +446,27 @@ sub ineval {
}
sub die {
- my ($arg,@rest) = @_;
+ # if no argument is passed, propagate $@ like
+ # the real die
+ my ($arg,@rest) = @_ ? @_
+ : $@ ? "$@\t...propagated"
+ : "Died"
+ ;
&$DIE_HANDLER($arg,@rest) if $DIE_HANDLER;
+ # the "$arg" is done on purpose!
# if called as die( $object, 'string' ),
# all is stringified, just like with
# the real 'die'
$arg = join '' => "$arg", @rest if @rest;
- $arg ||= 'Died';
-
my($file,$line,$id) = id(1);
$arg .= " at $file line $line.\n" unless ref $arg or $arg=~/\n$/;
realdie $arg if ineval();
- &fatalsToBrowser($arg) if $WRAP;
+ &fatalsToBrowser($arg) if ($WRAP and $CGI::Carp::TO_BROWSER);
$arg=~s/^/ stamp() /gme if $arg =~ /\n$/ or not exists $ENV{MOD_PERL};
diff --git a/cpan/CGI/lib/CGI/Cookie.pm b/cpan/CGI/lib/CGI/Cookie.pm
index 3567c7f108..df344ff348 100644
--- a/cpan/CGI/lib/CGI/Cookie.pm
+++ b/cpan/CGI/lib/CGI/Cookie.pm
@@ -12,23 +12,20 @@ use warnings;
# Copyright 1995-1999, Lincoln D. Stein. All rights reserved.
# It may be used and modified freely, but I do request that this copyright
-# notice remain attached to the file. You may modify this module as you
+# notice remain attached to the file. You may modify this module as you
# wish, but if you redistribute a modified version, please attach a note
# listing the modifications you have made.
-$CGI::Cookie::VERSION='1.29';
+our $VERSION='1.30';
use CGI::Util qw(rearrange unescape escape);
-use CGI;
-use overload '""' => \&as_string,
- 'cmp' => \&compare,
- 'fallback'=>1;
+use overload '""' => \&as_string, 'cmp' => \&compare, 'fallback' => 1;
my $PERLEX = 0;
# Turn on special checking for ActiveState's PerlEx
$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
-# Turn on special checking for Doug MacEachern's modperl
+# Turn on special checking for mod_perl
# PerlEx::DBI tries to fool DBI by setting MOD_PERL
my $MOD_PERL = 0;
if (exists $ENV{MOD_PERL} && ! $PERLEX) {
@@ -60,20 +57,14 @@ sub fetch {
my($key,$value);
my @pairs = split("[;,] ?",$raw_cookie);
- foreach (@pairs) {
- s/\s*(.*?)\s*/$1/;
- if (/^([^=]+)=(.*)/) {
- $key = $1;
- $value = $2;
- }
- else {
- $key = $_;
- $value = '';
- }
- $results{$key} = $value;
- }
- return \%results unless wantarray;
- return %results;
+ for my $pair ( @pairs ) {
+ $pair =~ s/^\s+|\s+$//g; # trim leading trailing whitespace
+ my ( $key, $value ) = split "=", $pair;
+
+ $value = defined $value ? $value : '';
+ $results{$key} = $value;
+ }
+ return wantarray ? %results : \%results;
}
sub get_raw_cookie {
@@ -93,11 +84,15 @@ sub get_raw_cookie {
sub parse {
my ($self,$raw_cookie) = @_;
+ return wantarray ? () : {} unless $raw_cookie;
+
my %results;
my @pairs = split("[;,] ?",$raw_cookie);
- foreach (@pairs) {
- s/\s*(.*?)\s*/$1/;
+ for (@pairs) {
+ s/^\s+//;
+ s/\s+$//;
+
my($key,$value) = split("=",$_,2);
# Some foreign cookies are not in name=value format, so ignore
@@ -113,49 +108,37 @@ sub parse {
# appear. The FIRST one in HTTP_COOKIE is the most recent version.
$results{$key} ||= $self->new(-name=>$key,-value=>\@values);
}
- return \%results unless wantarray;
- return %results;
+ return wantarray ? %results : \%results;
}
sub new {
- my $class = shift;
- $class = ref($class) if ref($class);
- # Ignore mod_perl request object--compatability with Apache::Cookie.
- shift if ref $_[0]
- && eval { $_[0]->isa('Apache::Request::Req') || $_[0]->isa('Apache') };
- my($name,$value,$path,$domain,$secure,$expires,$httponly) =
- rearrange([ 'NAME', ['VALUE','VALUES'], qw/ PATH DOMAIN SECURE EXPIRES
- HTTPONLY / ], @_);
-
- # Pull out our parameters.
- my @values;
- if (ref($value)) {
- if (ref($value) eq 'ARRAY') {
- @values = @$value;
- } elsif (ref($value) eq 'HASH') {
- @values = %$value;
- }
- } else {
- @values = ($value);
- }
-
- bless my $self = {
- 'name'=>$name,
- 'value'=>[@values],
- },$class;
-
- # IE requires the path and domain to be present for some reason.
- $path ||= "/";
- # however, this breaks networks which use host tables without fully qualified
- # names, so we comment it out.
- # $domain = CGI::virtual_host() unless defined $domain;
-
- $self->path($path) if defined $path;
- $self->domain($domain) if defined $domain;
- $self->secure($secure) if defined $secure;
- $self->expires($expires) if defined $expires;
- $self->httponly($httponly) if defined $httponly;
-# $self->max_age($expires) if defined $expires;
+ my ( $class, @params ) = @_;
+ $class = ref( $class ) || $class;
+ # Ignore mod_perl request object--compatibility with Apache::Cookie.
+ shift if ref $params[0]
+ && eval { $params[0]->isa('Apache::Request::Req') || $params[0]->isa('Apache') };
+ my ( $name, $value, $path, $domain, $secure, $expires, $max_age, $httponly )
+ = rearrange(
+ [
+ 'NAME', [ 'VALUE', 'VALUES' ],
+ 'PATH', 'DOMAIN',
+ 'SECURE', 'EXPIRES',
+ 'MAX-AGE','HTTPONLY'
+ ],
+ @params
+ );
+ return undef unless defined $name and defined $value;
+ my $self = {};
+ bless $self, $class;
+ $self->name( $name );
+ $self->value( $value );
+ $path ||= "/";
+ $self->path( $path ) if defined $path;
+ $self->domain( $domain ) if defined $domain;
+ $self->secure( $secure ) if defined $secure;
+ $self->expires( $expires ) if defined $expires;
+ $self->max_age($expires) if defined $max_age;
+ $self->httponly( $httponly ) if defined $httponly;
return $self;
}
@@ -163,23 +146,24 @@ sub as_string {
my $self = shift;
return "" unless $self->name;
- my(@constant_values,$domain,$path,$expires,$max_age,$secure,$httponly);
+ no warnings; # some things may be undefined, that's OK.
+
+ my $name = escape( $self->name );
+ my $value = join "&", map { escape($_) } $self->value;
+ my @cookie = ( "$name=$value" );
- push(@constant_values,"domain=$domain") if $domain = $self->domain;
- push(@constant_values,"path=$path") if $path = $self->path;
- push(@constant_values,"expires=$expires") if $expires = $self->expires;
- push(@constant_values,"max-age=$max_age") if $max_age = $self->max_age;
- push(@constant_values,"secure") if $secure = $self->secure;
- push(@constant_values,"HttpOnly") if $httponly = $self->httponly;
+ push @cookie,"domain=".$self->domain if $self->domain;
+ push @cookie,"path=".$self->path if $self->path;
+ push @cookie,"expires=".$self->expires if $self->expires;
+ push @cookie,"max-age=".$self->max_age if $self->max_age;
+ push @cookie,"secure" if $self->secure;
+ push @cookie,"HttpOnly" if $self->httponly;
- my($key) = escape($self->name);
- my($cookie) = join("=",(defined $key ? $key : ''),join("&",map escape(defined $_ ? $_ : ''),$self->value));
- return join("; ",$cookie,@constant_values);
+ return join "; ", @cookie;
}
sub compare {
- my $self = shift;
- my $value = shift;
+ my ( $self, $value ) = @_;
return "$self" cmp $value;
}
@@ -194,6 +178,7 @@ sub bake {
if ($r) {
$r->headers_out->add('Set-Cookie' => $self->as_string);
} else {
+ require CGI;
print CGI::header(-cookie => $self);
}
@@ -201,70 +186,56 @@ sub bake {
# accessors
sub name {
- my $self = shift;
- my $name = shift;
+ my ( $self, $name ) = @_;
$self->{'name'} = $name if defined $name;
return $self->{'name'};
}
sub value {
- my $self = shift;
- my $value = shift;
- if (defined $value) {
- my @values;
- if (ref($value)) {
- if (ref($value) eq 'ARRAY') {
- @values = @$value;
- } elsif (ref($value) eq 'HASH') {
- @values = %$value;
- }
- } else {
- @values = ($value);
- }
- $self->{'value'} = [@values];
- }
- return wantarray ? @{$self->{'value'}} : $self->{'value'}->[0]
+ my ( $self, $value ) = @_;
+ if ( defined $value ) {
+ my @values
+ = ref $value eq 'ARRAY' ? @$value
+ : ref $value eq 'HASH' ? %$value
+ : ( $value );
+ $self->{'value'} = [@values];
+ }
+ return wantarray ? @{ $self->{'value'} } : $self->{'value'}->[0];
}
sub domain {
- my $self = shift;
- my $domain = shift;
+ my ( $self, $domain ) = @_;
$self->{'domain'} = lc $domain if defined $domain;
return $self->{'domain'};
}
sub secure {
- my $self = shift;
- my $secure = shift;
+ my ( $self, $secure ) = @_;
$self->{'secure'} = $secure if defined $secure;
return $self->{'secure'};
}
sub expires {
- my $self = shift;
- my $expires = shift;
+ my ( $self, $expires ) = @_;
$self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires;
return $self->{'expires'};
}
sub max_age {
- my $self = shift;
- my $expires = shift;
- $self->{'max-age'} = CGI::Util::expire_calc($expires)-time() if defined $expires;
- return $self->{'max-age'};
+ my ( $self, $max_age ) = @_;
+ $self->{'max-age'} = CGI::Util::expire_calc($max_age)-time() if defined $max_age;
+ return $self->{'max-age'};
}
sub path {
- my $self = shift;
- my $path = shift;
+ my ( $self, $path ) = @_;
$self->{'path'} = $path if defined $path;
return $self->{'path'};
}
sub httponly { # HttpOnly
- my $self = shift;
- my $httponly = shift;
+ my ( $self, $httponly ) = @_;
$self->{'httponly'} = $httponly if defined $httponly;
return $self->{'httponly'};
}
@@ -273,7 +244,7 @@ sub httponly { # HttpOnly
=head1 NAME
-CGI::Cookie - Interface to Netscape Cookies
+CGI::Cookie - Interface to HTTP Cookies
=head1 SYNOPSIS
@@ -281,23 +252,23 @@ CGI::Cookie - Interface to Netscape Cookies
use CGI::Cookie;
# Create new cookies and send them
- $cookie1 = new CGI::Cookie(-name=>'ID',-value=>123456);
- $cookie2 = new CGI::Cookie(-name=>'preferences',
+ $cookie1 = CGI::Cookie->new(-name=>'ID',-value=>123456);
+ $cookie2 = CGI::Cookie->new(-name=>'preferences',
-value=>{ font => Helvetica,
size => 12 }
);
print header(-cookie=>[$cookie1,$cookie2]);
# fetch existing cookies
- %cookies = fetch CGI::Cookie;
+ %cookies = CGI::Cookie->fetch;
$id = $cookies{'ID'}->value;
# create cookies returned from an external source
- %cookies = parse CGI::Cookie($ENV{COOKIE});
+ %cookies = CGI::Cookie->parse($ENV{COOKIE});
=head1 DESCRIPTION
-CGI::Cookie is an interface to Netscape (HTTP/1.1) cookies, an
+CGI::Cookie is an interface to HTTP/1.1 cookies, an
innovation that allows Web servers to store persistent information on
the browser's side of the connection. Although CGI::Cookie is
intended to be used in conjunction with CGI.pm (and is in fact used by
@@ -334,7 +305,7 @@ the user quits the browser.
This is a partial or complete domain name for which the cookie is
valid. The browser will return the cookie to any host that matches
the partial domain name. For example, if you specify a domain name
-of ".capricorn.com", then Netscape will return the cookie to
+of ".capricorn.com", then the browser will return the cookie to
Web servers running on any of the machines "www.capricorn.com",
"ftp.capricorn.com", "feckless.capricorn.com", etc. Domain names
must contain at least two periods to prevent attempts to match
@@ -375,7 +346,7 @@ See these URLs for more information:
=head2 Creating New Cookies
- my $c = new CGI::Cookie(-name => 'foo',
+ my $c = CGI::Cookie->new(-name => 'foo',
-value => 'bar',
-expires => '+3M',
-domain => '.capricorn.com',
@@ -393,6 +364,14 @@ B<-expires> accepts any of the relative or absolute date formats
recognized by CGI.pm, for example "+3M" for three months in the
future. See CGI.pm's documentation for details.
+B<-max-age> accepts the same data formats as B<< -expires >>, but sets a
+relative value instead of an absolute like B<< -expires >>. This is intended to be
+more secure since a clock could be changed to fake an absolute time. In
+practice, as of 2011, C<< -max-age >> still does not enjoy the widespread support
+that C<< -expires >> has. You can set both, and browsers that support
+C<< -max-age >> should ignore the C<< Expires >> header. The drawback
+to this approach is the bit of bandwidth for sending an extra header on each cookie.
+
B<-domain> points to a domain name or to a fully qualified host name.
If not specified, the cookie will be returned only to the Web server
that created it.
@@ -412,7 +391,7 @@ For compatibility with Apache::Cookie, you may optionally pass in
a mod_perl request object as the first argument to C<new()>. It will
simply be ignored:
- my $c = new CGI::Cookie($r,
+ my $c = CGI::Cookie->new($r,
-name => 'foo',
-value => ['bar','baz']);
@@ -423,6 +402,10 @@ method:
$c->bake;
+This will print the Set-Cookie HTTP header to STDOUT using CGI.pm. CGI.pm
+will be loaded for this purpose if it is not already. Otherwise CGI.pm is not
+required or used by this module.
+
Under mod_perl, pass in an Apache request object:
$c->bake($r);
@@ -431,7 +414,7 @@ If you want to set the cookie yourself, Within a CGI script you can send
a cookie to the browser by creating one or more Set-Cookie: fields in the
HTTP header. Here is a typical sequence:
- my $c = new CGI::Cookie(-name => 'foo',
+ my $c = CGI::Cookie->new(-name => 'foo',
-value => ['bar','baz'],
-expires => '+3M');
@@ -459,14 +442,14 @@ representation. You may call as_string() yourself if you prefer:
=head2 Recovering Previous Cookies
- %cookies = fetch CGI::Cookie;
+ %cookies = CGI::Cookie->fetch;
B<fetch> returns an associative array consisting of all cookies
returned by the browser. The keys of the array are the cookie names. You
can iterate through the cookies this way:
- %cookies = fetch CGI::Cookie;
- foreach (keys %cookies) {
+ %cookies = CGI::Cookie->fetch;
+ for (keys %cookies) {
do_something($cookies{$_});
}
@@ -482,13 +465,16 @@ You may also retrieve cookies that were stored in some external
form using the parse() class method:
$COOKIES = `cat /usr/tmp/Cookie_stash`;
- %cookies = parse CGI::Cookie($COOKIES);
+ %cookies = CGI::Cookie->parse($COOKIES);
If you are in a mod_perl environment, you can save some overhead by
passing the request object to fetch() like this:
CGI::Cookie->fetch($r);
+If the value passed to parse() is undefined, an empty array will returned in list
+contact, and an empty hashref will be returned in scalar context.
+
=head2 Manipulating Cookies
Cookie objects have a series of accessor methods to get and set cookie
@@ -549,4 +535,6 @@ This section intentionally left blank.
L<CGI::Carp>, L<CGI>
+L<RFC 2109|http://www.ietf.org/rfc/rfc2109.txt>, L<RFC 2695|http://www.ietf.org/rfc/rfc2965.txt>
+
=cut
diff --git a/cpan/CGI/lib/CGI/Pretty.pm b/cpan/CGI/lib/CGI/Pretty.pm
index 356747824d..869fe0cdf2 100644
--- a/cpan/CGI/lib/CGI/Pretty.pm
+++ b/cpan/CGI/lib/CGI/Pretty.pm
@@ -252,7 +252,7 @@ now produces the following output:
=head2 Recommendation for when to use CGI::Pretty
CGI::Pretty is far slower than using CGI.pm directly. A benchmark showed that
-it could be about 10 times slower. Adding newslines and spaces may alter the
+it could be about 10 times slower. Adding newlines and spaces may alter the
rendered appearance of HTML. Also, the extra newlines and spaces also make the
file size larger, making the files take longer to download.
diff --git a/cpan/CGI/lib/CGI/Push.pm b/cpan/CGI/lib/CGI/Push.pm
index 9e72abda55..2af7d794da 100644
--- a/cpan/CGI/lib/CGI/Push.pm
+++ b/cpan/CGI/lib/CGI/Push.pm
@@ -16,7 +16,7 @@ package CGI::Push;
# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
-$CGI::Push::VERSION='1.04';
+$CGI::Push::VERSION='1.05';
use CGI;
use CGI::Util 'rearrange';
@ISA = ('CGI');
@@ -214,7 +214,7 @@ itself should have exactly the same calling conventions as the
This optional parameter indicates the content type of each page. It
defaults to "text/html". Normally the module assumes that each page
-is of a homogenous MIME type. However if you provide either of the
+is of a homogeneous MIME type. However if you provide either of the
magic values "heterogeneous" or "dynamic" (the latter provided for the
convenience of those who hate long parameter names), you can specify
the MIME type -- and other header fields -- on a per-page basis. See
diff --git a/cpan/CGI/lib/CGI/Util.pm b/cpan/CGI/lib/CGI/Util.pm
index eb639e40d5..ef95c9f018 100644
--- a/cpan/CGI/lib/CGI/Util.pm
+++ b/cpan/CGI/lib/CGI/Util.pm
@@ -1,15 +1,16 @@
package CGI::Util;
use strict;
-use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
+use vars qw($VERSION @EXPORT_OK @ISA @A2E @E2A);
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(rearrange rearrange_header make_attributes unescape escape
expires ebcdic2ascii ascii2ebcdic);
-$VERSION = '3.48';
+$VERSION = '3.51';
+
+use constant EBCDIC => "\t" ne "\011";
-$EBCDIC = "\t" ne "\011";
# (ord('^') == 95) for codepage 1047 as on os390, vmesa
@A2E = (
0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15,
@@ -48,7 +49,7 @@ $EBCDIC = "\t" ne "\011";
48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159
);
-if ($EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set
+if (EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set
$A2E[91] = 187; $A2E[92] = 188; $A2E[94] = 106; $A2E[96] = 74;
$A2E[123] = 251; $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95;
$A2E[162] = 176; $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186;
@@ -61,7 +62,7 @@ if ($EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character se
$E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125;
$E2A[255] = 126;
}
-elsif ($EBCDIC && ord('^') == 176) { # as in codepage 037 on os400
+elsif (EBCDIC && ord('^') == 176) { # as in codepage 037 on os400
$A2E[10] = 37; $A2E[91] = 186; $A2E[93] = 187; $A2E[94] = 176;
$A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173;
@@ -210,10 +211,10 @@ sub unescape {
my $todecode = shift;
return undef unless defined($todecode);
$todecode =~ tr/+/ /; # pluses become spaces
- if ($EBCDIC) {
+ if (EBCDIC) {
$todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
} else {
- # handle surrogate pairs first -- dankogai
+ # handle surrogate pairs first -- dankogai. Ref: http://unicode.org/faq/utf_bom.html#utf16-2
$todecode =~ s{
%u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi
%u([Dd][c-fC-F][0-9a-fA-F]{2}) # lo
@@ -272,11 +273,12 @@ EOR
}
sub escape {
+ # If we being called in an OO-context, discard the first argument.
shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
my $toencode = shift;
return undef unless defined($toencode);
utf8::encode($toencode) if ($] >= 5.008 && utf8::is_utf8($toencode));
- if ($EBCDIC) {
+ if (EBCDIC) {
$toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
} else {
$toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
@@ -340,7 +342,8 @@ sub expire_calc {
} else {
return $time;
}
- return (time+$offset);
+ my $cur_time = time;
+ return ($cur_time+$offset);
}
sub ebcdic2ascii {
@@ -373,7 +376,7 @@ no public subroutines
=head1 AUTHOR INFORMATION
-Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
+Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
@@ -383,7 +386,7 @@ bug reports, please provide the version of CGI.pm, the version of
Perl, the name and version of your Web server, and the name and
version of the operating system you are using. If the problem is even
remotely browser dependent, please provide information about the
-affected browers as well.
+affected browsers as well.
=head1 SEE ALSO
diff --git a/cpan/CGI/t/carp.t b/cpan/CGI/t/carp.t
index be6292867b..59508bc9d5 100644
--- a/cpan/CGI/t/carp.t
+++ b/cpan/CGI/t/carp.t
@@ -1,12 +1,12 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 2 -*-
-#!/usr/local/bin/perl -w
+#!perl -w
use strict;
-use Test::More tests => 59;
+use Test::More tests => 61;
use IO::Handle;
-BEGIN { use_ok('CGI::Carp') };
+use CGI::Carp;
#-----------------------------------------------------------------------------
# Test id
@@ -337,9 +337,14 @@ ok(!defined buffer("WIBBLE"), '"WIBBLE" doesn\'t returns proper filehandle'
CGI::Carp::die( My::Stringified::Object->new );
$result{string_object} .= $_ while <STDOUT>;
+ undef $@;
CGI::Carp::die();
$result{no_args} .= $_ while <STDOUT>;
+ $@ = "I think I caught a virus";
+ CGI::Carp::die();
+ $result{propagated} .= $_ while <STDOUT>;
+
untie *STDOUT;
like $result{string} => qr/regular string/, 'regular string, wrapped';
@@ -352,6 +357,9 @@ ok(!defined buffer("WIBBLE"), '"WIBBLE" doesn\'t returns proper filehandle'
'stringified object, wrapped';
like $result{no_args} => qr/Died at/, 'no args, wrapped';
+ like $result{propagated} => qr/I think I caught a virus\t\.{3}propagated/,
+ 'propagating $@ if no argument';
+
}
{
@@ -371,3 +379,20 @@ ok(!defined buffer("WIBBLE"), '"WIBBLE" doesn\'t returns proper filehandle'
return bless {}, shift;
}
}
+
+
+@result = ();
+tie *STDOUT, 'StoreStuff' or die "Can't tie STDOUT";
+ {
+ eval {
+ $CGI::Carp::TO_BROWSER = 0;
+ die 'Message ToBrowser = 0';
+ };
+ $result[0] = $@;
+ $result[1] .= $_ while (<STDOUT>);
+ }
+untie *STDOUT;
+
+ like $result[0] => qr/Message ToBrowser/, 'die message for ToBrowser = 0 is OK';
+ ok !$result[1], 'No output for ToBrowser = 0';
+
diff --git a/cpan/CGI/t/charset.t b/cpan/CGI/t/charset.t
new file mode 100644
index 0000000000..745979798b
--- /dev/null
+++ b/cpan/CGI/t/charset.t
@@ -0,0 +1,27 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use CGI;
+
+my $q = CGI->new;
+
+like( $q->header
+ , qr/charset=ISO-8859-1/, "charset ISO-8859-1 is set by default for default content-type");
+like( $q->header('application/json')
+ , qr/charset=ISO-8859-1/, "charset ISO-8859-1 is set by default for application/json content-type");
+
+{
+ $q->charset('UTF-8');
+ my $out = $q->header('text/plain');
+ like($out, qr{Content-Type: text/plain; charset=UTF-8}, "setting charset alters header of text/plain");
+}
+{
+ $q->charset('UTF-8');
+ my $out = $q->header('application/json');
+ like($out, qr{Content-Type: application/json; charset=UTF-8}, "setting charset alters header of application/json");
+}
+
diff --git a/cpan/CGI/t/cookie.t b/cpan/CGI/t/cookie.t
index f5afc18596..8249f0798e 100644
--- a/cpan/CGI/t/cookie.t
+++ b/cpan/CGI/t/cookie.t
@@ -1,23 +1,29 @@
-#!/usr/local/bin/perl -w
+#!perl -w
use strict;
-use Test::More tests => 96;
+# to have a consistent baseline, we nail the current time
+# to 100 seconds after the epoch
+BEGIN {
+ *CORE::GLOBAL::time = sub { 100 };
+}
+
+use Test::More 'no_plan';
use CGI::Util qw(escape unescape);
use POSIX qw(strftime);
+use CGI::Cookie;
#-----------------------------------------------------------------------------
# make sure module loaded
#-----------------------------------------------------------------------------
-BEGIN {use_ok('CGI::Cookie');}
-
my @test_cookie = (
- 'foo=123; bar=qwerty; baz=wibble; qux=a1',
- 'foo=123; bar=qwerty; baz=wibble;',
- 'foo=vixen; bar=cow; baz=bitch; qux=politician',
- 'foo=a%20phrase; bar=yes%2C%20a%20phrase; baz=%5Ewibble; qux=%27',
- );
+ # including leading and trailing whitespace in first cookie
+ ' foo=123 ; bar=qwerty; baz=wibble; qux=a1',
+ 'foo=123; bar=qwerty; baz=wibble;',
+ 'foo=vixen; bar=cow; baz=bitch; qux=politician',
+ 'foo=a%20phrase; bar=yes%2C%20a%20phrase; baz=%5Ewibble; qux=%27',
+ );
#-----------------------------------------------------------------------------
# Test parse
@@ -25,23 +31,29 @@ my @test_cookie = (
{
my $result = CGI::Cookie->parse($test_cookie[0]);
-
is(ref($result), 'HASH', "Hash ref returned in scalar context");
my @result = CGI::Cookie->parse($test_cookie[0]);
-
is(@result, 8, "returns correct number of fields");
@result = CGI::Cookie->parse($test_cookie[1]);
-
is(@result, 6, "returns correct number of fields");
my %result = CGI::Cookie->parse($test_cookie[0]);
-
is($result{foo}->value, '123', "cookie foo is correct");
is($result{bar}->value, 'qwerty', "cookie bar is correct");
is($result{baz}->value, 'wibble', "cookie baz is correct");
is($result{qux}->value, 'a1', "cookie qux is correct");
+
+ my @array = CGI::Cookie->parse('');
+ my $scalar = CGI::Cookie->parse('');
+ is_deeply(\@array, [], " parse('') returns an empty array in list context (undocumented)");
+ is_deeply($scalar, {}, " parse('') returns an empty hashref in scalar context (undocumented)");
+
+ my @array = CGI::Cookie->parse(undef);
+ my $scalar = CGI::Cookie->parse(undef);
+ is_deeply(\@array, [], " parse(undef) returns an empty array in list context (undocumented)");
+ is_deeply($scalar, {}, " parse(undef) returns an empty hashref in scalar context (undocumented)");
}
#-----------------------------------------------------------------------------
@@ -126,6 +138,10 @@ my @test_cookie = (
is($result{bar}, 'yes%2C%20a%20phrase', "cookie bar is correct");
is($result{baz}, '%5Ewibble', "cookie baz is correct");
is($result{qux}, '%27', "cookie qux is correct");
+
+ $ENV{COOKIE} = '$Version=1; foo; $Path="/test"';
+ %result = CGI::Cookie->raw_fetch();
+ is($result{foo}, '', 'no value translates to empty string');
}
#-----------------------------------------------------------------------------
@@ -135,12 +151,13 @@ my @test_cookie = (
{
# Try new with full information provided
my $c = CGI::Cookie->new(-name => 'foo',
- -value => 'bar',
- -expires => '+3M',
- -domain => '.capricorn.com',
- -path => '/cgi-bin/database',
- -secure => 1
- );
+ -value => 'bar',
+ -expires => '+3M',
+ -domain => '.capricorn.com',
+ -path => '/cgi-bin/database',
+ -secure => 1,
+ -httponly=> 1
+ );
is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
is($c->name , 'foo', 'name is correct');
is($c->value , 'bar', 'value is correct');
@@ -148,11 +165,12 @@ my @test_cookie = (
is($c->domain , '.capricorn.com', 'domain is correct');
is($c->path , '/cgi-bin/database', 'path is correct');
ok($c->secure , 'secure attribute is set');
+ ok( $c->httponly, 'httponly attribute is set' );
# now try it with the only two manditory values (should also set the default path)
$c = CGI::Cookie->new(-name => 'baz',
- -value => 'qux',
- );
+ -value => 'qux',
+ );
is(ref($c), 'CGI::Cookie', 'new returns objects of correct type');
is($c->name , 'baz', 'name is correct');
is($c->value , 'qux', 'value is correct');
@@ -160,6 +178,7 @@ my @test_cookie = (
ok(!defined $c->domain , 'domain attributeis not set');
is($c->path, '/', 'path atribute is set to default');
ok(!defined $c->secure , 'secure attribute is set');
+ ok( !defined $c->httponly, 'httponly attribute is not set' );
# I'm really not happy about the restults of this section. You pass
# the new method invalid arguments and it just merilly creates a
@@ -186,12 +205,13 @@ my @test_cookie = (
{
my $c = CGI::Cookie->new(-name => 'Jam',
- -value => 'Hamster',
- -expires => '+3M',
- -domain => '.pie-shop.com',
- -path => '/',
- -secure => 1
- );
+ -value => 'Hamster',
+ -expires => '+3M',
+ -domain => '.pie-shop.com',
+ -path => '/',
+ -secure => 1,
+ -httponly=> 1
+ );
my $name = $c->name;
like($c->as_string, "/$name/", "Stringified cookie contains name");
@@ -210,9 +230,12 @@ my @test_cookie = (
like($c->as_string, '/secure/', "Stringified cookie contains secure");
+ like( $c->as_string, '/HttpOnly/',
+ "Stringified cookie contains HttpOnly" );
+
$c = CGI::Cookie->new(-name => 'Hamster-Jam',
- -value => 'Tulip',
- );
+ -value => 'Tulip',
+ );
$name = $c->name;
like($c->as_string, "/$name/", "Stringified cookie contains name");
@@ -228,6 +251,9 @@ my @test_cookie = (
like($c->as_string, "/$path/", "Stringified cookie contains path");
ok($c->as_string !~ /secure/, "Stringified cookie does not contain secure");
+
+ ok( $c->as_string !~ /HttpOnly/,
+ "Stringified cookie does not contain HttpOnly" );
}
#-----------------------------------------------------------------------------
@@ -236,38 +262,38 @@ my @test_cookie = (
{
my $c1 = CGI::Cookie->new(-name => 'Jam',
- -value => 'Hamster',
- -expires => '+3M',
- -domain => '.pie-shop.com',
- -path => '/',
- -secure => 1
- );
+ -value => 'Hamster',
+ -expires => '+3M',
+ -domain => '.pie-shop.com',
+ -path => '/',
+ -secure => 1
+ );
# have to use $c1->expires because the time will occasionally be
# different between the two creates causing spurious failures.
my $c2 = CGI::Cookie->new(-name => 'Jam',
- -value => 'Hamster',
- -expires => $c1->expires,
- -domain => '.pie-shop.com',
- -path => '/',
- -secure => 1
- );
+ -value => 'Hamster',
+ -expires => $c1->expires,
+ -domain => '.pie-shop.com',
+ -path => '/',
+ -secure => 1
+ );
# This looks titally whacked, but it does the -1, 0, 1 comparison
# thing so 0 means they match
is($c1->compare("$c1"), 0, "Cookies are identical");
- is($c1->compare("$c2"), 0, "Cookies are identical");
+ is( "$c1", "$c2", "Cookies are identical");
$c1 = CGI::Cookie->new(-name => 'Jam',
- -value => 'Hamster',
- -domain => '.foo.bar.com'
- );
+ -value => 'Hamster',
+ -domain => '.foo.bar.com'
+ );
# have to use $c1->expires because the time will occasionally be
# different between the two creates causing spurious failures.
$c2 = CGI::Cookie->new(-name => 'Jam',
- -value => 'Hamster',
- );
+ -value => 'Hamster',
+ );
# This looks titally whacked, but it does the -1, 0, 1 comparison
# thing so 0 (i.e. false) means they match
@@ -284,12 +310,12 @@ my @test_cookie = (
{
my $c = CGI::Cookie->new(-name => 'Jam',
- -value => 'Hamster',
- -expires => '+3M',
- -domain => '.pie-shop.com',
- -path => '/',
- -secure => 1
- );
+ -value => 'Hamster',
+ -expires => '+3M',
+ -domain => '.pie-shop.com',
+ -path => '/',
+ -secure => 1
+ );
is($c->name, 'Jam', 'name is correct');
is($c->name('Clash'), 'Clash', 'name is set correctly');
@@ -321,6 +347,36 @@ my @test_cookie = (
ok(!$c->secure, 'secure attribute is cleared');
}
+#----------------------------------------------------------------------------
+# Max-age
+#----------------------------------------------------------------------------
+
+MAX_AGE: {
+ my $cookie = CGI::Cookie->new( -name=>'a', value=>'b', '-expires' => 'now',);
+ is $cookie->expires, 'Thu, 01-Jan-1970 00:01:40 GMT';
+ is $cookie->max_age => undef, 'max-age is undefined when setting expires';
+
+ my $cookie = CGI::Cookie->new( -name=>'a', 'value'=>'b' );
+ $cookie->max_age( '+4d' );
+
+ is $cookie->expires, undef, 'expires is undef when setting max_age';
+ is $cookie->max_age => 4*24*60*60, 'setting via max-age';
+
+ $cookie->max_age( '113' );
+ is $cookie->max_age => 13, 'max_age(num) as delta';
+}
+
+
+#----------------------------------------------------------------------------
+# bake
+#----------------------------------------------------------------------------
+
+BAKE: {
+ my $cookie = CGI::Cookie->new( -name=>'a', value=>'b', '-expires' => 'now',);
+ eval { $cookie->bake };
+ is($@,'', "calling bake() without mod_perl should survive");
+}
+
#-----------------------------------------------------------------------------
# Apache2?::Cookie compatibility.
#-----------------------------------------------------------------------------
diff --git a/cpan/CGI/t/headers.t b/cpan/CGI/t/headers.t
new file mode 100644
index 0000000000..661b74bb79
--- /dev/null
+++ b/cpan/CGI/t/headers.t
@@ -0,0 +1,47 @@
+
+# Test that header generation is spec compliant.
+# References:
+# http://www.w3.org/Protocols/rfc2616/rfc2616.html
+# http://www.w3.org/Protocols/rfc822/3_Lexical.html
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use CGI;
+
+my $cgi = CGI->new;
+
+like $cgi->header( -type => "text/html" ),
+ qr#Type: text/html#, 'known header, basic case: type => "text/html"';
+
+eval { $cgi->header( -type => "text/html".$CGI::CRLF."evil: stuff" ) };
+like($@,qr/contains a newline/,'invalid header blows up');
+
+like $cgi->header( -type => "text/html".$CGI::CRLF." evil: stuff " ),
+ qr#Content-Type: text/html evil: stuff#, 'known header, with leading and trailing whitespace on the continuation line';
+
+eval { $cgi->header( -foobar => "text/html".$CGI::CRLF."evil: stuff" ) };
+like($@,qr/contains a newline/,'unknown header with CRLF embedded blows up');
+
+eval { $cgi->header( -foobar => $CGI::CRLF."Content-type: evil/header" ) };
+like($@,qr/contains a newline/, 'unknown header with leading newlines blows up');
+
+eval { $cgi->redirect( -type => "text/html".$CGI::CRLF."evil: stuff" ) };
+like($@,qr/contains a newline/,'redirect with known header with CRLF embedded blows up');
+
+eval { $cgi->redirect( -foobar => "text/html".$CGI::CRLF."evil: stuff" ) };
+like($@,qr/contains a newline/,'redirect with unknown header with CRLF embedded blows up');
+
+eval { $cgi->redirect( $CGI::CRLF.$CGI::CRLF."Content-Type: text/html") };
+like($@,qr/contains a newline/,'redirect with leading newlines blows up');
+
+{
+ my $cgi = CGI->new('t=bogus%0A%0A<html>');
+ my $out;
+ eval { $out = $cgi->redirect( $cgi->param('t') ) };
+ like($@,qr/contains a newline/, "redirect does not allow double-newline injection");
+}
+
+
diff --git a/cpan/CGI/t/html.t b/cpan/CGI/t/html.t
index aebe22816a..09a3e33a49 100644
--- a/cpan/CGI/t/html.t
+++ b/cpan/CGI/t/html.t
@@ -63,11 +63,14 @@ is h1( { -align => 'CENTER' }, [ 'fred', 'agnes' ] ),
is header(), "Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}",
"header()";
-is header( -type => 'image/gif' ), "Content-Type: image/gif${CRLF}${CRLF}",
+is header( -type => 'image/gif', -charset => '' ), "Content-Type: image/gif${CRLF}${CRLF}",
"header()";
is header( -type => 'image/gif', -status => '500 Sucks' ),
"Status: 500 Sucks${CRLF}Content-Type: image/gif${CRLF}${CRLF}", "header()";
+
+# return to normal
+charset( 'ISO-8859-1' );
like header( -nph => 1 ),
qr!HTTP/1.0 200 OK${CRLF}Server: cmdline${CRLF}Date:.+${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!,
@@ -85,13 +88,17 @@ is start_html(), <<END, "start_html()";
<body>
END
-is start_html( -Title => 'The world of foo' ), <<END, "start_html()";
+is start_html(
+ -Title => 'The world of foo' ,
+ -Script => [ {-src=> 'foo.js', -charset=>'utf-8'} ],
+ ), <<END, "start_html()";
<!DOCTYPE html
PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US">
<head>
<title>The world of foo</title>
+<script src="foo.js" charset="utf-8" type="text/javascript"></script>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" />
</head>
<body>
diff --git a/cpan/CGI/t/param_fetch.t b/cpan/CGI/t/param_fetch.t
new file mode 100644
index 0000000000..a3756cdc83
--- /dev/null
+++ b/cpan/CGI/t/param_fetch.t
@@ -0,0 +1,26 @@
+#!perl
+
+# Tests for the param_fetch() method.
+
+use Test::More 'no_plan';
+use CGI;
+
+{
+ my $q = CGI->new('b=baz;a=foo;a=bar');
+
+ is $q->param_fetch('a')->[0] => 'foo', 'first "a" is "foo"';
+ is $q->param_fetch( -name => 'a' )->[0] => 'foo',
+ 'first "a" is "foo", with -name';
+ is $q->param_fetch('a')->[1] => 'bar', 'second "a" is "bar"';
+ is_deeply $q->param_fetch('a') => [qw/ foo bar /], 'a is array ref';
+ is_deeply $q->param_fetch( -name => 'a' ) => [qw/ foo bar /],
+ 'a is array ref, w/ name';
+
+ is $q->param_fetch('b')->[0] => 'baz', '"b" is "baz"';
+ is_deeply $q->param_fetch('b') => [qw/ baz /], 'b is array ref too';
+
+ is_deeply $q->param_fetch, [], "param_fetch without parameters";
+
+ is_deeply $q->param_fetch( 'a', 'b' ), [qw/ foo bar /],
+ "param_fetch only take first argument";
+}