# documentation in manual or html file format (these utilities are part of the
# Perl 5 distribution).
-# Copyright 1995,1996, Lincoln D. Stein. All rights reserved.
+# 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
# wish, but if you redistribute a modified version, please attach a note
# listing the modifications you have made.
-# The most recent version and complete docs are available at:
-# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
-# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
-
-$CGI::Cookie::VERSION='1.06';
+$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);
- $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 to be present for some reason.
- ($path = $ENV{'SCRIPT_NAME'})=~s![^/]+$!! unless $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;
- 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);
}
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;
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'};
}
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;
return $self->{'path'};
}
+
+sub httponly { # HttpOnly
+ my $self = shift;
+ my $httponly = shift;
+ $self->{'httponly'} = $httponly if defined $httponly;
+ return $self->{'httponly'};
+}
+
1;
=head1 NAME
If you provide a cookie path attribute, the browser will check it
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, path is set to "/", which
-causes the cookie to be sent to any CGI script on your site.
+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 "/", 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<http://msdn.microsoft.com/workshop/author/dhtml/httponly_cookies.asp>
+
=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
);
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<new()>. 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'],
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:
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
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
$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
$value = $c->value;
@new_value = $c->value(['a','b','c','d']);
-B<value()> is context sensitive. In an array context it will return
+B<value()> 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<first> value of a multivalued cookie.
=head1 AUTHOR INFORMATION
-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
-wish, but if you redistribute a modified version, please attach a note
-listing the modifications you have made.
+Copyright 1997-1998, Lincoln D. Stein. All rights reserved.
-Address bug reports and comments to:
-lstein@genome.wi.mit.edu
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Address bug reports and comments to: lstein@cshl.org
=head1 BUGS
=head1 SEE ALSO
L<CGI::Carp>, L<CGI>
-
+
=cut
projects / p5sagit/p5-mst-13.2.git / blobdiff