HTTP-Cookies-6.00/000755 000765 000024 00000000000 11532553146 014063 5ustar00gislestaff000000 000000 HTTP-Cookies-6.00/Changes000644 000765 000024 00000000525 11532553076 015362 0ustar00gislestaff000000 000000 _______________________________________________________________________________ 2011-02-27 HTTP-Cookies 6.00 Initial release of HTTP-Cookies as a separate distribution. There are no code changes besides incrementing the version number since libwww-perl-5.837. The HTTP::Cookies module used to be bundled with the libwww-perl distribution. HTTP-Cookies-6.00/lib/000755 000765 000024 00000000000 11532553146 014631 5ustar00gislestaff000000 000000 HTTP-Cookies-6.00/Makefile.PL000644 000765 000024 00000002173 11532552773 016045 0ustar00gislestaff000000 000000 #!perl -w require 5.008008; use strict; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'HTTP::Cookies', VERSION_FROM => 'lib/HTTP/Cookies.pm', ABSTRACT_FROM => 'lib/HTTP/Cookies.pm', AUTHOR => 'Gisle Aas ', LICENSE => "perl", MIN_PERL_VERSION => 5.008008, PREREQ_PM => { 'HTTP::Date' => 6, 'HTTP::Headers::Util' => 6, 'Time::Local' => 0, }, META_MERGE => { resources => { repository => 'http://github.com/gisle/libwww-perl', MailingList => 'mailto:libwww@perl.org', } }, ); BEGIN { # compatibility with older versions of MakeMaker my $developer = -f ".gitignore"; my %mm_req = ( LICENCE => 6.31, META_MERGE => 6.45, META_ADD => 6.45, MIN_PERL_VERSION => 6.48, ); undef(*WriteMakefile); *WriteMakefile = sub { my %arg = @_; for (keys %mm_req) { unless (eval { ExtUtils::MakeMaker->VERSION($mm_req{$_}) }) { warn "$_ $@" if $developer; delete $arg{$_}; } } ExtUtils::MakeMaker::WriteMakefile(%arg); }; } HTTP-Cookies-6.00/MANIFEST000644 000765 000024 00000000343 11532553146 015214 0ustar00gislestaff000000 000000 Changes lib/HTTP/Cookies.pm lib/HTTP/Cookies/Microsoft.pm lib/HTTP/Cookies/Netscape.pm Makefile.PL MANIFEST This list of files README t/cookies.t META.yml Module meta-data (added by MakeMaker) HTTP-Cookies-6.00/META.yml000644 000765 000024 00000001343 11532553146 015335 0ustar00gislestaff000000 000000 --- #YAML:1.0 name: HTTP-Cookies version: 6.00 abstract: HTTP cookie jars author: - Gisle Aas license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: HTTP::Date: 6 HTTP::Headers::Util: 6 perl: 5.008008 Time::Local: 0 resources: MailingList: mailto:libwww@perl.org repository: http://github.com/gisle/libwww-perl no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.56 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 HTTP-Cookies-6.00/README000644 000765 000024 00000013677 11532553001 014747 0ustar00gislestaff000000 000000 NAME HTTP::Cookies - HTTP cookie jars SYNOPSIS use HTTP::Cookies; $cookie_jar = HTTP::Cookies->new( file => "$ENV{'HOME'}/lwp_cookies.dat", autosave => 1, ); use LWP; my $browser = LWP::UserAgent->new; $browser->cookie_jar($cookie_jar); Or for an empty and temporary cookie jar: use LWP; my $browser = LWP::UserAgent->new; $browser->cookie_jar( {} ); DESCRIPTION This class is for objects that represent a "cookie jar" -- that is, a database of all the HTTP cookies that a given LWP::UserAgent object knows about. Cookies are a general mechanism which server side connections can use to both store and retrieve information on the client side of the connection. For more information about cookies refer to and . This module also implements the new style cookies described in *RFC 2965*. The two variants of cookies are supposed to be able to coexist happily. Instances of the class *HTTP::Cookies* are able to store a collection of Set-Cookie2: and Set-Cookie: headers and are able to use this information to initialize Cookie-headers in *HTTP::Request* objects. The state of a *HTTP::Cookies* object can be saved in and restored from files. METHODS The following methods are provided: $cookie_jar = HTTP::Cookies->new The constructor takes hash style parameters. The following parameters are recognized: file: name of the file to restore cookies from and save cookies to autosave: save during destruction (bool) ignore_discard: save even cookies that are requested to be discarded (bool) hide_cookie2: do not add Cookie2 header to requests Future parameters might include (not yet implemented): max_cookies 300 max_cookies_per_domain 20 max_cookie_size 4096 no_cookies list of domain names that we never return cookies to $cookie_jar->add_cookie_header( $request ) The add_cookie_header() method will set the appropriate Cookie:-header for the *HTTP::Request* object given as argument. The $request must have a valid url attribute before this method is called. $cookie_jar->extract_cookies( $response ) The extract_cookies() method will look for Set-Cookie: and Set-Cookie2: headers in the *HTTP::Response* object passed as argument. Any of these headers that are found are used to update the state of the $cookie_jar. $cookie_jar->set_cookie( $version, $key, $val, $path, $domain, $port, $path_spec, $secure, $maxage, $discard, \%rest ) The set_cookie() method updates the state of the $cookie_jar. The $key, $val, $domain, $port and $path arguments are strings. The $path_spec, $secure, $discard arguments are boolean values. The $maxage value is a number indicating number of seconds that this cookie will live. A value <= 0 will delete this cookie. %rest defines various other attributes like "Comment" and "CommentURL". $cookie_jar->save $cookie_jar->save( $file ) This method file saves the state of the $cookie_jar to a file. The state can then be restored later using the load() method. If a filename is not specified we will use the name specified during construction. If the attribute *ignore_discard* is set, then we will even save cookies that are marked to be discarded. The default is to save a sequence of "Set-Cookie3" lines. "Set-Cookie3" is a proprietary LWP format, not known to be compatible with any browser. The *HTTP::Cookies::Netscape* sub-class can be used to save in a format compatible with Netscape. $cookie_jar->load $cookie_jar->load( $file ) This method reads the cookies from the file and adds them to the $cookie_jar. The file must be in the format written by the save() method. $cookie_jar->revert This method empties the $cookie_jar and re-loads the $cookie_jar from the last save file. $cookie_jar->clear $cookie_jar->clear( $domain ) $cookie_jar->clear( $domain, $path ) $cookie_jar->clear( $domain, $path, $key ) Invoking this method without arguments will empty the whole $cookie_jar. If given a single argument only cookies belonging to that domain will be removed. If given two arguments, cookies belonging to the specified path within that domain are removed. If given three arguments, then the cookie with the specified key, path and domain is removed. $cookie_jar->clear_temporary_cookies Discard all temporary cookies. Scans for all cookies in the jar with either no expire field or a true `discard' flag. To be called when the user agent shuts down according to RFC 2965. $cookie_jar->scan( \&callback ) The argument is a subroutine that will be invoked for each cookie stored in the $cookie_jar. The subroutine will be invoked with the following arguments: 0 version 1 key 2 val 3 path 4 domain 5 port 6 path_spec 7 secure 8 expires 9 discard 10 hash $cookie_jar->as_string $cookie_jar->as_string( $skip_discardables ) The as_string() method will return the state of the $cookie_jar represented as a sequence of "Set-Cookie3" header lines separated by "\n". If $skip_discardables is TRUE, it will not return lines for cookies with the *Discard* attribute. SEE ALSO HTTP::Cookies::Netscape, HTTP::Cookies::Microsoft COPYRIGHT Copyright 1997-2002 Gisle Aas This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. HTTP-Cookies-6.00/t/000755 000765 000024 00000000000 11532553146 014326 5ustar00gislestaff000000 000000 HTTP-Cookies-6.00/t/cookies.t000644 000765 000024 00000054724 11532553001 016151 0ustar00gislestaff000000 000000 #!perl -w use Test; plan tests => 66; use HTTP::Cookies; use HTTP::Request; use HTTP::Response; #------------------------------------------------------------------- # First we check that it works for the original example at # http://curl.haxx.se/rfc/cookie_spec.html # Client requests a document, and receives in the response: # # Set-Cookie: CUSTOMER=WILE_E_COYOTE; path=/; expires=Wednesday, 09-Nov-99 23:12:40 GMT # # When client requests a URL in path "/" on this server, it sends: # # Cookie: CUSTOMER=WILE_E_COYOTE # # Client requests a document, and receives in the response: # # Set-Cookie: PART_NUMBER=ROCKET_LAUNCHER_0001; path=/ # # When client requests a URL in path "/" on this server, it sends: # # Cookie: CUSTOMER=WILE_E_COYOTE; PART_NUMBER=ROCKET_LAUNCHER_0001 # # Client receives: # # Set-Cookie: SHIPPING=FEDEX; path=/fo # # When client requests a URL in path "/" on this server, it sends: # # Cookie: CUSTOMER=WILE_E_COYOTE; PART_NUMBER=ROCKET_LAUNCHER_0001 # # When client requests a URL in path "/foo" on this server, it sends: # # Cookie: CUSTOMER=WILE_E_COYOTE; PART_NUMBER=ROCKET_LAUNCHER_0001; SHIPPING=FEDEX # # The last Cookie is buggy, because both specifications says that the # most specific cookie must be sent first. SHIPPING=FEDEX is the # most specific and should thus be first. my $year_plus_one = (localtime)[5] + 1900 + 1; $c = HTTP::Cookies->new; $req = HTTP::Request->new(GET => "http://1.1.1.1/"); $req->header("Host", "www.acme.com:80"); $res = HTTP::Response->new(200, "OK"); $res->request($req); $res->header("Set-Cookie" => "CUSTOMER=WILE_E_COYOTE; path=/ ; expires=Wednesday, 09-Nov-$year_plus_one 23:12:40 GMT"); #print $res->as_string; $c->extract_cookies($res); $req = HTTP::Request->new(GET => "http://www.acme.com/"); $c->add_cookie_header($req); ok($req->header("Cookie"), "CUSTOMER=WILE_E_COYOTE"); ok($req->header("Cookie2"), "\$Version=\"1\""); $res->request($req); $res->header("Set-Cookie" => "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/"); $c->extract_cookies($res); $req = HTTP::Request->new(GET => "http://www.acme.com/foo/bar"); $c->add_cookie_header($req); $h = $req->header("Cookie"); ok($h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/); ok($h =~ /CUSTOMER=WILE_E_COYOTE/); $res->request($req); $res->header("Set-Cookie", "SHIPPING=FEDEX; path=/foo"); $c->extract_cookies($res); $req = HTTP::Request->new(GET => "http://www.acme.com/"); $c->add_cookie_header($req); $h = $req->header("Cookie"); ok($h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/); ok($h =~ /CUSTOMER=WILE_E_COYOTE/); ok($h !~ /SHIPPING=FEDEX/); $req = HTTP::Request->new(GET => "http://www.acme.com/foo/"); $c->add_cookie_header($req); $h = $req->header("Cookie"); ok($h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/); ok($h =~ /CUSTOMER=WILE_E_COYOTE/); ok($h =~ /^SHIPPING=FEDEX;/); print $c->as_string; # Second Example transaction sequence: # # Assume all mappings from above have been cleared. # # Client receives: # # Set-Cookie: PART_NUMBER=ROCKET_LAUNCHER_0001; path=/ # # When client requests a URL in path "/" on this server, it sends: # # Cookie: PART_NUMBER=ROCKET_LAUNCHER_0001 # # Client receives: # # Set-Cookie: PART_NUMBER=RIDING_ROCKET_0023; path=/ammo # # When client requests a URL in path "/ammo" on this server, it sends: # # Cookie: PART_NUMBER=RIDING_ROCKET_0023; PART_NUMBER=ROCKET_LAUNCHER_0001 # # NOTE: There are two name/value pairs named "PART_NUMBER" due to # the inheritance of the "/" mapping in addition to the "/ammo" mapping. $c = HTTP::Cookies->new; # clear it $req = HTTP::Request->new(GET => "http://www.acme.com/"); $res = HTTP::Response->new(200, "OK"); $res->request($req); $res->header("Set-Cookie", "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/"); $c->extract_cookies($res); $req = HTTP::Request->new(GET => "http://www.acme.com/"); $c->add_cookie_header($req); ok($req->header("Cookie"), "PART_NUMBER=ROCKET_LAUNCHER_0001"); $res->request($req); $res->header("Set-Cookie", "PART_NUMBER=RIDING_ROCKET_0023; path=/ammo"); $c->extract_cookies($res); $req = HTTP::Request->new(GET => "http://www.acme.com/ammo"); $c->add_cookie_header($req); ok($req->header("Cookie") =~ /^PART_NUMBER=RIDING_ROCKET_0023;\s*PART_NUMBER=ROCKET_LAUNCHER_0001/); print $c->as_string; undef($c); #------------------------------------------------------------------- # When there are no "Set-Cookie" header, then even responses # without any request URLs connected should be allowed. $c = HTTP::Cookies->new; $c->extract_cookies(HTTP::Response->new("200", "OK")); ok(count_cookies($c), 0); #------------------------------------------------------------------- # Then we test with the examples from RFC 2965. # # 5. EXAMPLES $c = HTTP::Cookies->new; # # 5.1 Example 1 # # Most detail of request and response headers has been omitted. Assume # the user agent has no stored cookies. # # 1. User Agent -> Server # # POST /acme/login HTTP/1.1 # [form data] # # User identifies self via a form. # # 2. Server -> User Agent # # HTTP/1.1 200 OK # Set-Cookie2: Customer="WILE_E_COYOTE"; Version="1"; Path="/acme" # # Cookie reflects user's identity. $cookie = interact($c, 'http://www.acme.com/acme/login', 'Customer="WILE_E_COYOTE"; Version="1"; Path="/acme"'); ok(!$cookie); # # 3. User Agent -> Server # # POST /acme/pickitem HTTP/1.1 # Cookie: $Version="1"; Customer="WILE_E_COYOTE"; $Path="/acme" # [form data] # # User selects an item for ``shopping basket.'' # # 4. Server -> User Agent # # HTTP/1.1 200 OK # Set-Cookie2: Part_Number="Rocket_Launcher_0001"; Version="1"; # Path="/acme" # # Shopping basket contains an item. $cookie = interact($c, 'http://www.acme.com/acme/pickitem', 'Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"'); ok($cookie =~ m(^\$Version="?1"?; Customer="?WILE_E_COYOTE"?; \$Path="/acme"$)); # # 5. User Agent -> Server # # POST /acme/shipping HTTP/1.1 # Cookie: $Version="1"; # Customer="WILE_E_COYOTE"; $Path="/acme"; # Part_Number="Rocket_Launcher_0001"; $Path="/acme" # [form data] # # User selects shipping method from form. # # 6. Server -> User Agent # # HTTP/1.1 200 OK # Set-Cookie2: Shipping="FedEx"; Version="1"; Path="/acme" # # New cookie reflects shipping method. $cookie = interact($c, "http://www.acme.com/acme/shipping", 'Shipping="FedEx"; Version="1"; Path="/acme"'); ok($cookie =~ /^\$Version="?1"?;/); ok($cookie =~ /Part_Number="?Rocket_Launcher_0001"?;\s*\$Path="\/acme"/); ok($cookie =~ /Customer="?WILE_E_COYOTE"?;\s*\$Path="\/acme"/); # # 7. User Agent -> Server # # POST /acme/process HTTP/1.1 # Cookie: $Version="1"; # Customer="WILE_E_COYOTE"; $Path="/acme"; # Part_Number="Rocket_Launcher_0001"; $Path="/acme"; # Shipping="FedEx"; $Path="/acme" # [form data] # # User chooses to process order. # # 8. Server -> User Agent # # HTTP/1.1 200 OK # # Transaction is complete. $cookie = interact($c, "http://www.acme.com/acme/process"); print "FINAL COOKIE: $cookie\n"; ok($cookie =~ /Shipping="?FedEx"?;\s*\$Path="\/acme"/); ok($cookie =~ /WILE_E_COYOTE/); # # The user agent makes a series of requests on the origin server, after # each of which it receives a new cookie. All the cookies have the same # Path attribute and (default) domain. Because the request URLs all have # /acme as a prefix, and that matches the Path attribute, each request # contains all the cookies received so far. print $c->as_string; # 5.2 Example 2 # # This example illustrates the effect of the Path attribute. All detail # of request and response headers has been omitted. Assume the user agent # has no stored cookies. $c = HTTP::Cookies->new; # Imagine the user agent has received, in response to earlier requests, # the response headers # # Set-Cookie2: Part_Number="Rocket_Launcher_0001"; Version="1"; # Path="/acme" # # and # # Set-Cookie2: Part_Number="Riding_Rocket_0023"; Version="1"; # Path="/acme/ammo" interact($c, "http://www.acme.com/acme/ammo/specific", 'Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"', 'Part_Number="Riding_Rocket_0023"; Version="1"; Path="/acme/ammo"'); # A subsequent request by the user agent to the (same) server for URLs of # the form /acme/ammo/... would include the following request header: # # Cookie: $Version="1"; # Part_Number="Riding_Rocket_0023"; $Path="/acme/ammo"; # Part_Number="Rocket_Launcher_0001"; $Path="/acme" # # Note that the NAME=VALUE pair for the cookie with the more specific Path # attribute, /acme/ammo, comes before the one with the less specific Path # attribute, /acme. Further note that the same cookie name appears more # than once. $cookie = interact($c, "http://www.acme.com/acme/ammo/..."); ok($cookie =~ /Riding_Rocket_0023.*Rocket_Launcher_0001/); # A subsequent request by the user agent to the (same) server for a URL of # the form /acme/parts/ would include the following request header: # # Cookie: $Version="1"; Part_Number="Rocket_Launcher_0001"; $Path="/acme" # # Here, the second cookie's Path attribute /acme/ammo is not a prefix of # the request URL, /acme/parts/, so the cookie does not get forwarded to # the server. $cookie = interact($c, "http://www.acme.com/acme/parts/"); ok($cookie =~ /Rocket_Launcher_0001/); ok($cookie !~ /Riding_Rocket_0023/); print $c->as_string; #----------------------------------------------------------------------- # Test rejection of Set-Cookie2 responses based on domain, path or port $c = HTTP::Cookies->new; # illegal domain (no embedded dots) $cookie = interact($c, "http://www.acme.com", 'foo=bar; domain=".com"'); ok(count_cookies($c), 0); # legal domain $cookie = interact($c, "http://www.acme.com", 'foo=bar; domain="acme.com"'); ok(count_cookies($c), 1); # illegal domain (host prefix "www.a" contains a dot) $cookie = interact($c, "http://www.a.acme.com", 'foo=bar; domain="acme.com"'); ok(count_cookies($c), 1); # legal domain $cookie = interact($c, "http://www.a.acme.com", 'foo=bar; domain=".a.acme.com"'); ok(count_cookies($c), 2); # can't use a IP-address as domain $cookie = interact($c, "http://125.125.125.125", 'foo=bar; domain="125.125.125"'); ok(count_cookies($c), 2); # illegal path (must be prefix of request path) $cookie = interact($c, "http://www.sol.no", 'foo=bar; domain=".sol.no"; path="/foo"'); ok(count_cookies($c), 2); # legal path $cookie = interact($c, "http://www.sol.no/foo/bar", 'foo=bar; domain=".sol.no"; path="/foo"'); ok(count_cookies($c), 3); # illegal port (request-port not in list) $cookie = interact($c, "http://www.sol.no", 'foo=bar; domain=".sol.no"; port="90,100"'); ok(count_cookies($c), 3); # legal port $cookie = interact($c, "http://www.sol.no", 'foo=bar; domain=".sol.no"; port="90,100, 80,8080"; max-age=100; Comment = "Just kidding! (\"|\\\\) "'); ok(count_cookies($c), 4); # port attribute without any value (current port) $cookie = interact($c, "http://www.sol.no", 'foo9=bar; domain=".sol.no"; port; max-age=100;'); ok(count_cookies($c), 5); # encoded path $cookie = interact($c, "http://www.sol.no/foo/", 'foo8=bar; path="/%66oo"'); ok(count_cookies($c), 6); my $file = "lwp-cookies-$$.txt"; $c->save($file); $old = $c->as_string; undef($c); $c = HTTP::Cookies->new; $c->load($file); unlink($file) || warn "Can't unlink $file: $!"; ok($old, $c->as_string); undef($c); # # Try some URL encodings of the PATHs # $c = HTTP::Cookies->new; interact($c, "http://www.acme.com/foo%2f%25/%40%40%0Anew%E5/%E5", 'foo = bar; version = 1'); print $c->as_string; $cookie = interact($c, "http://www.acme.com/foo%2f%25/@@%0anewå/æøå", "bar=baz; path=\"/foo/\"; version=1"); ok($cookie =~ /foo=bar/); ok($cookie =~ /^\$version=\"?1\"?/i); $cookie = interact($c, "http://www.acme.com/foo/%25/@@%0anewå/æøå"); ok(!$cookie); undef($c); # # Try to use the Netscape cookie file format for saving # $file = "cookies-$$.txt"; $c = HTTP::Cookies::Netscape->new(file => $file); interact($c, "http://www.acme.com/", "foo1=bar; max-age=100"); interact($c, "http://www.acme.com/", "foo2=bar; port=\"80\"; max-age=100; Discard; Version=1"); interact($c, "http://www.acme.com/", "foo3=bar; secure; Version=1"); $c->save; undef($c); $c = HTTP::Cookies::Netscape->new(file => $file); ok(count_cookies($c), 1); # 2 of them discarded on save ok($c->as_string =~ /foo1=bar/); undef($c); unlink($file); # # Some additional Netscape cookies test # $c = HTTP::Cookies->new; $req = HTTP::Request->new(POST => "http://foo.bar.acme.com/foo"); # Netscape allows a host part that contains dots $res = HTTP::Response->new(200, "OK"); $res->header(set_cookie => 'Customer=WILE_E_COYOTE; domain=.acme.com'); $res->request($req); $c->extract_cookies($res); # and that the domain is the same as the host without adding a leading # dot to the domain. Should not quote even if strange chars are used # in the cookie value. $res = HTTP::Response->new(200, "OK"); $res->header(set_cookie => 'PART_NUMBER=3,4; domain=foo.bar.acme.com'); $res->request($req); $c->extract_cookies($res); print $c->as_string; require URI; $req = HTTP::Request->new(POST => URI->new("http://foo.bar.acme.com/foo")); $c->add_cookie_header($req); #print $req->as_string; ok($req->header("Cookie") =~ /PART_NUMBER=3,4/); ok($req->header("Cookie") =~ /Customer=WILE_E_COYOTE/); # Test handling of local intranet hostnames without a dot $c->clear; print "---\n"; interact($c, "http://example/", "foo1=bar; PORT; Discard;"); $_=interact($c, "http://example/", 'foo2=bar; domain=".local"'); ok(/foo1=bar/); $_=interact($c, "http://example/", 'foo3=bar'); $_=interact($c, "http://example/"); print "Cookie: $_\n"; ok(/foo2=bar/); ok(count_cookies($c), 3); print $c->as_string; # Test for empty path # Broken web-server ORION/1.3.38 returns to the client response like # # Set-Cookie: JSESSIONID=ABCDERANDOM123; Path= # # e.g. with Path set to nothing. # In this case routine extract_cookies() must set cookie to / (root) print "---\n"; print "Test for empty path...\n"; $c = HTTP::Cookies->new; # clear it $req = HTTP::Request->new(GET => "http://www.ants.com/"); $res = HTTP::Response->new(200, "OK"); $res->request($req); $res->header("Set-Cookie" => "JSESSIONID=ABCDERANDOM123; Path="); print $res->as_string; $c->extract_cookies($res); #print $c->as_string; $req = HTTP::Request->new(GET => "http://www.ants.com/"); $c->add_cookie_header($req); #print $req->as_string; ok($req->header("Cookie"), "JSESSIONID=ABCDERANDOM123"); ok($req->header("Cookie2"), "\$Version=\"1\""); # missing path in the request URI $req = HTTP::Request->new(GET => URI->new("http://www.ants.com:8080")); $c->add_cookie_header($req); #print $req->as_string; ok($req->header("Cookie"), "JSESSIONID=ABCDERANDOM123"); ok($req->header("Cookie2"), "\$Version=\"1\""); # 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: ; 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; ok($c->as_string, <<'EOT'); 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 #------------------------------------------------------------------- # Test if temporary cookies are deleted properly with # $jar->clear_temporary_cookies() $req = HTTP::Request->new('GET', 'http://www.perlmeister.com/scripts'); $res = HTTP::Response->new(200, "OK"); $res->request($req); # Set session/perm cookies and mark their values as "session" vs. "perm" # to recognize them later $res->push_header("Set-Cookie" => qq(s1=session;Path=/scripts)); $res->push_header("Set-Cookie" => qq(p1=perm; Domain=.perlmeister.com;Path=/;expires=Fri, 02-Feb-$year_plus_one 23:24:20 GMT)); $res->push_header("Set-Cookie" => qq(p2=perm;Path=/;expires=Fri, 02-Feb-$year_plus_one 23:24:20 GMT)); $res->push_header("Set-Cookie" => qq(s2=session;Path=/scripts;Domain=.perlmeister.com)); $res->push_header("Set-Cookie2" => qq(s3=session;Version=1;Discard;Path="/")); $c = HTTP::Cookies->new; # clear jar $c->extract_cookies($res); # How many session/permanent cookies do we have? my %counter = ("session_after" => 0); $c->scan( sub { $counter{"${_[2]}_before"}++ } ); $c->clear_temporary_cookies(); # How many now? $c->scan( sub { $counter{"${_[2]}_after"}++ } ); ok($counter{"perm_after"}, $counter{"perm_before"}); # a permanent cookie got lost accidently ok($counter{"session_after"}, 0); # a session cookie hasn't been cleared ok($counter{"session_before"}, 3); # we didn't have session cookies in the first place #print $c->as_string; # Test handling of 'secure ' attribute for classic cookies $c = HTTP::Cookies->new; $req = HTTP::Request->new(GET => "https://1.1.1.1/"); $req->header("Host", "www.acme.com:80"); $res = HTTP::Response->new(200, "OK"); $res->request($req); $res->header("Set-Cookie" => "CUSTOMER=WILE_E_COYOTE ; secure ; path=/"); #print $res->as_string; $c->extract_cookies($res); $req = HTTP::Request->new(GET => "http://www.acme.com/"); $c->add_cookie_header($req); ok(!$req->header("Cookie")); $req->uri->scheme("https"); $c->add_cookie_header($req); ok($req->header("Cookie"), "CUSTOMER=WILE_E_COYOTE"); #print $req->as_string; #print $c->as_string; $req = HTTP::Request->new(GET => "ftp://ftp.activestate.com/"); $c->add_cookie_header($req); ok(!$req->header("Cookie")); $req = HTTP::Request->new(GET => "file:/etc/motd"); $c->add_cookie_header($req); ok(!$req->header("Cookie")); $req = HTTP::Request->new(GET => "mailto:gisle\@aas.no"); $c->add_cookie_header($req); ok(!$req->header("Cookie")); # Test cookie called 'exipres' $c = HTTP::Cookies->new; $req = HTTP::Request->new("GET" => "http://example.com"); $res = HTTP::Response->new(200, "OK"); $res->request($req); $res->header("Set-Cookie" => "Expires=10101"); $c->extract_cookies($res); #print $c->as_string; ok($c->as_string, <<'EOT'); Set-Cookie3: Expires=10101; path="/"; domain=example.com; discard; version=0 EOT # Test empty cookie header [RT#29401] $c = HTTP::Cookies->new; $res->header("Set-Cookie" => ["CUSTOMER=WILE_E_COYOTE; path=/;", ""]); #print $res->as_string; $c->extract_cookies($res); #print $c->as_string; ok($c->as_string, <<'EOT'); Set-Cookie3: CUSTOMER=WILE_E_COYOTE; path="/"; domain=example.com; path_spec; discard; version=0 EOT # Test empty cookie part [RT#38480] $c = HTTP::Cookies->new; $res->header("Set-Cookie" => "CUSTOMER=WILE_E_COYOTE;;path=/;"); #print $res->as_string; $c->extract_cookies($res); #print $c->as_string; ok($c->as_string, <<'EOT'); Set-Cookie3: CUSTOMER=WILE_E_COYOTE; path="/"; domain=example.com; path_spec; discard; version=0 EOT # Test Set-Cookie with version set $c = HTTP::Cookies->new; $res->header("Set-Cookie" => "foo=\"bar\";version=1"); #print $res->as_string; $c->extract_cookies($res); #print $c->as_string; $req = HTTP::Request->new(GET => "http://www.example.com/foo"); $c->add_cookie_header($req); #print $req->as_string; ok($req->header("Cookie"), "foo=\"bar\""); # Test cookies that expire far into the future [RT#50147] $c = HTTP::Cookies->new; $res->header("Set-Cookie", "PREF=ID=cee18f7c4e977184:TM=1254583090:LM=1254583090:S=Pdb0-hy9PxrNj4LL; expires=Mon, 03-Oct-2211 15:18:10 GMT; path=/; domain=.example.com"); $res->push_header("Set-Cookie", "expired1=1; expires=Mon, 03-Oct-2001 15:18:10 GMT; path=/; domain=.example.com"); $res->push_header("Set-Cookie", "expired2=1; expires=Fri Jan 1 00:00:00 GMT 1970; path=/; domain=.example.com"); $res->push_header("Set-Cookie", "expired3=1; expires=Fri Jan 1 00:00:01 GMT 1970; path=/; domain=.example.com"); $res->push_header("Set-Cookie", "expired4=1; expires=Thu Dec 31 23:59:59 GMT 1969; path=/; domain=.example.com"); $res->push_header("Set-Cookie", "expired5=1; expires=Fri Feb 2 00:00:00 GMT 1950; path=/; domain=.example.com"); $c->extract_cookies($res); #print $res->as_string; #print "---\n"; #print $c->as_string; $req = HTTP::Request->new(GET => "http://www.example.com/foo"); $c->add_cookie_header($req); #print $req->as_string; ok($req->header("Cookie"), "PREF=ID=cee18f7c4e977184:TM=1254583090:LM=1254583090:S=Pdb0-hy9PxrNj4LL"); $c->clear_temporary_cookies; $req = HTTP::Request->new(GET => "http://www.example.com/foo"); $c->add_cookie_header($req); #print $req->as_string; ok($req->header("Cookie"), "PREF=ID=cee18f7c4e977184:TM=1254583090:LM=1254583090:S=Pdb0-hy9PxrNj4LL"); # Test merging of cookies $c = HTTP::Cookies->new; $res->header("Set-Cookie", "foo=1; path=/"); $c->extract_cookies($res); $req = HTTP::Request->new(GET => "http://www.example.com/foo"); $req->header("Cookie", "x=bcd"); $c->add_cookie_header($req); ok($req->header("Cookie"), "x=bcd; foo=1"); $c->add_cookie_header($req); ok($req->header("Cookie"), "x=bcd; foo=1; foo=1"); #print $req->as_string; #------------------------------------------------------------------- sub interact { my $c = shift; my $url = shift; my $req = HTTP::Request->new(POST => $url); $c->add_cookie_header($req); my $cookie = $req->header("Cookie"); my $res = HTTP::Response->new(200, "OK"); $res->request($req); for (@_) { $res->push_header("Set-Cookie2" => $_) } $c->extract_cookies($res); return $cookie; } sub count_cookies { my $c = shift; my $no = 0; $c->scan(sub { $no++ }); $no; } HTTP-Cookies-6.00/lib/HTTP/000755 000765 000024 00000000000 11532553146 015410 5ustar00gislestaff000000 000000 HTTP-Cookies-6.00/lib/HTTP/Cookies/000755 000765 000024 00000000000 11532553146 017004 5ustar00gislestaff000000 000000 HTTP-Cookies-6.00/lib/HTTP/Cookies.pm000644 000765 000024 00000047435 11532553001 017345 0ustar00gislestaff000000 000000 package HTTP::Cookies; use strict; use HTTP::Date qw(str2time parse_date time2str); use HTTP::Headers::Util qw(_split_header_words join_header_words); use vars qw($VERSION $EPOCH_OFFSET); $VERSION = "6.00"; # Legacy: because "use "HTTP::Cookies" used be the ONLY way # to load the class HTTP::Cookies::Netscape. require HTTP::Cookies::Netscape; $EPOCH_OFFSET = 0; # difference from Unix epoch if ($^O eq "MacOS") { require Time::Local; $EPOCH_OFFSET = Time::Local::timelocal(0,0,0,1,0,70); } # A HTTP::Cookies object is a hash. The main attribute is the # COOKIES 3 level hash: $self->{COOKIES}{$domain}{$path}{$key}. sub new { my $class = shift; my $self = bless { COOKIES => {}, }, $class; my %cnf = @_; for (keys %cnf) { $self->{lc($_)} = $cnf{$_}; } $self->load; $self; } sub add_cookie_header { my $self = shift; my $request = shift || return; my $url = $request->uri; my $scheme = $url->scheme; unless ($scheme =~ /^https?\z/) { return; } my $domain = _host($request, $url); $domain = "$domain.local" unless $domain =~ /\./; my $secure_request = ($scheme eq "https"); my $req_path = _url_path($url); my $req_port = $url->port; my $now = time(); _normalize_path($req_path) if $req_path =~ /%/; my @cval; # cookie values for the "Cookie" header my $set_ver; my $netscape_only = 0; # An exact domain match applies to any cookie while ($domain =~ /\./) { # Checking $domain for cookies" my $cookies = $self->{COOKIES}{$domain}; next unless $cookies; if ($self->{delayload} && defined($cookies->{'//+delayload'})) { my $cookie_data = $cookies->{'//+delayload'}{'cookie'}; delete $self->{COOKIES}{$domain}; $self->load_cookie($cookie_data->[1]); $cookies = $self->{COOKIES}{$domain}; next unless $cookies; # should not really happen } # Want to add cookies corresponding to the most specific paths # first (i.e. longest path first) my $path; for $path (sort {length($b) <=> length($a) } keys %$cookies) { if (index($req_path, $path) != 0) { next; } my($key,$array); while (($key,$array) = each %{$cookies->{$path}}) { my($version,$val,$port,$path_spec,$secure,$expires) = @$array; if ($secure && !$secure_request) { next; } if ($expires && $expires < $now) { next; } if ($port) { my $found; if ($port =~ s/^_//) { # The corresponding Set-Cookie attribute was empty $found++ if $port eq $req_port; $port = ""; } else { my $p; for $p (split(/,/, $port)) { $found++, last if $p eq $req_port; } } unless ($found) { next; } } if ($version > 0 && $netscape_only) { next; } # set version number of cookie header. # XXX: What should it be if multiple matching # Set-Cookie headers have different versions themselves if (!$set_ver++) { if ($version >= 1) { push(@cval, "\$Version=$version"); } elsif (!$self->{hide_cookie2}) { $request->header(Cookie2 => '$Version="1"'); } } # do we need to quote the value if ($val =~ /\W/ && $version) { $val =~ s/([\\\"])/\\$1/g; $val = qq("$val"); } # and finally remember this cookie push(@cval, "$key=$val"); if ($version >= 1) { push(@cval, qq(\$Path="$path")) if $path_spec; push(@cval, qq(\$Domain="$domain")) if $domain =~ /^\./; if (defined $port) { my $p = '$Port'; $p .= qq(="$port") if length $port; push(@cval, $p); } } } } } continue { # Try with a more general domain, alternately stripping # leading name components and leading dots. When this # results in a domain with no leading dot, it is for # Netscape cookie compatibility only: # # a.b.c.net Any cookie # .b.c.net Any cookie # b.c.net Netscape cookie only # .c.net Any cookie if ($domain =~ s/^\.+//) { $netscape_only = 1; } else { $domain =~ s/[^.]*//; $netscape_only = 0; } } if (@cval) { if (my $old = $request->header("Cookie")) { unshift(@cval, $old); } $request->header(Cookie => join("; ", @cval)); } $request; } sub extract_cookies { my $self = shift; my $response = shift || return; my @set = _split_header_words($response->_header("Set-Cookie2")); my @ns_set = $response->_header("Set-Cookie"); return $response unless @set || @ns_set; # quick exit my $request = $response->request; my $url = $request->uri; my $req_host = _host($request, $url); $req_host = "$req_host.local" unless $req_host =~ /\./; my $req_port = $url->port; my $req_path = _url_path($url); _normalize_path($req_path) if $req_path =~ /%/; if (@ns_set) { # The old Netscape cookie format for Set-Cookie # http://curl.haxx.se/rfc/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(); # 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 (@ns_set) { $set =~ s/^\s+//; my @cur; my $param; my $expires; my $first_param = 1; for $param (split(/;\s*/, $set)) { next unless length($param); my($k,$v) = split(/\s*=\s*/, $param, 2); if (defined $v) { $v =~ s/\s+$//; #print "$k => $v\n"; } else { $k =~ s/\s+$//; #print "$k => undef"; } if (!$first_param && lc($k) eq "expires") { my $etime = str2time($v); if (defined $etime) { push(@cur, "Max-Age" => $etime - $now); $expires++; } else { # parse_date can deal with years outside the range of time_t, my($year, $mon, $day, $hour, $min, $sec, $tz) = parse_date($v); if ($year) { my $thisyear = (gmtime)[5] + 1900; if ($year < $thisyear) { push(@cur, "Max-Age" => -1); # any negative value will do $expires++; } elsif ($year >= $thisyear + 10) { # the date is at least 10 years into the future, just replace # it with something approximate push(@cur, "Max-Age" => 10 * 365 * 24 * 60 * 60); $expires++; } } } } elsif (!$first_param && lc($k) =~ /^(?:version|discard|ns-cookie)/) { # ignore } else { push(@cur, $k => $v); } $first_param = 0; } next unless @cur; 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); } } SET_COOKIE: for my $set (@set) { next unless @$set >= 2; my $key = shift @$set; my $val = shift @$set; my %hash; while (@$set) { my $k = shift @$set; my $v = shift @$set; my $lc = lc($k); # don't loose case distinction for unknown fields $k = $lc if $lc =~ /^(?:discard|domain|max-age| path|port|secure|version)$/x; if ($k eq "discard" || $k eq "secure") { $v = 1 unless defined $v; } next if exists $hash{$k}; # only first value is significant $hash{$k} = $v; }; my %orig_hash = %hash; my $version = delete $hash{version}; $version = 1 unless defined($version); 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}; $domain = lc($domain) if defined $domain; if (defined($domain) && $domain ne $req_host && $domain ne ".$req_host") { if ($domain !~ /\./ && $domain ne "local") { next SET_COOKIE; } $domain = ".$domain" unless $domain =~ /^\./; if ($domain =~ /\.\d+$/) { next SET_COOKIE; } my $len = length($domain); unless (substr($req_host, -$len) eq $domain) { next SET_COOKIE; } my $hostpre = substr($req_host, 0, length($req_host) - $len); if ($hostpre =~ /\./ && !$ns_cookie) { next SET_COOKIE; } } else { $domain = $req_host; } my $path = delete $hash{path}; my $path_spec; if (defined $path && $path ne '') { $path_spec++; _normalize_path($path) if $path =~ /%/; if (!$ns_cookie && substr($req_path, 0, length($path)) ne $path) { next SET_COOKIE; } } else { $path = $req_path; $path =~ s,/[^/]*$,,; $path = "/" unless length($path); } my $port; if (exists $hash{port}) { $port = delete $hash{port}; if (defined $port) { $port =~ s/\s+//g; my $found; for my $p (split(/,/, $port)) { unless ($p =~ /^\d+$/) { next SET_COOKIE; } $found++ if $p eq $req_port; } unless ($found) { next SET_COOKIE; } } else { $port = "_$req_port"; } } $self->set_cookie($version,$key,$val,$path,$domain,$port,$path_spec,$secure,$maxage,$discard, \%hash) if $self->set_cookie_ok(\%orig_hash); } $response; } sub set_cookie_ok { 1; } sub set_cookie { my $self = shift; my($version, $key, $val, $path, $domain, $port, $path_spec, $secure, $maxage, $discard, $rest) = @_; # path and key can not be empty (key can't start with '$') return $self if !defined($path) || $path !~ m,^/, || !defined($key) || $key =~ m,^\$,; # ensure legal port if (defined $port) { return $self unless $port =~ /^_?\d+(?:,\d+)*$/; } my $expires; if (defined $maxage) { if ($maxage <= 0) { delete $self->{COOKIES}{$domain}{$path}{$key}; return $self; } $expires = time() + $maxage; } $version = 0 unless defined $version; my @array = ($version, $val,$port, $path_spec, $secure, $expires, $discard); push(@array, {%$rest}) if defined($rest) && %$rest; # trim off undefined values at end pop(@array) while !defined $array[-1]; $self->{COOKIES}{$domain}{$path}{$key} = \@array; $self; } sub save { my $self = shift; my $file = shift || $self->{'file'} || return; local(*FILE); open(FILE, ">$file") or die "Can't open $file: $!"; print FILE "#LWP-Cookies-1.0\n"; print FILE $self->as_string(!$self->{ignore_discard}); close(FILE); 1; } sub load { my $self = shift; my $file = shift || $self->{'file'} || return; local(*FILE, $_); local $/ = "\n"; # make sure we got standard record separator open(FILE, $file) or return; my $magic = ; unless ($magic =~ /^\#LWP-Cookies-(\d+\.\d+)/) { warn "$file does not seem to contain cookies"; return; } while () { next unless s/^Set-Cookie3:\s*//; chomp; my $cookie; for $cookie (_split_header_words($_)) { my($key,$val) = splice(@$cookie, 0, 2); my %hash; while (@$cookie) { my $k = shift @$cookie; my $v = shift @$cookie; $hash{$k} = $v; } my $version = delete $hash{version}; my $path = delete $hash{path}; my $domain = delete $hash{domain}; my $port = delete $hash{port}; my $expires = str2time(delete $hash{expires}); my $path_spec = exists $hash{path_spec}; delete $hash{path_spec}; my $secure = exists $hash{secure}; delete $hash{secure}; my $discard = exists $hash{discard}; delete $hash{discard}; my @array = ($version,$val,$port, $path_spec,$secure,$expires,$discard); push(@array, \%hash) if %hash; $self->{COOKIES}{$domain}{$path}{$key} = \@array; } } close(FILE); 1; } sub revert { my $self = shift; $self->clear->load; $self; } sub clear { my $self = shift; if (@_ == 0) { $self->{COOKIES} = {}; } elsif (@_ == 1) { delete $self->{COOKIES}{$_[0]}; } elsif (@_ == 2) { delete $self->{COOKIES}{$_[0]}{$_[1]}; } elsif (@_ == 3) { delete $self->{COOKIES}{$_[0]}{$_[1]}{$_[2]}; } else { require Carp; Carp::carp('Usage: $c->clear([domain [,path [,key]]])'); } $self; } sub clear_temporary_cookies { my($self) = @_; $self->scan(sub { if($_[9] or # "Discard" flag set not $_[8]) { # No expire field? $_[8] = -1; # Set the expire/max_age field $self->set_cookie(@_); # Clear the cookie } }); } sub DESTROY { my $self = shift; local($., $@, $!, $^E, $?); $self->save if $self->{'autosave'}; } sub scan { my($self, $cb) = @_; my($domain,$path,$key); for $domain (sort keys %{$self->{COOKIES}}) { for $path (sort keys %{$self->{COOKIES}{$domain}}) { for $key (sort keys %{$self->{COOKIES}{$domain}{$path}}) { my($version,$val,$port,$path_spec, $secure,$expires,$discard,$rest) = @{$self->{COOKIES}{$domain}{$path}{$key}}; $rest = {} unless defined($rest); &$cb($version,$key,$val,$path,$domain,$port, $path_spec,$secure,$expires,$discard,$rest); } } } } sub as_string { my($self, $skip_discard) = @_; my @res; $self->scan(sub { my($version,$key,$val,$path,$domain,$port, $path_spec,$secure,$expires,$discard,$rest) = @_; return if $discard && $skip_discard; my @h = ($key, $val); push(@h, "path", $path); push(@h, "domain" => $domain); push(@h, "port" => $port) if defined $port; push(@h, "path_spec" => undef) if $path_spec; push(@h, "secure" => undef) if $secure; push(@h, "expires" => HTTP::Date::time2isoz($expires)) if $expires; push(@h, "discard" => undef) if $discard; my $k; for $k (sort keys %$rest) { push(@h, $k, $rest->{$k}); } push(@h, "version" => $version); push(@res, "Set-Cookie3: " . join_header_words(\@h)); }); join("\n", @res, ""); } sub _host { my($request, $url) = @_; if (my $h = $request->header("Host")) { $h =~ s/:\d+$//; # might have a port as well return lc($h); } return lc($url->host); } sub _url_path { my $url = shift; my $path; if($url->can('epath')) { $path = $url->epath; # URI::URL method } else { $path = $url->path; # URI::_generic method } $path = "/" unless length $path; $path; } sub _normalize_path # so that plain string compare can be used { my $x; $_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/ $x = uc($1); $x eq "2F" || $x eq "25" ? "%$x" : pack("C", hex($x)); /eg; $_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg; } 1; __END__ =head1 NAME HTTP::Cookies - HTTP cookie jars =head1 SYNOPSIS use HTTP::Cookies; $cookie_jar = HTTP::Cookies->new( file => "$ENV{'HOME'}/lwp_cookies.dat", autosave => 1, ); use LWP; my $browser = LWP::UserAgent->new; $browser->cookie_jar($cookie_jar); Or for an empty and temporary cookie jar: use LWP; my $browser = LWP::UserAgent->new; $browser->cookie_jar( {} ); =head1 DESCRIPTION This class is for objects that represent a "cookie jar" -- that is, a database of all the HTTP cookies that a given LWP::UserAgent object knows about. Cookies are a general mechanism which server side connections can use to both store and retrieve information on the client side of the connection. For more information about cookies refer to and . This module also implements the new style cookies described in I. The two variants of cookies are supposed to be able to coexist happily. Instances of the class I are able to store a collection of Set-Cookie2: and Set-Cookie: headers and are able to use this information to initialize Cookie-headers in I objects. The state of a I object can be saved in and restored from files. =head1 METHODS The following methods are provided: =over 4 =item $cookie_jar = HTTP::Cookies->new The constructor takes hash style parameters. The following parameters are recognized: file: name of the file to restore cookies from and save cookies to autosave: save during destruction (bool) ignore_discard: save even cookies that are requested to be discarded (bool) hide_cookie2: do not add Cookie2 header to requests Future parameters might include (not yet implemented): max_cookies 300 max_cookies_per_domain 20 max_cookie_size 4096 no_cookies list of domain names that we never return cookies to =item $cookie_jar->add_cookie_header( $request ) The add_cookie_header() method will set the appropriate Cookie:-header for the I object given as argument. The $request must have a valid url attribute before this method is called. =item $cookie_jar->extract_cookies( $response ) The extract_cookies() method will look for Set-Cookie: and Set-Cookie2: headers in the I object passed as argument. Any of these headers that are found are used to update the state of the $cookie_jar. =item $cookie_jar->set_cookie( $version, $key, $val, $path, $domain, $port, $path_spec, $secure, $maxage, $discard, \%rest ) The set_cookie() method updates the state of the $cookie_jar. The $key, $val, $domain, $port and $path arguments are strings. The $path_spec, $secure, $discard arguments are boolean values. The $maxage value is a number indicating number of seconds that this cookie will live. A value <= 0 will delete this cookie. %rest defines various other attributes like "Comment" and "CommentURL". =item $cookie_jar->save =item $cookie_jar->save( $file ) This method file saves the state of the $cookie_jar to a file. The state can then be restored later using the load() method. If a filename is not specified we will use the name specified during construction. If the attribute I is set, then we will even save cookies that are marked to be discarded. The default is to save a sequence of "Set-Cookie3" lines. "Set-Cookie3" is a proprietary LWP format, not known to be compatible with any browser. The I sub-class can be used to save in a format compatible with Netscape. =item $cookie_jar->load =item $cookie_jar->load( $file ) This method reads the cookies from the file and adds them to the $cookie_jar. The file must be in the format written by the save() method. =item $cookie_jar->revert This method empties the $cookie_jar and re-loads the $cookie_jar from the last save file. =item $cookie_jar->clear =item $cookie_jar->clear( $domain ) =item $cookie_jar->clear( $domain, $path ) =item $cookie_jar->clear( $domain, $path, $key ) Invoking this method without arguments will empty the whole $cookie_jar. If given a single argument only cookies belonging to that domain will be removed. If given two arguments, cookies belonging to the specified path within that domain are removed. If given three arguments, then the cookie with the specified key, path and domain is removed. =item $cookie_jar->clear_temporary_cookies Discard all temporary cookies. Scans for all cookies in the jar with either no expire field or a true C flag. To be called when the user agent shuts down according to RFC 2965. =item $cookie_jar->scan( \&callback ) The argument is a subroutine that will be invoked for each cookie stored in the $cookie_jar. The subroutine will be invoked with the following arguments: 0 version 1 key 2 val 3 path 4 domain 5 port 6 path_spec 7 secure 8 expires 9 discard 10 hash =item $cookie_jar->as_string =item $cookie_jar->as_string( $skip_discardables ) The as_string() method will return the state of the $cookie_jar represented as a sequence of "Set-Cookie3" header lines separated by "\n". If $skip_discardables is TRUE, it will not return lines for cookies with the I attribute. =back =head1 SEE ALSO L, L =head1 COPYRIGHT Copyright 1997-2002 Gisle Aas This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. HTTP-Cookies-6.00/lib/HTTP/Cookies/Microsoft.pm000644 000765 000024 00000020024 11532553001 021273 0ustar00gislestaff000000 000000 package HTTP::Cookies::Microsoft; use strict; use vars qw(@ISA $VERSION); $VERSION = "6.00"; require HTTP::Cookies; @ISA=qw(HTTP::Cookies); sub load_cookies_from_file { my ($file) = @_; my @cookies; my ($key, $value, $domain_path, $flags, $lo_expire, $hi_expire); my ($lo_create, $hi_create, $sep); open(COOKIES, $file) || return; while ($key = ) { chomp($key); chomp($value = ); chomp($domain_path= ); chomp($flags = ); # 0x0001 bit is for secure chomp($lo_expire = ); chomp($hi_expire = ); chomp($lo_create = ); chomp($hi_create = ); chomp($sep = ); if (!defined($key) || !defined($value) || !defined($domain_path) || !defined($flags) || !defined($hi_expire) || !defined($lo_expire) || !defined($hi_create) || !defined($lo_create) || !defined($sep) || ($sep ne '*')) { last; } if ($domain_path =~ /^([^\/]+)(\/.*)$/) { my $domain = $1; my $path = $2; push(@cookies, {KEY => $key, VALUE => $value, DOMAIN => $domain, PATH => $path, FLAGS =>$flags, HIXP =>$hi_expire, LOXP => $lo_expire, HICREATE => $hi_create, LOCREATE => $lo_create}); } } return \@cookies; } sub get_user_name { use Win32; use locale; my $user = lc(Win32::LoginName()); return $user; } # MSIE stores create and expire times as Win32 FILETIME, # which is 64 bits of 100 nanosecond intervals since Jan 01 1601 # # But Cookies code expects time in 32-bit value expressed # in seconds since Jan 01 1970 # sub epoch_time_offset_from_win32_filetime { my ($high, $low) = @_; #-------------------------------------------------------- # USEFUL CONSTANT #-------------------------------------------------------- # 0x019db1de 0xd53e8000 is 1970 Jan 01 00:00:00 in Win32 FILETIME # # 100 nanosecond intervals == 0.1 microsecond intervals my $filetime_low32_1970 = 0xd53e8000; my $filetime_high32_1970 = 0x019db1de; #------------------------------------ # ALGORITHM #------------------------------------ # To go from 100 nanosecond intervals to seconds since 00:00 Jan 01 1970: # # 1. Adjust 100 nanosecond intervals to Jan 01 1970 base # 2. Divide by 10 to get to microseconds (1/millionth second) # 3. Divide by 1000000 (10 ^ 6) to get to seconds # # We can combine Step 2 & 3 into one divide. # # After much trial and error, I came up with the following code which # avoids using Math::BigInt or floating pt, but still gives correct answers # If the filetime is before the epoch, return 0 if (($high < $filetime_high32_1970) || (($high == $filetime_high32_1970) && ($low < $filetime_low32_1970))) { return 0; } # Can't multiply by 0x100000000, (1 << 32), # without Perl issuing an integer overflow warning # # So use two multiplies by 0x10000 instead of one multiply by 0x100000000 # # The result is the same. # my $date1970 = (($filetime_high32_1970 * 0x10000) * 0x10000) + $filetime_low32_1970; my $time = (($high * 0x10000) * 0x10000) + $low; $time -= $date1970; $time /= 10000000; return $time; } sub load_cookie { my($self, $file) = @_; my $now = time() - $HTTP::Cookies::EPOCH_OFFSET; my $cookie_data; if (-f $file) { # open the cookie file and get the data $cookie_data = load_cookies_from_file($file); foreach my $cookie (@{$cookie_data}) { my $secure = ($cookie->{FLAGS} & 1) != 0; my $expires = epoch_time_offset_from_win32_filetime($cookie->{HIXP}, $cookie->{LOXP}); $self->set_cookie(undef, $cookie->{KEY}, $cookie->{VALUE}, $cookie->{PATH}, $cookie->{DOMAIN}, undef, 0, $secure, $expires-$now, 0); } } } sub load { my($self, $cookie_index) = @_; my $now = time() - $HTTP::Cookies::EPOCH_OFFSET; my $cookie_dir = ''; my $delay_load = (defined($self->{'delayload'}) && $self->{'delayload'}); my $user_name = get_user_name(); my $data; $cookie_index ||= $self->{'file'} || return; if ($cookie_index =~ /[\\\/][^\\\/]+$/) { $cookie_dir = $` . "\\"; } local(*INDEX, $_); open(INDEX, $cookie_index) || return; binmode(INDEX); if (256 != read(INDEX, $data, 256)) { warn "$cookie_index file is not large enough"; close(INDEX); return; } # Cookies' index.dat file starts with 32 bytes of signature # followed by an offset to the first record, stored as a little-endian DWORD my ($sig, $size) = unpack('a32 V', $data); if (($sig !~ /^Client UrlCache MMF Ver 5\.2/) || # check that sig is valid (only tested in IE6.0) (0x4000 != $size)) { warn "$cookie_index ['$sig' $size] does not seem to contain cookies"; close(INDEX); return; } if (0 == seek(INDEX, $size, 0)) # move the file ptr to start of the first record { close(INDEX); return; } # Cookies are usually stored in 'URL ' records in two contiguous 0x80 byte sectors (256 bytes) # so read in two 0x80 byte sectors and adjust if not a Cookie. while (256 == read(INDEX, $data, 256)) { # each record starts with a 4-byte signature # and a count (little-endian DWORD) of 0x80 byte sectors for the record ($sig, $size) = unpack('a4 V', $data); # Cookies are found in 'URL ' records if ('URL ' ne $sig) { # skip over uninteresting record: I've seen 'HASH' and 'LEAK' records if (($sig eq 'HASH') || ($sig eq 'LEAK')) { # '-2' takes into account the two 0x80 byte sectors we've just read in if (($size > 0) && ($size != 2)) { if (0 == seek(INDEX, ($size-2)*0x80, 1)) { # Seek failed. Something's wrong. Gonna stop. last; } } } next; } #$REMOVE Need to check if URL records in Cookies' index.dat will # ever use more than two 0x80 byte sectors if ($size > 2) { my $more_data = ($size-2)*0x80; if ($more_data != read(INDEX, $data, $more_data, 256)) { last; } } (my $user_name2 = $user_name) =~ s/ /_/g; if ($data =~ /Cookie\:\Q$user_name\E\@([\x21-\xFF]+).*?((?:\Q$user_name\E|\Q$user_name2\E)\@[\x21-\xFF]+\.txt)/) { my $cookie_file = $cookie_dir . $2; # form full pathname if (!$delay_load) { $self->load_cookie($cookie_file); } else { my $domain = $1; # grab only the domain name, drop everything from the first dir sep on if ($domain =~ m{[\\/]}) { $domain = $`; } # set the delayload cookie for this domain with # the cookie_file as cookie for later-loading info $self->set_cookie(undef, 'cookie', $cookie_file, '//+delayload', $domain, undef, 0, 0, $now+86400, 0); } } } close(INDEX); 1; } 1; __END__ =head1 NAME HTTP::Cookies::Microsoft - access to Microsoft cookies files =head1 SYNOPSIS use LWP; use HTTP::Cookies::Microsoft; use Win32::TieRegistry(Delimiter => "/"); my $cookies_dir = $Registry-> {"CUser/Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders/Cookies"}; $cookie_jar = HTTP::Cookies::Microsoft->new( file => "$cookies_dir\\index.dat", 'delayload' => 1, ); my $browser = LWP::UserAgent->new; $browser->cookie_jar( $cookie_jar ); =head1 DESCRIPTION This is a subclass of C which loads Microsoft Internet Explorer 5.x and 6.x for Windows (MSIE) cookie files. See the documentation for L. =head1 METHODS The following methods are provided: =over 4 =item $cookie_jar = HTTP::Cookies::Microsoft->new; The constructor takes hash style parameters. In addition to the regular HTTP::Cookies parameters, HTTP::Cookies::Microsoft recognizes the following: delayload: delay loading of cookie data until a request is actually made. This results in faster runtime unless you use most of the cookies since only the domain's cookie data is loaded on demand. =back =head1 CAVEATS Please note that the code DOESN'T support saving to the MSIE cookie file format. =head1 AUTHOR Johnny Lee =head1 COPYRIGHT Copyright 2002 Johnny Lee This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut HTTP-Cookies-6.00/lib/HTTP/Cookies/Netscape.pm000644 000765 000024 00000005471 11532553001 021101 0ustar00gislestaff000000 000000 package HTTP::Cookies::Netscape; use strict; use vars qw(@ISA $VERSION); $VERSION = "6.00"; require HTTP::Cookies; @ISA=qw(HTTP::Cookies); sub load { my($self, $file) = @_; $file ||= $self->{'file'} || return; local(*FILE, $_); local $/ = "\n"; # make sure we got standard record separator my @cookies; open(FILE, $file) || return; my $magic = ; unless ($magic =~ /^\#(?: Netscape)? HTTP Cookie File/) { warn "$file does not look like a netscape cookies file" if $^W; close(FILE); return; } my $now = time() - $HTTP::Cookies::EPOCH_OFFSET; while () { next if /^\s*\#/; next if /^\s*$/; tr/\n\r//d; my($domain,$bool1,$path,$secure, $expires,$key,$val) = split(/\t/, $_); $secure = ($secure eq "TRUE"); $self->set_cookie(undef,$key,$val,$path,$domain,undef, 0,$secure,$expires-$now, 0); } close(FILE); 1; } sub save { my($self, $file) = @_; $file ||= $self->{'file'} || return; local(*FILE, $_); open(FILE, ">$file") || return; # Use old, now broken link to the old cookie spec just in case something # else (not us!) requires the comment block exactly this way. print FILE <scan(sub { my($version,$key,$val,$path,$domain,$port, $path_spec,$secure,$expires,$discard,$rest) = @_; return if $discard && !$self->{ignore_discard}; $expires = $expires ? $expires - $HTTP::Cookies::EPOCH_OFFSET : 0; return if $now > $expires; $secure = $secure ? "TRUE" : "FALSE"; my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE"; print FILE join("\t", $domain, $bool, $path, $secure, $expires, $key, $val), "\n"; }); close(FILE); 1; } 1; __END__ =head1 NAME HTTP::Cookies::Netscape - access to Netscape cookies files =head1 SYNOPSIS use LWP; use HTTP::Cookies::Netscape; $cookie_jar = HTTP::Cookies::Netscape->new( file => "c:/program files/netscape/users/ZombieCharity/cookies.txt", ); my $browser = LWP::UserAgent->new; $browser->cookie_jar( $cookie_jar ); =head1 DESCRIPTION This is a subclass of C that reads (and optionally writes) Netscape/Mozilla cookie files. See the documentation for L. =head1 CAVEATS Please note that the Netscape/Mozilla cookie file format can't store all the information available in the Set-Cookie2 headers, so you will probably lose some information if you save in this format. At time of writing, this module seems to work fine with Mozilla Phoenix/Firebird. =head1 SEE ALSO L =head1 COPYRIGHT Copyright 2002-2003 Gisle Aas This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut