Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge branch 'header-escape' of github.com:markstos/CGI.pm into heade…

…r-escape

Conflicts:
	lib/CGI.pm
	t/headers.t
  • Loading branch information...
commit 1bb256e385022e8bd72f781138bc994e9434531d 2 parents 1f1cc22 + 12271d7
@markstos authored
View
1  Makefile.PL
@@ -16,6 +16,7 @@ WriteMakefile(
'Test::More' => 0.80, # Ideally, this could be just a "test_requires"
'File::Spec' => .82,
'FCGI' => 0.67,
+ 'Time::Piece' => 0,
},
'linkext' => { LINKTYPE=>'' }, # no link needed
'dist' => {'COMPRESS'=>'gzip -9f', 'SUFFIX' => 'gz',
View
40 lib/CGI.pm
@@ -1039,24 +1039,28 @@ sub read_from_stdin {
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);
- }
+ while (1) {
+ eval {
+ local $SIG{ALRM} = sub { die "alarm\n" };
+ alarm 5;
+ $res = $MOD_PERL ? $self->r->read($tempbuf, $bufsiz, 0)
+ : read(\*STDIN, $tempbuf, $bufsiz)
+ ;
+ alarm 0;
+ };
+
+ if ( $@ ) {
+ return $res if $@ eq "alarm\n";
+ die $@; # wan't the timeout, propagate
+ }
- if ( !defined($res) ) {
- # TODO: how to do error reporting ?
- $eoffound = 1;
- last;
- }
- if ( $res == 0 ) {
- $eoffound = 1;
- last;
- }
- $localbuf .= $tempbuf;
+ if ( !defined($res) or $res == 0 ) {
+ # TODO: how to do error reporting ?
+ $eoffound = 1;
+ last;
+ }
+
+ $localbuf .= $tempbuf;
}
$$buff = $localbuf;
@@ -1564,7 +1568,7 @@ sub header {
$header = substr($header,0,72).'...' if (length $header > 72);
die "Invalid header value contains a newline not followed by whitespace: $header";
}
- }
+ }
}
$nph ||= $NPH;
View
71 lib/CGI.pm.rej
@@ -0,0 +1,71 @@
+--- cgi-lib_porting.html
++++ cgi-lib_porting.html
+@@ -88,7 +88,7 @@
+
+ <h2>How do I migrate from cgi-lib.pl to CGI.pm?</h2>
+
+-A compatability mode allows you to port most scripts that use
++A compatibility mode allows you to port most scripts that use
+ cgi-lib.pl to CGI.pm without making extensive source code changes.
+ Most of the functions defined in cgi-lib.pl version 2.10 are available
+ for your use. Missing functions are easy to work around. Follow this
+@@ -120,7 +120,7 @@
+ </pre></blockquote>
+
+ instructs Perl to read in CGI.pm and to import into your script's name
+-space the cgi-lib.pl compatability routines. (In case you've never
++space the cgi-lib.pl compatibility routines. (In case you've never
+ run into this syntax before, the colon in front of
+ <code>cgi-lib</code> indicates that we're importing a family of
+ routines identified by the tag <cite>cgi-lib</cite> rather than a
+@@ -173,7 +173,7 @@
+
+ <h2>Cgi-lib functions that are available in CGI.pm</h2>
+
+-In compatability mode, the following cgi-lib.pl functions are
++In compatibility mode, the following cgi-lib.pl functions are
+ available for your use:
+
+ <ol>
+@@ -237,7 +237,7 @@
+
+ <h2>Caveats</h2>
+
+-The compatability routines are a recent feature (added in CGI.pm
++The compatibility routines are a recent feature (added in CGI.pm
+ version 2.20, released on May 22, 1996) and may contain bugs.
+ <strong>Caveat emptor!</strong>
+ <hr>
+--- Pretty.pm
++++ Pretty.pm
+@@ -252,7 +252,7 @@
+ =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.
+
+--- Push.pm
++++ Push.pm
+@@ -214,7 +214,7 @@
+
+ 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
+--- Util.pm
++++ Util.pm
+@@ -383,7 +383,7 @@
+ 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
+
View
BIN  lib/CGI/.Util.pm.swp
Binary file not shown
View
131 lib/CGI/Cookie.pm
@@ -20,6 +20,7 @@ $CGI::Cookie::VERSION='1.29';
use CGI::Util qw(rearrange unescape escape);
use CGI;
+use Carp;
use overload '""' => \&as_string,
'cmp' => \&compare,
'fallback'=>1;
@@ -123,25 +124,22 @@ sub new {
# 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) =
+ my($name,$value,$path,$domain,$secure,$expires,$max_age, $httponly) =
rearrange([ 'NAME', ['VALUE','VALUES'], qw/ PATH DOMAIN SECURE EXPIRES
- HTTPONLY / ], @_);
-
+ MAX_AGE HTTPONLY / ], @_);
+ croak "can't use both 'expires' and 'max_age' arguments at the same time"
+ if $expires and $max_age;
+
# 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);
- }
-
+ my @values = !ref $value ? $value
+ : ref $value eq 'ARRAY' ? @$value
+ : ref $value eq 'HASH' ? %$value
+ : ()
+ ;
+
bless my $self = {
- 'name'=>$name,
- 'value'=>[@values],
+ 'name' => $name,
+ 'value' => \@values,
},$class;
# IE requires the path and domain to be present for some reason.
@@ -154,8 +152,9 @@ sub new {
$self->domain($domain) if defined $domain;
$self->secure($secure) if defined $secure;
$self->expires($expires) if defined $expires;
+ $self->max_age($max_age) if defined $max_age;
$self->httponly($httponly) if defined $httponly;
-# $self->max_age($expires) if defined $expires;
+
return $self;
}
@@ -167,8 +166,10 @@ sub as_string {
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;
+ if ( defined $self->max_age ) {
+ push @constant_values, 'expires='.$self->expires;
+ push @constant_values, 'max-age='.$self->max_age;
+ }
push(@constant_values,"secure") if $secure = $self->secure;
push(@constant_values,"HttpOnly") if $httponly = $self->httponly;
@@ -178,8 +179,7 @@ sub as_string {
}
sub compare {
- my $self = shift;
- my $value = shift;
+ my ( $self, $value ) = @_;
return "$self" cmp $value;
}
@@ -242,16 +242,41 @@ sub secure {
sub expires {
my $self = shift;
- my $expires = shift;
- $self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires;
- return $self->{'expires'};
+
+ if( @_ ) {
+ my $time = shift;
+
+ return $self->{max_age} = undef unless defined $time;
+
+ $time -= time if $time =~ /^\d+/;
+ $self->{max_age} = CGI::Util::max_age_calc( $time );
+ }
+
+ return defined( $self->{max_age} )
+ ? CGI::Util::expires(time() + $self->{max_age},'cookie')
+ : undef
+ ;
}
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'};
+
+ if ( @_ ) {
+ my $max_age = shift;
+
+ return $self->{max_age} = undef unless defined $max_age;
+
+ # so that passing a max age of 3 isn't considered as
+ # a timestamp of the 70s
+ $max_age = '+' . $max_age unless $max_age =~ /^[+-]/;
+ $self->{max_age} = 0 + CGI::Util::max_age_calc($max_age);
+ }
+
+ return unless defined $self->{max_age};
+
+ # don't know how browsers would react to negative numbers,
+ # so I take no chance
+ return $self->{max_age} > 0 ? $self->{max_age} : 0 ;
}
sub path {
@@ -281,11 +306,14 @@ 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',
- -value=>{ font => Helvetica,
- size => 12 }
- );
+ $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
@@ -375,13 +403,13 @@ See these URLs for more information:
=head2 Creating New Cookies
- my $c = new CGI::Cookie(-name => 'foo',
- -value => 'bar',
- -expires => '+3M',
- -domain => '.capricorn.com',
- -path => '/cgi-bin/database',
- -secure => 1
- );
+ my $c = CGI::Cookie->new( -name => 'foo',
+ -value => 'bar',
+ -max_age => '+3M',
+ -domain => '.capricorn.com',
+ -path => '/cgi-bin/database',
+ -secure => 1
+ );
Create cookies from scratch with the B<new> method. The B<-name> and
B<-value> parameters are required. The name must be a scalar value.
@@ -389,9 +417,14 @@ The value can be a scalar, an array reference, or a hash reference.
(At some point in the future cookies will support one of the Perl
object serialization protocols for full generality).
-B<-expires> accepts any of the relative or absolute date formats
+B<-max_age>, or 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.
+future. The only difference in behavior between the two arguments
+is if the time is passed
+as a raw number: B<-expires> will consider it as timestamp, whereas
+B<-max_age> will see it as the number of seconds before the cookie expires.
+Beside this distinction, both arguments can be used interchangeably.
+They can't, however, be used at the same time.
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
@@ -431,9 +464,11 @@ 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',
- -value => ['bar','baz'],
- -expires => '+3M');
+ my $c = CGI::Cookie->(
+ -name => 'foo',
+ -value => ['bar','baz'],
+ -max_age => '+3M'
+ );
print "Set-Cookie: $c\n";
print "Content-Type: text/html\n\n";
@@ -525,9 +560,13 @@ Get or set the cookie's domain.
Get or set the cookie's path.
-=item B<expires()>
+=item B<expires()>, B<max_age()>
-Get or set the cookie's expiration time.
+Get or set the cookie's expiration time. Both functions
+treat the passed expiration time the same, unless it is
+a raw number. In that case B<expires> will consider it as timestamp
+and B<max_age> will see it as the number of seconds before the
+cookie expires.
=back
View
60 lib/CGI/Pretty.pm.rej
@@ -0,0 +1,60 @@
+--- cgi-lib_porting.html
++++ cgi-lib_porting.html
+@@ -88,7 +88,7 @@
+
+ <h2>How do I migrate from cgi-lib.pl to CGI.pm?</h2>
+
+-A compatability mode allows you to port most scripts that use
++A compatibility mode allows you to port most scripts that use
+ cgi-lib.pl to CGI.pm without making extensive source code changes.
+ Most of the functions defined in cgi-lib.pl version 2.10 are available
+ for your use. Missing functions are easy to work around. Follow this
+@@ -120,7 +120,7 @@
+ </pre></blockquote>
+
+ instructs Perl to read in CGI.pm and to import into your script's name
+-space the cgi-lib.pl compatability routines. (In case you've never
++space the cgi-lib.pl compatibility routines. (In case you've never
+ run into this syntax before, the colon in front of
+ <code>cgi-lib</code> indicates that we're importing a family of
+ routines identified by the tag <cite>cgi-lib</cite> rather than a
+@@ -173,7 +173,7 @@
+
+ <h2>Cgi-lib functions that are available in CGI.pm</h2>
+
+-In compatability mode, the following cgi-lib.pl functions are
++In compatibility mode, the following cgi-lib.pl functions are
+ available for your use:
+
+ <ol>
+@@ -237,7 +237,7 @@
+
+ <h2>Caveats</h2>
+
+-The compatability routines are a recent feature (added in CGI.pm
++The compatibility routines are a recent feature (added in CGI.pm
+ version 2.20, released on May 22, 1996) and may contain bugs.
+ <strong>Caveat emptor!</strong>
+ <hr>
+--- Push.pm
++++ Push.pm
+@@ -214,7 +214,7 @@
+
+ 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
+--- Util.pm
++++ Util.pm
+@@ -383,7 +383,7 @@
+ 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
+
View
46 lib/CGI/Util.pm
@@ -3,6 +3,8 @@ package CGI::Util;
use strict;
use vars qw($VERSION @EXPORT_OK @ISA @A2E @E2A);
require Exporter;
+use Carp;
+
@ISA = qw(Exporter);
@EXPORT_OK = qw(rearrange rearrange_header make_attributes unescape escape
expires ebcdic2ascii ascii2ebcdic);
@@ -293,12 +295,8 @@ sub expires {
my($time,$format) = @_;
$format ||= 'http';
- my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
- my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
-
- # pass through preformatted dates for the sake of expire_calc()
- $time = expire_calc($time);
- return $time unless $time =~ /^\d+$/;
+ my @MON =qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
+ my @WDAY = qw/Sun Mon Tue Wed Thu Fri Sat/;
# make HTTP/cookie date string from GMT'ed time
# (cookies use '-' as date separator, HTTP uses ' ')
@@ -314,6 +312,10 @@ sub expires {
# hours from the current time. It incorporates modifications from
# Mark Fisher.
sub expire_calc {
+ return max_age_calc( @_ ) + time;
+}
+
+sub max_age_calc {
my($time) = @_;
my(%mult) = ('s'=>1,
'm'=>60,
@@ -330,19 +332,25 @@ sub expire_calc {
# "+3M" -- in 3 months
# "+2y" -- in 2 years
# "-3m" -- 3 minutes ago(!)
- # If you don't supply one of these forms, we assume you are
- # specifying the date yourself
- my($offset);
- if (!$time || (lc($time) eq 'now')) {
- $offset = 0;
- } elsif ($time=~/^\d+/) {
- return $time;
- } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) {
- $offset = ($mult{$2} || 1)*$1;
- } else {
- return $time;
- }
- return (time+$offset);
+
+ return 0 if !$time or lc($time) eq 'now';
+
+ return $time if $time=~/^\d+/;
+
+ return ($mult{$2} || 1)*$1
+ if $time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/;
+
+ if ( $time =~ /^(Mon|Tue|Wed|Thu|Fri|Sat|Sun)/ ) {
+ require Time::Piece;
+ my $delta = eval {
+ Time::Piece->strptime( $time, "%a, %d-%b-%Y %T GMT" )->epoch
+ - time;
+ };
+ croak "couldn't parse time string '$time'" if $@;
+ return $delta;
+ }
+
+ return $time;
}
sub ebcdic2ascii {
View
72 t/cookie.t
@@ -2,7 +2,13 @@
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 tests => 110;
use CGI::Util qw(escape unescape);
use POSIX qw(strftime);
@@ -256,7 +262,7 @@ my @test_cookie = (
# 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',
@@ -321,6 +327,68 @@ my @test_cookie = (
ok(!$c->secure, 'secure attribute is cleared');
}
+#----------------------------------------------------------------------------
+# Max-age
+#----------------------------------------------------------------------------
+
+MAX_AGE: {
+ eval {
+ CGI::Cookie->new(
+ -expires => '+2M',
+ -max_age => '+2M',
+ );
+ };
+
+ like $@ =>
+ qr/can't use both 'expires' and 'max_age' arguments at the same time/,
+ q{can't use expires and max_age at the same time};
+
+ my $cookie_expires = CGI::Cookie->new( -expires => '+3y' );
+ my $cookie_max_age = CGI::Cookie->new( -max_age => '+3y' );
+
+ is $cookie_expires => $cookie_max_age,
+ 'max-age and expires new() arguments';
+
+
+ my $cookie = CGI::Cookie->new(
+ -name => 'foo',
+ -expires => 'now',
+ );
+
+ is $cookie->expires, 'Thu, 01-Jan-1970 00:01:40 GMT';
+ is $cookie->max_age => 0, 'max-age for now is zero';
+
+ $cookie->expires( '+3d' );
+ is $cookie->expires, 'Sun, 04-Jan-1970 00:01:40 GMT';
+ is $cookie->max_age => 3*24*60*60, 'setting via expires';
+
+ $cookie->max_age( '+4d' );
+ is $cookie->expires, 'Mon, 05-Jan-1970 00:01:40 GMT';
+ is $cookie->max_age => 4*24*60*60, 'setting via max-age';
+
+ $cookie->expires( '113' );
+ is $cookie->max_age => 13, 'expires(num) as timestamp';
+
+ $cookie->max_age( '113' );
+ is $cookie->max_age => 113, 'max_age(num) as delta';
+
+ $cookie->max_age( -99 );
+ is $cookie->max_age => 0, 'negative max-age => delta of 0';
+ is $cookie->expires => 'Thu, 01-Jan-1970 00:00:01 GMT', '...but the expires is in the past';
+
+ $cookie->max_age( undef );
+ unlike "$cookie" => qr/max-age|expires/,
+ 'undef the max-age removes it from the cookie';
+
+ $cookie->max_age( 100 );
+ $cookie->expires( undef );
+ unlike "$cookie" => qr/max-age|expires/,
+ 'undef the expires removes it from the cookie';
+
+}
+
+
+
#-----------------------------------------------------------------------------
# Apache2?::Cookie compatibility.
#-----------------------------------------------------------------------------
View
1  t/headers.t
@@ -44,4 +44,3 @@ like($@,qr/contains a newline/,'redirect with leading newlines blows up');
like($@,qr/contains a newline/, "redirect does not allow double-newline injection");
}
-
View
14 t/rt-52469.t
@@ -0,0 +1,14 @@
+use strict;
+use warnings;
+
+use Test::More tests => 1; # last test to print
+
+use CGI;
+
+$ENV{REQUEST_METHOD} = 'PUT';
+
+my $cgi = CGI->new;
+
+pass 'new() returned';
+
+

1 comment on commit 1bb256e

@markstos
Owner

This commit looks like it has a mish-mash of changes which should be abandoned.

Please sign in to comment.
Something went wrong with that request. Please try again.