cpan/CGI/t/uploadInfo.t See if CGI.pm works
cpan/CGI/t/upload_post_text.txt Test data for CGI.pm
cpan/CGI/t/upload.t See if CGI.pm works
+cpan/CGI/t/url.t See if CGI.pm works
cpan/CGI/t/user_agent.t See if CGI->user_agent() works
cpan/CGI/t/utf8.t See if CGI.pm works
cpan/CGI/t/util-58.t See if 5.8-dependent features work
'CGI' =>
{
'MAINTAINER' => 'lstein',
- 'DISTRIBUTION' => 'LDS/CGI.pm-3.48.tar.gz',
+ 'DISTRIBUTION' => 'LDS/CGI.pm-3.49.tar.gz',
'FILES' => q[cpan/CGI],
'EXCLUDED' => [ qr{^t/lib/Test},
qw( cgi-lib_porting.html
+Version 3.49
+
+ [BUG FIXES]
+ 1. Fix a regression since 3.44 involving a case when the header includes "Content-Length: 0".
+ 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)
+
+ [SECURITY]
+ 1. embedded newlines are now filtered out of header values in header().
+ Thanks to Mark Stosberg and Yanick Champoux.
+
+ [DOCUMENTATION]
+ 1. README was updated to reflect that CGI.pm was moved under ./lib.
+ Thanks to Alex Vandiver.
+
+ [INTERNALS]
+ 1. More tests were added for autoescape, thanks to Bob Kuo. (RT#25485)
+ 2. Attempt to avoid test failures with t/fast, thanks to Steve Hay. (RT#49599)
+
Version 3.48
[BUG FIXES]
# http://stein.cshl.org/WWW/software/CGI/
$CGI::revision = '$Id: CGI.pm,v 1.266 2009/07/30 16:32:34 lstein Exp $';
-$CGI::VERSION='3.48';
+$CGI::VERSION='3.49';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
if ( $content_length > 0 ) {
$self->read_from_client(\$query_string,$content_length,0);
}
- else {
+ elsif (not defined $ENV{CONTENT_LENGTH}) {
$self->read_from_stdin(\$query_string);
# should this be PUTDATA in case of PUT ?
my($param) = $meth . 'DATA' ;
'EXPIRES','NPH','CHARSET',
'ATTACHMENT','P3P'],@p);
+ # CR escaping for values, per RFC 822
+ for my $header ($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) {
+ if (defined $header) {
+ $header =~ s/
+ (?<=\n) # For any character proceeded by a newline
+ (?=\S) # ... that is not whitespace
+ / /xg; # ... inject a leading space in the new line
+ }
+ }
+
$nph ||= $NPH;
$type ||= 'text/html' unless defined($type);
# need to fix it up a little.
for (@other) {
# Don't use \s because of perl bug 21951
- next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
+ next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/s;
($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
}
my(@values);
@values = $self->_set_values_and_labels($values,\$labels,$name);
$tabindex = $self->element_tab($tabindex);
+ $name = q{} if ! defined $name;
$result = qq/<select name="$name" $tabindex$other>\n/;
for (@values) {
if (/<optgroup/) {
@values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
my($other) = @other ? " @other" : '';
- $name=$self->_maybe_escapeHTML($name);
+ $name = $self->_maybe_escapeHTML($name) || q{};
$result = qq/<optgroup label="$name"$other>\n/;
for (@values) {
if (/<optgroup/) {
# $uri =~ s/\Q$path\E$// if defined $path; # remove path
if ($full) {
- my $protocol = $self->protocol();
- $url = "$protocol://";
- my $vh = http('x_forwarded_host') || http('host') || '';
- $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it.
- if ($vh) {
- $url .= $vh;
- } else {
- $url .= server_name();
- }
- my $port = $self->server_port;
- $url .= ":" . $port
- unless (lc($protocol) eq 'http' && $port == 80)
- || (lc($protocol) eq 'https' && $port == 443);
+ my $protocol = $self->protocol();
+ $url = "$protocol://";
+ my $vh = http('x_forwarded_host') || http('host') || '';
+ $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it.
+
+ $url .= $vh || server_name();
+
+ my $port = $self->virtual_port;
+
+ # add the port to the url unless it's the protocol's default port
+ $url .= ':' . $port unless (lc($protocol) eq 'http' && $port == 80)
+ or (lc($protocol) eq 'https' && $port == 443);
+
return $url if $base;
- $url .= $uri;
+
+ $url .= $uri;
} elsif ($relative) {
($url) = $uri =~ m!([^/]+)$!;
} elsif ($absolute) {
use CGI;
- open (OUT,">>test.out") || die;
+ open (OUT,'>>','test.out') || die;
$records = 5;
for (0..$records) {
my $q = CGI->new;
close OUT;
# reopen for reading
- open (IN,"test.out") || die;
+ open (IN,'<','test.out') || die;
while (!eof(IN)) {
my $q = CGI->new(\*IN);
print $q->param('counter'),"\n";
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" );
+
+will generate
+
+ Ingredients: ham
+ eggs
+ bacon
+
=head2 GENERATING A REDIRECTION HEADER
print $q->redirect('http://somewhere.else/in/movie/land');
# undef may be returned if it's not a valid file handle
if (defined $lightweight_fh) {
# Upgrade the handle to one compatible with IO::Handle:
- my $io_handle = $lightweight_fh->handle;
+ my $io_handle = $lightweight_fh->handle;
- open (OUTFILE,">>/usr/local/web/users/feedback");
- while ($bytesread = $io_handle->read($buffer,1024)) {
- print OUTFILE $buffer;
- }
+ open (OUTFILE,'>>','/usr/local/web/users/feedback');
+ while ($bytesread = $io_handle->read($buffer,1024)) {
+ print OUTFILE $buffer;
+ }
}
In a list context, upload() will return an array of filehandles.
}
sub do_work {
- my(@values,$key);
print "<h2>Here are the current settings in this form</h2>";
- for $key (param) {
+ for my $key (param) {
print "<strong>$key</strong> -> ";
- @values = param($key);
+ my @values = param($key);
print join(", ",@values),"<br>\n";
}
}
sub die {
my ($arg,@rest) = @_;
- if ($DIE_HANDLER) {
- &$DIE_HANDLER($arg,@rest);
- }
+ &$DIE_HANDLER($arg,@rest) if $DIE_HANDLER;
- if ( ineval() ) {
- if (!ref($arg)) {
- $arg = join("",($arg,@rest)) || "Died";
- my($file,$line,$id) = id(1);
- $arg .= " at $file line $line.\n" unless $arg=~/\n$/;
- realdie($arg);
- }
- else {
- realdie($arg,@rest);
- }
- }
+ # 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;
+
+ $arg=~s/^/ stamp() /gme if $arg =~ /\n$/ or not exists $ENV{MOD_PERL};
+
+ $arg .= "\n" unless $arg =~ /\n$/;
- if (!ref($arg)) {
- $arg = join("", ($arg,@rest));
- my($file,$line,$id) = id(1);
- $arg .= " at $file line $line." unless $arg=~/\n$/;
- &fatalsToBrowser($arg) if $WRAP;
- if (($arg =~ /\n$/) || !exists($ENV{MOD_PERL})) {
- my $stamp = stamp;
- $arg=~s/^/$stamp/gm;
- }
- if ($arg !~ /\n$/) {
- $arg .= "\n";
- }
- }
realdie $arg;
}
# headers
sub fatalsToBrowser {
- my($msg) = @_;
+ my $msg = shift;
+
+ $msg = "$msg" if ref $msg;
+
$msg=~s/&/&/g;
$msg=~s/>/>/g;
$msg=~s/</</g;
- $msg=~s/\"/"/g;
+ $msg=~s/"/"/g;
+
my($wm) = $ENV{SERVER_ADMIN} ?
qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] :
"this site's webmaster";
package CGI::Cookie;
+use strict;
+use warnings;
+
# See the bottom of this file for the POD documentation. Search for the
# string '=head'.
$r ||= eval { $MOD_PERL == 2 ?
Apache2::RequestUtil->request() :
Apache->request } if $MOD_PERL;
- if ($r) {
- $raw_cookie = $r->headers_in->{'Cookie'};
- } else {
- if ($MOD_PERL && !exists $ENV{REQUEST_METHOD}) {
- die "Run $r->subprocess_env; before calling fetch()";
- }
- $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
- }
+
+ return $r->headers_in->{'Cookie'} if $r;
+
+ die "Run $r->subprocess_env; before calling fetch()"
+ if $MOD_PERL and !exists $ENV{REQUEST_METHOD};
+
+ return $ENV{HTTP_COOKIE} || $ENV{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],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@_);
+ rearrange([ 'NAME', ['VALUE','VALUES'], qw/ PATH DOMAIN SECURE EXPIRES
+ HTTPONLY / ], @_);
# Pull out our parameters.
my @values;
package CGI::Fast;
use strict;
-$^W=1; # A way to say "use warnings" that's compatible with even older perls.
+
+# A way to say "use warnings" that's compatible with even older perls.
+# making it local will not affect the code that loads this module
+# and since we're not in a BLOCK, warnings are enabled until the EOF
+local $^W = 1;
# See the bottom of this file for the POD documentation. Search for the
# string '=head'.
# wish, but if you redistribute a modified version, please attach a note
# listing the modifications you have made.
-$CGI::Fast::VERSION='1.07';
+$CGI::Fast::VERSION='1.08';
use CGI;
use FCGI;
# was always so and cannot be fixed without breaking the binary data case.
# -- Stepan Kasal <skasal@redhat.com>
#
+if ($] == 5.008) {
+ package utf8;
+
+ no warnings 'redefine'; # needed for Perl 5.8.1+
+
+ my $is_utf8_redefinition = <<'EOR';
+ sub is_utf8 {
+ my ($text) = @_;
+
+ my $ctext = pack q{C0a*}, $text;
+
+ return ($text ne $ctext) && ($ctext =~ m/^(
+ [\x09\x0A\x0D\x20-\x7E]
+ | [\xC2-\xDF][\x80-\xBF]
+ | \xE0[\xA0-\xBF][\x80-\xBF]
+ | [\xE1-\xEC\xEE\xEF][\x80-\xBF]{2}
+ | \xED[\x80-\x9F][\x80-\xBF]
+ | \xF0[\x90-\xBF][\x80-\xBF]{2}
+ | [\xF1-\xF3][\x80-\xBF]{3}
+ | \xF4[\x80-\x8F][\x80-\xBF]{2}
+ )*$/xo);
+ }
+EOR
+
+ eval $is_utf8_redefinition;
+}
+
sub escape {
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.008001 && utf8::is_utf8($toencode));
+ utf8::encode($toencode) if ($] >= 5.008 && utf8::is_utf8($toencode));
if ($EBCDIC) {
$toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
} else {
use strict;
-use Test::More tests => 41;
+use Test::More tests => 59;
use IO::Handle;
BEGIN { use_ok('CGI::Carp') };
# Test that realwarn is called
{
local $^W = 0;
- eval 'sub CGI::Carp::realdie {my $mess = shift; return $mess};';
-}
+ local *CGI::Carp::realdie = sub { my $mess = shift; return $mess };
-like(CGI::Carp::die('There is a problem'),
- $stamp,
- 'CGI::Carp::die calls CORE::die, but adds stamp');
+ like(CGI::Carp::die('There is a problem'),
+ $stamp,
+ 'CGI::Carp::die calls CORE::die, but adds stamp');
+
+}
#-----------------------------------------------------------------------------
# Test set_message
ok( defined buffer('::STDOUT'), 'STDIN returns proper filehandle');
ok( defined buffer(*main::STDOUT), 'STDIN returns proper filehandle');
ok(!defined buffer("WIBBLE"), '"WIBBLE" doesn\'t returns proper filehandle');
+
+# Calling die with code refs with no WRAP
+{
+ local $CGI::Carp::WRAP = 0;
+
+ eval { CGI::Carp::die( 'regular string' ) };
+ like $@ => qr/regular string/, 'die with string';
+
+ eval { CGI::Carp::die( [ 1..10 ] ) };
+ like $@ => qr/ARRAY\(0x[\da-f]+\)/, 'die with array ref';
+
+ eval { CGI::Carp::die( { a => 1 } ) };
+ like $@ => qr/HASH\(0x[\da-f]+\)/, 'die with hash ref';
+
+ eval { CGI::Carp::die( sub { 'Farewell' } ) };
+ like $@ => qr/CODE\(0x[\da-f]+\)/, 'die with code ref';
+
+ eval { CGI::Carp::die( My::Plain::Object->new ) };
+ isa_ok $@, 'My::Plain::Object';
+
+ eval { CGI::Carp::die( My::Plain::Object->new, ' and another argument' ) };
+ like $@ => qr/My::Plain::Object/, 'object is stringified';
+ like $@ => qr/and another argument/, 'second argument is present';
+
+ eval { CGI::Carp::die( My::Stringified::Object->new ) };
+ isa_ok $@, 'My::Stringified::Object';
+
+ eval { CGI::Carp::die( My::Stringified::Object->new, ' and another argument' ) };
+ like $@ => qr/stringified/, 'object is stringified';
+ like $@ => qr/and another argument/, 'second argument is present';
+
+ eval { CGI::Carp::die() };
+ like $@ => qr/Died at/, 'die with no argument';
+}
+
+# Calling die with code refs when WRAPped
+{
+ local $CGI::Carp::WRAP = 1;
+ local *CGI::Carp::realdie = sub { return @_ };
+ local *STDOUT;
+
+ tie *STDOUT, 'StoreStuff';
+
+ my %result; # store results because stdout is kidnapped
+
+ CGI::Carp::die( 'regular string' );
+ $result{string} .= $_ while <STDOUT>;
+
+ CGI::Carp::die( [ 1..10 ] );
+ $result{array_ref} .= $_ while <STDOUT>;
+
+ CGI::Carp::die( { a => 1 } );
+ $result{hash_ref} .= $_ while <STDOUT>;
+
+ CGI::Carp::die( sub { 'Farewell' } );
+ $result{code_ref} .= $_ while <STDOUT>;
+
+ CGI::Carp::die( My::Plain::Object->new );
+ $result{plain_object} .= $_ while <STDOUT>;
+
+ CGI::Carp::die( My::Stringified::Object->new );
+ $result{string_object} .= $_ while <STDOUT>;
+
+ CGI::Carp::die();
+ $result{no_args} .= $_ while <STDOUT>;
+
+ untie *STDOUT;
+
+ like $result{string} => qr/regular string/, 'regular string, wrapped';
+ like $result{array_ref} => qr/ARRAY\(\w+?\)/, 'array ref, wrapped';
+ like $result{hash_ref} => qr/HASH\(\w+?\)/, 'hash ref, wrapped';
+ like $result{code_ref} => qr/CODE\(\w+?\)/, 'code ref, wrapped';
+ like $result{plain_object} => qr/My::Plain::Object/,
+ 'plain object, wrapped';
+ like $result{string_object} => qr/stringified/,
+ 'stringified object, wrapped';
+ like $result{no_args} => qr/Died at/, 'no args, wrapped';
+
+}
+
+{
+ package My::Plain::Object;
+
+ sub new {
+ return bless {}, shift;
+ }
+}
+
+{
+ package My::Stringified::Object;
+
+ use overload '""' => sub { 'stringified' };
+
+ sub new {
+ return bless {}, shift;
+ }
+}
if (ord("\t") != 9) { $CRLF = "\r\n"; }
-# Web servers on EBCDIC hosts are typically set up to do an EBCDIC -> ASCII
-# translation hence CRLF is used as \r\n within CGI.pm on such machines.
-
-if (ord("\t") != 9) { $CRLF = "\r\n"; }
-
# Set up a CGI environment
$ENV{REQUEST_METHOD}='GET';
$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull';
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More tests => 4; # last test to print
+
+use CGI qw/ :all /;
+
+$ENV{HTTP_X_FORWARDED_HOST} = 'proxy:8484';
+$ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
+$ENV{SERVER_PORT} = 8080;
+$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
+
+is virtual_port() => 8484, 'virtual_port()';
+is server_port() => 8080, 'server_port()';
+
+is url() => 'http://proxy:8484', 'url()';
+
+# let's see if we do the defaults right
+
+$ENV{HTTP_X_FORWARDED_HOST} = 'proxy:80';
+
+is url() => 'http://proxy', 'url() with default port';
+
projects / p5sagit/p5-mst-13.2.git / commitdiff