X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCGI%2FCookie.pm;h=926109ce3c6bee8ab08ac37556251ac4a32addab;hb=d9f30342f9de4793189d81b85a5e32057393e428;hp=433df496df03eb4242f9c61610a36722972705ed;hpb=3538e1d594b84483ebd9da2f46446c3f5afac4b5;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/CGI/Cookie.pm b/lib/CGI/Cookie.pm index 433df49..926109c 100644 --- a/lib/CGI/Cookie.pm +++ b/lib/CGI/Cookie.pm @@ -13,113 +13,159 @@ package CGI::Cookie; # wish, but if you redistribute a modified version, please attach a note # listing the modifications you have made. -$CGI::Cookie::VERSION='1.10'; +$CGI::Cookie::VERSION='1.27'; +use CGI::Util qw(rearrange unescape escape); use CGI; use overload '""' => \&as_string, 'cmp' => \&compare, 'fallback'=>1; +# Turn on special checking for Doug MacEachern's modperl +my $MOD_PERL = 0; +if (exists $ENV{MOD_PERL}) { + if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { + $MOD_PERL = 2; + require Apache2::RequestUtil; + require APR::Table; + } else { + $MOD_PERL = 1; + require Apache; + } +} + # fetch a list of cookies from the environment and # return as a hash. the cookies are parsed as normal # escaped URL data. sub fetch { my $class = shift; - my $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE}; - return () unless $raw_cookie; + my $raw_cookie = get_raw_cookie(@_) or return; return $class->parse($raw_cookie); } -# fetch a list of cookies from the environment and -# return as a hash. the cookie values are not unescaped -# or altered in any way. -sub raw_fetch { - my $class = shift; - my $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE}; - return () unless $raw_cookie; - my %results; - my($key,$value); - - my(@pairs) = split("; ",$raw_cookie); - foreach (@pairs) { - if (/^([^=]+)=(.*)/) { - $key = $1; - $value = $2; - } - else { - $key = $_; - $value = ''; - } - $results{$key} = $value; +# Fetch a list of cookies from the environment or the incoming headers and +# return as a hash. The cookie values are not unescaped or altered in any way. + sub raw_fetch { + my $class = shift; + my $raw_cookie = get_raw_cookie(@_) or return; + my %results; + 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; +} + +sub get_raw_cookie { + my $r = shift; + $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()"; } - return \%results unless wantarray; - return %results; + $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE}; + } } + sub parse { - my ($self,$raw_cookie) = @_; - my %results; - - my(@pairs) = split("; ",$raw_cookie); - foreach (@pairs) { - my($key,$value) = split("="); - my(@values) = map CGI::unescape($_),split('&',$value); - $key = CGI::unescape($key); - # A bug in Netscape can cause several cookies with same name to - # appear. The FIRST one in HTTP_COOKIE is the most recent version. - $results{$key} ||= $self->new(-name=>$key,-value=>\@values); + my ($self,$raw_cookie) = @_; + my %results; + + my(@pairs) = split("; ?",$raw_cookie); + foreach (@pairs) { + s/\s*(.*?)\s*/$1/; + my($key,$value) = split("=",$_,2); + + # Some foreign cookies are not in name=value format, so ignore + # them. + next if !defined($value); + my @values = (); + if ($value ne '') { + @values = map unescape($_),split(/[&;]/,$value.'&dmy'); + pop @values; } - return \%results unless wantarray; - return %results; + $key = unescape($key); + # A bug in Netscape can cause several cookies with same name to + # 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; } sub new { - my $class = shift; - $class = ref($class) if ref($class); - my($name,$value,$path,$domain,$secure,$expires) = - CGI->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@_); - - # 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 $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],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; } - - bless my $self = { - 'name'=>$name, - 'value'=>[@values], - },$class; - - # IE requires the path and domain to be present for some reason. - $path ||= CGI::url(-absolute=>1); - $domain ||= CGI::virtual_host(); - - $self->path($path) if defined $path; - $self->domain($domain) if defined $domain; - $self->secure($secure) if defined $secure; - $self->expires($expires) if defined $expires; - return $self; + } 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; + return $self; } sub as_string { my $self = shift; return "" unless $self->name; - my(@constant_values,$domain,$path,$expires,$secure); + my(@constant_values,$domain,$path,$expires,$max_age,$secure,$httponly); - push(@constant_values,"domain=$domain") if $domain = $self->domain; - push(@constant_values,"path=$path") if $path = $self->path; + 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,'secure') if $secure = $self->secure; + 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; - my($key) = CGI::escape($self->name); - my($cookie) = join("=",$key,join("&",map CGI::escape($_),$self->value)); + my($key) = escape($self->name); + my($cookie) = join("=",(defined $key ? $key : ''),join("&",map escape(defined $_ ? $_ : ''),$self->value)); return join("; ",$cookie,@constant_values); } @@ -129,6 +175,22 @@ sub compare { return "$self" cmp $value; } +sub bake { + my ($self, $r) = @_; + + $r ||= eval { + $MOD_PERL == 2 + ? Apache2::RequestUtil->request() + : Apache->request + } if $MOD_PERL; + if ($r) { + $r->headers_out->add('Set-Cookie' => $self->as_string); + } else { + print CGI::header(-cookie => $self); + } + +} + # accessors sub name { my $self = shift; @@ -140,14 +202,26 @@ sub name { sub value { my $self = shift; my $value = shift; - $self->{'value'} = $value if defined $value; + 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] } sub domain { my $self = shift; my $domain = shift; - $self->{'domain'} = $domain if defined $domain; + $self->{'domain'} = lc $domain if defined $domain; return $self->{'domain'}; } @@ -161,10 +235,17 @@ sub secure { sub expires { my $self = shift; my $expires = shift; - $self->{'expires'} = CGI::expires($expires,'cookie') if defined $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'}; +} + sub path { my $self = shift; my $path = shift; @@ -172,6 +253,14 @@ sub path { return $self->{'path'}; } + +sub httponly { # HttpOnly + my $self = shift; + my $httponly = shift; + $self->{'httponly'} = $httponly if defined $httponly; + return $self->{'httponly'}; +} + 1; =head1 NAME @@ -250,23 +339,36 @@ against your script's URL before returning the cookie. For example, if you specify the path "/cgi-bin", then the cookie will be returned to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and "/cgi-bin/customer_service/complain.pl", but not to the script -"/cgi-private/site_admin.pl". By default, the path is set to the -directory that contains your script. +"/cgi-private/site_admin.pl". By default, the path is set to "/", so +that all scripts at your site will receive the cookie. =item B<4. secure flag> If the "secure" attribute is set, the cookie will only be sent to your script if the CGI request is occurring on a secure channel, such as SSL. +=item B<4. httponly flag> + +If the "httponly" attribute is set, the cookie will only be accessible +through HTTP Requests. This cookie will be inaccessible via JavaScript +(to prevent XSS attacks). + +But, currently this feature only used and recognised by +MS Internet Explorer 6 Service Pack 1 and later. + +See this URL for more information: + +L + =back =head2 Creating New Cookies - $c = new CGI::Cookie(-name => 'foo', + my $c = new CGI::Cookie(-name => 'foo', -value => 'bar', -expires => '+3M', -domain => '.capricorn.com', - -path => '/cgi-bin/database' + -path => '/cgi-bin/database', -secure => 1 ); @@ -292,11 +394,31 @@ pages at your site. B<-secure> if set to a true value instructs the browser to return the cookie only when a cryptographic protocol is in use. +B<-httponly> if set to a true value, the cookie will not be accessible +via JavaScript. + +For compatibility with Apache::Cookie, you may optionally pass in +a mod_perl request object as the first argument to C. It will +simply be ignored: + + my $c = new CGI::Cookie($r, + -name => 'foo', + -value => ['bar','baz']); + =head2 Sending the Cookie to the Browser -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: +The simplest way to send a cookie to the browser is by calling the bake() +method: + + $c->bake; + +Under mod_perl, pass in an Apache request object: + + $c->bake($r); + +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'], @@ -306,8 +428,6 @@ sequence: print "Content-Type: text/html\n\n"; To send more than one cookie, create several Set-Cookie: fields. -Alternatively, you may concatenate the cookies together with "; " and -send them in one field. If you are using CGI.pm, you send cookies by providing a -cookie argument to the header() method: @@ -317,7 +437,7 @@ argument to the header() method: Mod_perl users can set cookies using the request object's header_out() method: - $r->header_out('Set-Cookie',$c); + $r->headers_out->set('Set-Cookie' => $c); Internally, Cookie overloads the "" operator to call its as_string() method when incorporated into the HTTP header. as_string() turns the @@ -341,7 +461,7 @@ can iterate through the cookies this way: In a scalar context, fetch() returns a hash reference, which may be more efficient if you are manipulating multiple cookies. - + CGI.pm uses the URL escaping methods to save and restore reserved characters in its cookies. If you are trying to retrieve a cookie set by a foreign server, this escaping method may trip you up. Use raw_fetch() instead, which has the @@ -353,6 +473,11 @@ form using the parse() class method: $COOKIES = `cat /usr/tmp/Cookie_stash`; %cookies = parse CGI::Cookie($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); + =head2 Manipulating Cookies Cookie objects have a series of accessor methods to get and set cookie @@ -377,7 +502,7 @@ Get or set the cookie's value. Example: $value = $c->value; @new_value = $c->value(['a','b','c','d']); -B is context sensitive. In an array context it will return +B is context sensitive. In a list context it will return the current value of the cookie as an array. In a scalar context it will return the B value of a multivalued cookie. @@ -412,5 +537,5 @@ This section intentionally left blank. =head1 SEE ALSO L, L - + =cut