develooper Front page | perl.libwww | Postings from July 2001

[PATCH] HTTP::Cookies extract_cookies

From:
Gisle Aas
Date:
July 20, 2001 13:09
Subject:
[PATCH] HTTP::Cookies extract_cookies
Message ID:
200107202009.NAA20582@caliper.ActiveState.com
The extract_cookies method of HTTP::Cookies used to ignore all Set-Cookie
headers if there was any Set-Cookie2 headers in the response.  This was wrong.
Only Set-Cookie headers that reference the same cookie as a Set-Cookie2
header was to be ignored.  This is a patch fixes that problem.

Regards,
Gisle


Index: lib/HTTP/Cookies.pm
===================================================================
RCS file: /cvsroot/libwww-perl/lwp5/lib/HTTP/Cookies.pm,v
retrieving revision 1.16
diff -u -p -u -r1.16 Cookies.pm
--- lib/HTTP/Cookies.pm	2001/04/04 17:30:44	1.16
+++ lib/HTTP/Cookies.pm	2001/07/20 20:03:54
@@ -240,14 +240,12 @@ sub extract_cookies
 {
     my $self = shift;
     my $response = shift || return;
+
     my @set = split_header_words($response->_header("Set-Cookie2"));
-    my $netscape_cookies;
-    unless (@set) {
-	@set = $response->_header("Set-Cookie");
-	return $response unless @set;
-	$netscape_cookies++;
-    }
+    my @ns_set = $response->_header("Set-Cookie");
 
+    return $response unless @set || @ns_set;  # quick exit
+
     my $url = $response->request->url;
     my $req_host = $url->host;
     $req_host = "$req_host.local" unless $req_host =~ /\./;
@@ -255,16 +253,23 @@ sub extract_cookies
     my $req_path = _url_path($url);
     _normalize_path($req_path) if $req_path =~ /%/;
 
-    if ($netscape_cookies) {
+    if (@ns_set) {
 	# The old Netscape cookie format for Set-Cookie
         # http://www.netscape.com/newsref/std/cookie_spec.html
 	# can for instance contain an unquoted "," in the expires
 	# field, so we have to use this ad-hoc parser.
 	my $now = time();
-	my @old = @set;
-	@set = ();
+
+	# Build a hash of cookies that was present in Set-Cookie2
+	# headers.  We need to skip them if we also find them in a
+	# Set-Cookie header.
+	my %in_set2;
+	for (@set) {
+	    $in_set2{$_->[0]}++;
+	}
+
 	my $set;
-	for $set (@old) {
+	for $set (@ns_set) {
 	    my @cur;
 	    my $param;
 	    my $expires;
@@ -282,9 +287,12 @@ sub extract_cookies
 		    push(@cur, $k => $v);
 		}
 	    }
+	    next if $in_set2{$cur[0]};
+
 #	    push(@cur, "Port" => $req_port);
 	    push(@cur, "Discard" => undef) unless $expires;
 	    push(@cur, "Version" => 0);
+	    push(@cur, "ns-cookie" => 1);
 	    push(@set, \@cur);
 	}
     }
@@ -319,6 +327,7 @@ sub extract_cookies
 	my $discard   = delete $hash{discard};
 	my $secure    = delete $hash{secure};
 	my $maxage    = delete $hash{'max-age'};
+	my $ns_cookie = delete $hash{'ns-cookie'};
 
 	# Check domain
 	my $domain  = delete $hash{domain};
@@ -338,7 +347,7 @@ sub extract_cookies
 		next SET_COOKIE;
 	    }
 	    my $hostpre = substr($req_host, 0, length($req_host) - $len);
-	    if ($hostpre =~ /\./ && !$netscape_cookies) {
+	    if ($hostpre =~ /\./ && !$ns_cookie) {
 	        LWP::Debug::debug("Host prefix contain a dot: $hostpre => $domain");
 		next SET_COOKIE;
 	    }
@@ -351,7 +360,7 @@ sub extract_cookies
 	if (defined $path && $path ne '') {
 	    $path_spec++;
 	    _normalize_path($path) if $path =~ /%/;
-	    if (!$netscape_cookies &&
+	    if (!$ns_cookie &&
                 substr($req_path, 0, length($path)) ne $path) {
 	        LWP::Debug::debug("Path $path is not a prefix of $req_path");
 		next SET_COOKIE;
Index: t/base/cookies.t
===================================================================
RCS file: /cvsroot/libwww-perl/lwp5/t/base/cookies.t,v
retrieving revision 1.9
diff -u -p -u -r1.9 cookies.t
--- t/base/cookies.t	2001/04/04 17:30:47	1.9
+++ t/base/cookies.t	2001/07/20 20:03:54
@@ -1,4 +1,4 @@
-print "1..34\n";
+print "1..35\n";
 
 #use LWP::Debug '+';
 use HTTP::Cookies;
@@ -531,7 +531,40 @@ print "not " unless $req->header("Cookie
                     $req->header("Cookie2") eq "\$Version=\"1\"";
 print "ok 34\n";
 
+# test mixing of Set-Cookie and Set-Cookie2 headers.
+# Example from http://www.trip.com/trs/trip/flighttracker/flight_tracker_home.xsl
+# which gives up these headers:
+#
+# HTTP/1.1 200 OK
+# Connection: close
+# Date: Fri, 20 Jul 2001 19:54:58 GMT
+# Server: Apache/1.3.19 (Unix) ApacheJServ/1.1.2
+# Content-Type: text/html
+# Content-Type: text/html; charset=iso-8859-1
+# Link: </trip/stylesheet.css>; rel="stylesheet"; type="text/css"
+# Servlet-Engine: Tomcat Web Server/3.2.1 (JSP 1.1; Servlet 2.2; Java 1.3.0; SunOS 5.8 sparc; java.vendor=Sun Microsystems Inc.)
+# Set-Cookie: trip.appServer=1111-0000-x-024;Domain=.trip.com;Path=/
+# Set-Cookie: JSESSIONID=fkumjm7nt1.JS24;Path=/trs
+# Set-Cookie2: JSESSIONID=fkumjm7nt1.JS24;Version=1;Discard;Path="/trs"
+# Title: TRIP.com Travel - FlightTRACKER
+# X-Meta-Description: Trip.com privacy policy
+# X-Meta-Keywords: privacy policy
+
+$req = HTTP::Request->new('GET', 'http://www.trip.com/trs/trip/flighttracker/flight_tracker_home.xsl');
+$res = HTTP::Response->new(200, "OK");
+$res->request($req);
+$res->push_header("Set-Cookie"  => qq(trip.appServer=1111-0000-x-024;Domain=.trip.com;Path=/));
+$res->push_header("Set-Cookie"  => qq(JSESSIONID=fkumjm7nt1.JS24;Path=/trs));
+$res->push_header("Set-Cookie2" => qq(JSESSIONID=fkumjm7nt1.JS24;Version=1;Discard;Path="/trs"));
+#print $res->as_string;
 
+$c = HTTP::Cookies->new;  # clear it
+$c->extract_cookies($res);
+print $c->as_string;
+print "not " unless $c->as_string eq <<'EOT'; print "ok 35\n";
+Set-Cookie3: trip.appServer="1111-0000-x-024"; path="/"; domain=".trip.com"; path_spec; discard; version=0
+Set-Cookie3: JSESSIONID="fkumjm7nt1.JS24"; path="/trs"; domain="www.trip.com"; path_spec; discard; version=1
+EOT
 
 #-------------------------------------------------------------------
 



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About