1#!perl -w 2 3use Test; 4plan tests => 81; 5 6use HTTP::Cookies; 7use HTTP::Request; 8use HTTP::Response; 9 10#------------------------------------------------------------------- 11# First we check that it works for the original example at 12# http://curl.haxx.se/rfc/cookie_spec.html 13 14# Client requests a document, and receives in the response: 15# 16# Set-Cookie: CUSTOMER=WILE_E_COYOTE; path=/; expires=Wednesday, 09-Nov-99 23:12:40 GMT 17# 18# When client requests a URL in path "/" on this server, it sends: 19# 20# Cookie: CUSTOMER=WILE_E_COYOTE 21# 22# Client requests a document, and receives in the response: 23# 24# Set-Cookie: PART_NUMBER=ROCKET_LAUNCHER_0001; path=/ 25# 26# When client requests a URL in path "/" on this server, it sends: 27# 28# Cookie: CUSTOMER=WILE_E_COYOTE; PART_NUMBER=ROCKET_LAUNCHER_0001 29# 30# Client receives: 31# 32# Set-Cookie: SHIPPING=FEDEX; path=/fo 33# 34# When client requests a URL in path "/" on this server, it sends: 35# 36# Cookie: CUSTOMER=WILE_E_COYOTE; PART_NUMBER=ROCKET_LAUNCHER_0001 37# 38# When client requests a URL in path "/foo" on this server, it sends: 39# 40# Cookie: CUSTOMER=WILE_E_COYOTE; PART_NUMBER=ROCKET_LAUNCHER_0001; SHIPPING=FEDEX 41# 42# The last Cookie is buggy, because both specifications says that the 43# most specific cookie must be sent first. SHIPPING=FEDEX is the 44# most specific and should thus be first. 45 46my $year_plus_one = (localtime)[5] + 1900 + 1; 47 48$c = HTTP::Cookies->new; 49 50$req = HTTP::Request->new(GET => "http://1.1.1.1/"); 51$req->header("Host", "www.acme.com:80"); 52 53$res = HTTP::Response->new(200, "OK"); 54$res->request($req); 55$res->header("Set-Cookie" => "CUSTOMER=WILE_E_COYOTE; path=/ ; expires=Wednesday, 09-Nov-$year_plus_one 23:12:40 GMT"); 56#print $res->as_string; 57$c->extract_cookies($res); 58 59$req = HTTP::Request->new(GET => "http://www.acme.com/"); 60$c->add_cookie_header($req); 61 62ok($req->header("Cookie"), "CUSTOMER=WILE_E_COYOTE"); 63ok($req->header("Cookie2"), "\$Version=\"1\""); 64 65$res->request($req); 66$res->header("Set-Cookie" => "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/"); 67$c->extract_cookies($res); 68 69$req = HTTP::Request->new(GET => "http://www.acme.com/foo/bar"); 70$c->add_cookie_header($req); 71 72$h = $req->header("Cookie"); 73ok($h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/); 74ok($h =~ /CUSTOMER=WILE_E_COYOTE/); 75 76$res->request($req); 77$res->header("Set-Cookie", "SHIPPING=FEDEX; path=/foo"); 78$c->extract_cookies($res); 79 80$req = HTTP::Request->new(GET => "http://www.acme.com/"); 81$c->add_cookie_header($req); 82 83$h = $req->header("Cookie"); 84ok($h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/); 85ok($h =~ /CUSTOMER=WILE_E_COYOTE/); 86ok($h !~ /SHIPPING=FEDEX/); 87 88 89$req = HTTP::Request->new(GET => "http://www.acme.com/foo/"); 90$c->add_cookie_header($req); 91 92$h = $req->header("Cookie"); 93ok($h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/); 94ok($h =~ /CUSTOMER=WILE_E_COYOTE/); 95ok($h =~ /^SHIPPING=FEDEX;/); 96 97print $c->as_string; 98 99 100# Second Example transaction sequence: 101# 102# Assume all mappings from above have been cleared. 103# 104# Client receives: 105# 106# Set-Cookie: PART_NUMBER=ROCKET_LAUNCHER_0001; path=/ 107# 108# When client requests a URL in path "/" on this server, it sends: 109# 110# Cookie: PART_NUMBER=ROCKET_LAUNCHER_0001 111# 112# Client receives: 113# 114# Set-Cookie: PART_NUMBER=RIDING_ROCKET_0023; path=/ammo 115# 116# When client requests a URL in path "/ammo" on this server, it sends: 117# 118# Cookie: PART_NUMBER=RIDING_ROCKET_0023; PART_NUMBER=ROCKET_LAUNCHER_0001 119# 120# NOTE: There are two name/value pairs named "PART_NUMBER" due to 121# the inheritance of the "/" mapping in addition to the "/ammo" mapping. 122 123$c = HTTP::Cookies->new; # clear it 124 125$req = HTTP::Request->new(GET => "http://www.acme.com/"); 126$res = HTTP::Response->new(200, "OK"); 127$res->request($req); 128$res->header("Set-Cookie", "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/"); 129 130$c->extract_cookies($res); 131 132$req = HTTP::Request->new(GET => "http://www.acme.com/"); 133$c->add_cookie_header($req); 134 135ok($req->header("Cookie"), "PART_NUMBER=ROCKET_LAUNCHER_0001"); 136 137$res->request($req); 138$res->header("Set-Cookie", "PART_NUMBER=RIDING_ROCKET_0023; path=/ammo"); 139$c->extract_cookies($res); 140 141$req = HTTP::Request->new(GET => "http://www.acme.com/ammo"); 142$c->add_cookie_header($req); 143 144ok($req->header("Cookie") =~ 145 /^PART_NUMBER=RIDING_ROCKET_0023;\s*PART_NUMBER=ROCKET_LAUNCHER_0001/); 146 147print $c->as_string; 148undef($c); 149 150 151#------------------------------------------------------------------- 152# When there are no "Set-Cookie" header, then even responses 153# without any request URLs connected should be allowed. 154 155$c = HTTP::Cookies->new; 156$c->extract_cookies(HTTP::Response->new("200", "OK")); 157ok(count_cookies($c), 0); 158 159 160#------------------------------------------------------------------- 161# Then we test with the examples from RFC 2965. 162# 163# 5. EXAMPLES 164 165$c = HTTP::Cookies->new; 166 167# 168# 5.1 Example 1 169# 170# Most detail of request and response headers has been omitted. Assume 171# the user agent has no stored cookies. 172# 173# 1. User Agent -> Server 174# 175# POST /acme/login HTTP/1.1 176# [form data] 177# 178# User identifies self via a form. 179# 180# 2. Server -> User Agent 181# 182# HTTP/1.1 200 OK 183# Set-Cookie2: Customer="WILE_E_COYOTE"; Version="1"; Path="/acme" 184# 185# Cookie reflects user's identity. 186 187$cookie = interact($c, 'http://www.acme.com/acme/login', 188 'Customer="WILE_E_COYOTE"; Version="1"; Path="/acme"'); 189ok(!$cookie); 190 191# 192# 3. User Agent -> Server 193# 194# POST /acme/pickitem HTTP/1.1 195# Cookie: $Version="1"; Customer="WILE_E_COYOTE"; $Path="/acme" 196# [form data] 197# 198# User selects an item for ``shopping basket.'' 199# 200# 4. Server -> User Agent 201# 202# HTTP/1.1 200 OK 203# Set-Cookie2: Part_Number="Rocket_Launcher_0001"; Version="1"; 204# Path="/acme" 205# 206# Shopping basket contains an item. 207 208$cookie = interact($c, 'http://www.acme.com/acme/pickitem', 209 'Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"'); 210ok($cookie =~ m(^\$Version="?1"?; Customer="?WILE_E_COYOTE"?; \$Path="/acme"$)); 211 212# 213# 5. User Agent -> Server 214# 215# POST /acme/shipping HTTP/1.1 216# Cookie: $Version="1"; 217# Customer="WILE_E_COYOTE"; $Path="/acme"; 218# Part_Number="Rocket_Launcher_0001"; $Path="/acme" 219# [form data] 220# 221# User selects shipping method from form. 222# 223# 6. Server -> User Agent 224# 225# HTTP/1.1 200 OK 226# Set-Cookie2: Shipping="FedEx"; Version="1"; Path="/acme" 227# 228# New cookie reflects shipping method. 229 230$cookie = interact($c, "http://www.acme.com/acme/shipping", 231 'Shipping="FedEx"; Version="1"; Path="/acme"'); 232 233ok($cookie =~ /^\$Version="?1"?;/); 234ok($cookie =~ /Part_Number="?Rocket_Launcher_0001"?;\s*\$Path="\/acme"/); 235ok($cookie =~ /Customer="?WILE_E_COYOTE"?;\s*\$Path="\/acme"/); 236 237# 238# 7. User Agent -> Server 239# 240# POST /acme/process HTTP/1.1 241# Cookie: $Version="1"; 242# Customer="WILE_E_COYOTE"; $Path="/acme"; 243# Part_Number="Rocket_Launcher_0001"; $Path="/acme"; 244# Shipping="FedEx"; $Path="/acme" 245# [form data] 246# 247# User chooses to process order. 248# 249# 8. Server -> User Agent 250# 251# HTTP/1.1 200 OK 252# 253# Transaction is complete. 254 255$cookie = interact($c, "http://www.acme.com/acme/process"); 256print "FINAL COOKIE: $cookie\n"; 257ok($cookie =~ /Shipping="?FedEx"?;\s*\$Path="\/acme"/); 258ok($cookie =~ /WILE_E_COYOTE/); 259 260# 261# The user agent makes a series of requests on the origin server, after 262# each of which it receives a new cookie. All the cookies have the same 263# Path attribute and (default) domain. Because the request URLs all have 264# /acme as a prefix, and that matches the Path attribute, each request 265# contains all the cookies received so far. 266 267print $c->as_string; 268 269 270# 5.2 Example 2 271# 272# This example illustrates the effect of the Path attribute. All detail 273# of request and response headers has been omitted. Assume the user agent 274# has no stored cookies. 275 276$c = HTTP::Cookies->new; 277 278# Imagine the user agent has received, in response to earlier requests, 279# the response headers 280# 281# Set-Cookie2: Part_Number="Rocket_Launcher_0001"; Version="1"; 282# Path="/acme" 283# 284# and 285# 286# Set-Cookie2: Part_Number="Riding_Rocket_0023"; Version="1"; 287# Path="/acme/ammo" 288 289interact($c, "http://www.acme.com/acme/ammo/specific", 290 'Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"', 291 'Part_Number="Riding_Rocket_0023"; Version="1"; Path="/acme/ammo"'); 292 293# A subsequent request by the user agent to the (same) server for URLs of 294# the form /acme/ammo/... would include the following request header: 295# 296# Cookie: $Version="1"; 297# Part_Number="Riding_Rocket_0023"; $Path="/acme/ammo"; 298# Part_Number="Rocket_Launcher_0001"; $Path="/acme" 299# 300# Note that the NAME=VALUE pair for the cookie with the more specific Path 301# attribute, /acme/ammo, comes before the one with the less specific Path 302# attribute, /acme. Further note that the same cookie name appears more 303# than once. 304 305$cookie = interact($c, "http://www.acme.com/acme/ammo/..."); 306ok($cookie =~ /Riding_Rocket_0023.*Rocket_Launcher_0001/); 307 308# A subsequent request by the user agent to the (same) server for a URL of 309# the form /acme/parts/ would include the following request header: 310# 311# Cookie: $Version="1"; Part_Number="Rocket_Launcher_0001"; $Path="/acme" 312# 313# Here, the second cookie's Path attribute /acme/ammo is not a prefix of 314# the request URL, /acme/parts/, so the cookie does not get forwarded to 315# the server. 316 317$cookie = interact($c, "http://www.acme.com/acme/parts/"); 318ok($cookie =~ /Rocket_Launcher_0001/); 319ok($cookie !~ /Riding_Rocket_0023/); 320 321print $c->as_string; 322 323#----------------------------------------------------------------------- 324 325# Test rejection of Set-Cookie2 responses based on domain, path or port 326 327$c = HTTP::Cookies->new; 328 329# illegal domain (no embedded dots) 330$cookie = interact($c, "http://www.acme.com", 'foo=bar; domain=".com"'); 331ok(count_cookies($c), 0); 332 333# legal domain 334$cookie = interact($c, "http://www.acme.com", 'foo=bar; domain="acme.com"'); 335ok(count_cookies($c), 1); 336 337# illegal domain (host prefix "www.a" contains a dot) 338$cookie = interact($c, "http://www.a.acme.com", 'foo=bar; domain="acme.com"'); 339ok(count_cookies($c), 1); 340 341# legal domain 342$cookie = interact($c, "http://www.a.acme.com", 'foo=bar; domain=".a.acme.com"'); 343ok(count_cookies($c), 2); 344 345# can't use a IP-address as domain 346$cookie = interact($c, "http://125.125.125.125", 'foo=bar; domain="125.125.125"'); 347ok(count_cookies($c), 2); 348 349# illegal path (must be prefix of request path) 350$cookie = interact($c, "http://www.sol.no", 'foo=bar; domain=".sol.no"; path="/foo"'); 351ok(count_cookies($c), 2); 352 353# legal path 354$cookie = interact($c, "http://www.sol.no/foo/bar", 'foo=bar; domain=".sol.no"; path="/foo"'); 355ok(count_cookies($c), 3); 356 357# illegal port (request-port not in list) 358$cookie = interact($c, "http://www.sol.no", 'foo=bar; domain=".sol.no"; port="90,100"'); 359ok(count_cookies($c), 3); 360 361# legal port 362$cookie = interact($c, "http://www.sol.no", 'foo=bar; domain=".sol.no"; port="90,100, 80,8080"; max-age=100; Comment = "Just kidding! (\"|\\\\) "'); 363ok(count_cookies($c), 4); 364 365# port attribute without any value (current port) 366$cookie = interact($c, "http://www.sol.no", 'foo9=bar; domain=".sol.no"; port; max-age=100;'); 367ok(count_cookies($c), 5); 368 369# encoded path 370$cookie = interact($c, "http://www.sol.no/foo/", 'foo8=bar; path="/%66oo"'); 371ok(count_cookies($c), 6); 372 373my $file = "lwp-cookies-$$.txt"; 374$c->save($file); 375$old = $c->as_string; 376undef($c); 377 378$c = HTTP::Cookies->new; 379$c->load($file); 380unlink($file) || warn "Can't unlink $file: $!"; 381 382ok($old, $c->as_string); 383 384undef($c); 385 386# 387# Try some URL encodings of the PATHs 388# 389$c = HTTP::Cookies->new; 390interact($c, "http://www.acme.com/foo%2f%25/%40%40%0Anew%E5/%E5", 'foo = bar; version = 1'); 391print $c->as_string; 392 393$cookie = interact($c, "http://www.acme.com/foo%2f%25/@@%0anew�/���", "bar=baz; path=\"/foo/\"; version=1"); 394ok($cookie =~ /foo=bar/); 395ok($cookie =~ /^\$version=\"?1\"?/i); 396 397$cookie = interact($c, "http://www.acme.com/foo/%25/@@%0anew�/���"); 398ok(!$cookie); 399 400undef($c); 401 402# 403# Try to use the Netscape cookie file format for saving 404# 405$file = "cookies-$$.txt"; 406$c = HTTP::Cookies::Netscape->new(file => $file); 407interact($c, "http://www.acme.com/", "foo1=bar; max-age=100"); 408interact($c, "http://www.acme.com/", "foo2=bar; port=\"80\"; max-age=100; Discard; Version=1"); 409interact($c, "http://www.acme.com/", "foo3=bar; secure; Version=1"); 410$c->save; 411undef($c); 412 413$c = HTTP::Cookies::Netscape->new(file => $file); 414ok(count_cookies($c), 1); # 2 of them discarded on save 415 416ok($c->as_string =~ /foo1=bar/); 417undef($c); 418unlink($file); 419 420# Expect a HttpOnly cookie to be loaded, rather than treated as a comment 421$c = HTTP::Cookies::Netscape->new(file => 't/data/netscape-httponly.txt'); 422ok(count_cookies($c), 4); 423undef($c); 424 425# 426# Some additional Netscape cookies test 427# 428$c = HTTP::Cookies->new; 429$req = HTTP::Request->new(POST => "http://foo.bar.acme.com/foo"); 430 431# Netscape allows a host part that contains dots 432$res = HTTP::Response->new(200, "OK"); 433$res->header(set_cookie => 'Customer=WILE_E_COYOTE; domain=.acme.com'); 434$res->request($req); 435$c->extract_cookies($res); 436 437# and that the domain is the same as the host without adding a leading 438# dot to the domain. Should not quote even if strange chars are used 439# in the cookie value. 440$res = HTTP::Response->new(200, "OK"); 441$res->header(set_cookie => 'PART_NUMBER=3,4; domain=foo.bar.acme.com'); 442$res->request($req); 443$c->extract_cookies($res); 444 445print $c->as_string; 446 447require URI; 448$req = HTTP::Request->new(POST => URI->new("http://foo.bar.acme.com/foo")); 449$c->add_cookie_header($req); 450#print $req->as_string; 451ok($req->header("Cookie") =~ /PART_NUMBER=3,4/); 452ok($req->header("Cookie") =~ /Customer=WILE_E_COYOTE/); 453 454 455# Test handling of local intranet hostnames without a dot 456$c->clear; 457print "---\n"; 458 459interact($c, "http://example/", "foo1=bar; PORT; Discard;"); 460$_=interact($c, "http://example/", 'foo2=bar; domain=".local"'); 461ok(/foo1=bar/); 462 463$_=interact($c, "http://example/", 'foo3=bar'); 464$_=interact($c, "http://example/"); 465print "Cookie: $_\n"; 466ok(/foo2=bar/); 467ok(count_cookies($c), 3); 468print $c->as_string; 469 470# Test for empty path 471# Broken web-server ORION/1.3.38 returns to the client response like 472# 473# Set-Cookie: JSESSIONID=ABCDERANDOM123; Path= 474# 475# e.g. with Path set to nothing. 476# In this case routine extract_cookies() must set cookie to / (root) 477print "---\n"; 478print "Test for empty path...\n"; 479$c = HTTP::Cookies->new; # clear it 480 481$req = HTTP::Request->new(GET => "http://www.ants.com/"); 482 483$res = HTTP::Response->new(200, "OK"); 484$res->request($req); 485$res->header("Set-Cookie" => "JSESSIONID=ABCDERANDOM123; Path="); 486print $res->as_string; 487$c->extract_cookies($res); 488#print $c->as_string; 489 490$req = HTTP::Request->new(GET => "http://www.ants.com/"); 491$c->add_cookie_header($req); 492#print $req->as_string; 493 494ok($req->header("Cookie"), "JSESSIONID=ABCDERANDOM123"); 495ok($req->header("Cookie2"), "\$Version=\"1\""); 496 497 498# missing path in the request URI 499$req = HTTP::Request->new(GET => URI->new("http://www.ants.com:8080")); 500$c->add_cookie_header($req); 501#print $req->as_string; 502 503ok($req->header("Cookie"), "JSESSIONID=ABCDERANDOM123"); 504ok($req->header("Cookie2"), "\$Version=\"1\""); 505 506# test mixing of Set-Cookie and Set-Cookie2 headers. 507# Example from http://www.trip.com/trs/trip/flighttracker/flight_tracker_home.xsl 508# which gives up these headers: 509# 510# HTTP/1.1 200 OK 511# Connection: close 512# Date: Fri, 20 Jul 2001 19:54:58 GMT 513# Server: Apache/1.3.19 (Unix) ApacheJServ/1.1.2 514# Content-Type: text/html 515# Content-Type: text/html; charset=iso-8859-1 516# Link: </trip/stylesheet.css>; rel="stylesheet"; type="text/css" 517# 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.) 518# Set-Cookie: trip.appServer=1111-0000-x-024;Domain=.trip.com;Path=/ 519# Set-Cookie: JSESSIONID=fkumjm7nt1.JS24;Path=/trs 520# Set-Cookie2: JSESSIONID=fkumjm7nt1.JS24;Version=1;Discard;Path="/trs" 521# Title: TRIP.com Travel - FlightTRACKER 522# X-Meta-Description: Trip.com privacy policy 523# X-Meta-Keywords: privacy policy 524 525$req = HTTP::Request->new('GET', 'http://www.trip.com/trs/trip/flighttracker/flight_tracker_home.xsl'); 526$res = HTTP::Response->new(200, "OK"); 527$res->request($req); 528$res->push_header("Set-Cookie" => qq(trip.appServer=1111-0000-x-024;Domain=.trip.com;Path=/)); 529$res->push_header("Set-Cookie" => qq(JSESSIONID=fkumjm7nt1.JS24;Path=/trs)); 530$res->push_header("Set-Cookie2" => qq(JSESSIONID=fkumjm7nt1.JS24;Version=1;Discard;Path="/trs")); 531#print $res->as_string; 532 533$c = HTTP::Cookies->new; # clear it 534$c->extract_cookies($res); 535print $c->as_string; 536ok($c->as_string, <<'EOT'); 537Set-Cookie3: trip.appServer=1111-0000-x-024; path="/"; domain=.trip.com; path_spec; discard; version=0 538Set-Cookie3: JSESSIONID=fkumjm7nt1.JS24; path="/trs"; domain=www.trip.com; path_spec; discard; version=1 539EOT 540 541#------------------------------------------------------------------- 542# Test if temporary cookies are deleted properly with 543# $jar->clear_temporary_cookies() 544 545$req = HTTP::Request->new('GET', 'http://www.perlmeister.com/scripts'); 546$res = HTTP::Response->new(200, "OK"); 547$res->request($req); 548 # Set session/perm cookies and mark their values as "session" vs. "perm" 549 # to recognize them later 550$res->push_header("Set-Cookie" => qq(s1=session;Path=/scripts)); 551$res->push_header("Set-Cookie" => qq(p1=perm; Domain=.perlmeister.com;Path=/;expires=Fri, 02-Feb-$year_plus_one 23:24:20 GMT)); 552$res->push_header("Set-Cookie" => qq(p2=perm;Path=/;expires=Fri, 02-Feb-$year_plus_one 23:24:20 GMT)); 553$res->push_header("Set-Cookie" => qq(s2=session;Path=/scripts;Domain=.perlmeister.com)); 554$res->push_header("Set-Cookie2" => qq(s3=session;Version=1;Discard;Path="/")); 555 556$c = HTTP::Cookies->new; # clear jar 557$c->extract_cookies($res); 558# How many session/permanent cookies do we have? 559my %counter = ("session_after" => 0); 560$c->scan( sub { $counter{"${_[2]}_before"}++ } ); 561$c->clear_temporary_cookies(); 562# How many now? 563$c->scan( sub { $counter{"${_[2]}_after"}++ } ); 564ok($counter{"perm_after"}, $counter{"perm_before"}); # a permanent cookie got lost accidently 565ok($counter{"session_after"}, 0); # a session cookie hasn't been cleared 566ok($counter{"session_before"}, 3); # we didn't have session cookies in the first place 567#print $c->as_string; 568 569 570# Test handling of 'secure ' attribute for classic cookies 571$c = HTTP::Cookies->new; 572$req = HTTP::Request->new(GET => "https://1.1.1.1/"); 573$req->header("Host", "www.acme.com:80"); 574 575$res = HTTP::Response->new(200, "OK"); 576$res->request($req); 577$res->header("Set-Cookie" => "CUSTOMER=WILE_E_COYOTE ; secure ; path=/"); 578#print $res->as_string; 579$c->extract_cookies($res); 580 581$req = HTTP::Request->new(GET => "http://www.acme.com/"); 582$c->add_cookie_header($req); 583 584ok(!$req->header("Cookie")); 585 586$req->uri->scheme("https"); 587$c->add_cookie_header($req); 588 589ok($req->header("Cookie"), "CUSTOMER=WILE_E_COYOTE"); 590 591#print $req->as_string; 592#print $c->as_string; 593 594 595$req = HTTP::Request->new(GET => "ftp://ftp.activestate.com/"); 596$c->add_cookie_header($req); 597ok(!$req->header("Cookie")); 598 599$req = HTTP::Request->new(GET => "file:/etc/motd"); 600$c->add_cookie_header($req); 601ok(!$req->header("Cookie")); 602 603$req = HTTP::Request->new(GET => "mailto:gisle\@aas.no"); 604$c->add_cookie_header($req); 605ok(!$req->header("Cookie")); 606 607 608# Test cookie called 'expires' <https://rt.cpan.org/Ticket/Display.html?id=8108> 609$c = HTTP::Cookies->new; 610$req = HTTP::Request->new("GET" => "http://example.com"); 611$res = HTTP::Response->new(200, "OK"); 612$res->request($req); 613$res->header("Set-Cookie" => "Expires=10101"); 614$c->extract_cookies($res); 615#print $c->as_string; 616ok($c->as_string, <<'EOT'); 617Set-Cookie3: Expires=10101; path="/"; domain=example.com; discard; version=0 618EOT 619 620# Test empty cookie header [RT#29401] 621$c = HTTP::Cookies->new; 622$res->header("Set-Cookie" => ["CUSTOMER=WILE_E_COYOTE; path=/;", ""]); 623#print $res->as_string; 624$c->extract_cookies($res); 625#print $c->as_string; 626ok($c->as_string, <<'EOT'); 627Set-Cookie3: CUSTOMER=WILE_E_COYOTE; path="/"; domain=example.com; path_spec; discard; version=0 628EOT 629 630# Test empty cookie part [RT#38480] 631$c = HTTP::Cookies->new; 632$res->header("Set-Cookie" => "CUSTOMER=WILE_E_COYOTE;;path=/;"); 633#print $res->as_string; 634$c->extract_cookies($res); 635#print $c->as_string; 636ok($c->as_string, <<'EOT'); 637Set-Cookie3: CUSTOMER=WILE_E_COYOTE; path="/"; domain=example.com; path_spec; discard; version=0 638EOT 639 640# Test Set-Cookie with version set 641$c = HTTP::Cookies->new; 642$res->header("Set-Cookie" => "foo=\"bar\";version=1"); 643#print $res->as_string; 644$c->extract_cookies($res); 645#print $c->as_string; 646$req = HTTP::Request->new(GET => "http://www.example.com/foo"); 647$c->add_cookie_header($req); 648#print $req->as_string; 649ok($req->header("Cookie"), "foo=bar"); 650 651# Test cookies that expire far into the future [RT#50147] 652$c = HTTP::Cookies->new; 653$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"); 654$res->push_header("Set-Cookie", "expired1=1; expires=Mon, 03-Oct-2001 15:18:10 GMT; path=/; domain=.example.com"); 655$res->push_header("Set-Cookie", "expired2=1; expires=Fri Jan 1 00:00:00 GMT 1970; path=/; domain=.example.com"); 656$res->push_header("Set-Cookie", "expired3=1; expires=Fri Jan 1 00:00:01 GMT 1970; path=/; domain=.example.com"); 657$res->push_header("Set-Cookie", "expired4=1; expires=Thu Dec 31 23:59:59 GMT 1969; path=/; domain=.example.com"); 658$res->push_header("Set-Cookie", "expired5=1; expires=Fri Feb 2 00:00:00 GMT 1950; path=/; domain=.example.com"); 659$c->extract_cookies($res); 660#print $res->as_string; 661#print "---\n"; 662#print $c->as_string; 663$req = HTTP::Request->new(GET => "http://www.example.com/foo"); 664$c->add_cookie_header($req); 665#print $req->as_string; 666ok($req->header("Cookie"), "PREF=ID=cee18f7c4e977184:TM=1254583090:LM=1254583090:S=Pdb0-hy9PxrNj4LL"); 667 668$c->clear_temporary_cookies; 669$req = HTTP::Request->new(GET => "http://www.example.com/foo"); 670$c->add_cookie_header($req); 671#print $req->as_string; 672ok($req->header("Cookie"), "PREF=ID=cee18f7c4e977184:TM=1254583090:LM=1254583090:S=Pdb0-hy9PxrNj4LL"); 673 674# Test merging of cookies 675$c = HTTP::Cookies->new; 676$res->header("Set-Cookie", "foo=1; path=/"); 677$c->extract_cookies($res); 678 679$req = HTTP::Request->new(GET => "http://www.example.com/foo"); 680$req->header("Cookie", "x=bcd"); 681$c->add_cookie_header($req); 682ok($req->header("Cookie"), "x=bcd; foo=1"); 683$c->add_cookie_header($req); 684ok($req->header("Cookie"), "x=bcd; foo=1; foo=1"); 685#print $req->as_string; 686 687# Test get_cookies 688$c = HTTP::Cookies->new; 689$res->header("Set-Cookie", "foo=42"); 690$c->extract_cookies($res); 691ok($c->get_cookies("example.com")->{foo}, 42); 692ok($c->get_cookies("example.com", "foo"), 42); 693ok($c->get_cookies("example.com", "bar"), undef); 694ok($c->get_cookies("http://example.com", "foo"), 42); 695ok($c->get_cookies("https://example.com", "foo"), 42); 696ok($c->get_cookies(URI->new("https://example.com"), "foo"), 42); 697ok($c->get_cookies("foo.example.com", "foo"), 42); 698ok($c->get_cookies("example.org", "foo"), undef); 699 700my @a = $c->get_cookies("example.com", "bar", "foo"); 701ok(@a, 2); 702ok($a[0], undef); 703ok($a[1], 42); 704 705# Test ignore_discard argument of save() 706$c = HTTP::Cookies->new( ignore_discard => 0 ); 707interact($c, 'http://example.com/', 'foo=bar; Discard;'); 708$old = $c->as_string; 709$c->save( file => $file, ignore_discard => 1 ); 710undef $c; 711 712$c = HTTP::Cookies->new( ignore_discard => 0 ); 713$c->load($file); 714unlink($file) || warn "Can't unlink $file: $!"; 715 716ok($c->as_string, $old); 717 718$c = HTTP::Cookies::Netscape->new( ignore_discard => 0 ); 719$req = HTTP::Request->new(GET => "http://1.1.1.1/"); 720$req->header("Host", "www.acme.com:80"); 721$res = HTTP::Response->new(200, "OK"); 722$res->request($req); 723$res->header("Set-Cookie" => "foo=bar; path=/; discard; expires=Wednesday, 09-Nov-$year_plus_one 23:12:40 GMT"); 724$c->extract_cookies($res); 725$old = $c->as_string; 726$c->save( file => $file, ignore_discard => 1 ); 727undef $c; 728 729$c = HTTP::Cookies::Netscape->new( ignore_discard => 0 ); 730$c->load($file); 731$req = HTTP::Request->new(GET => "http://www.acme.com/foo/bar"); 732$c->add_cookie_header($req); 733$h = $req->header("Cookie"); 734ok($h =~ /foo=bar/); 735unlink($file) || warn "Can't unlink $file: $!"; 736 737# Test discard isn't set when max-age is set 738$c = HTTP::Cookies->new; 739$req = HTTP::Request->new("GET" => "http://example.com"); 740$res = HTTP::Response->new(200, "OK"); 741$res->request($req); 742$res->header("Set-Cookie" => "foo=bar; max-age=1337"); 743$c->extract_cookies($res); 744#print $c->as_string; 745ok($c->as_string, <<'EOT'); 746Set-Cookie3: foo=bar; path="/"; domain=example.com; version=0 747EOT 748 749 750 751#------------------------------------------------------------------- 752 753sub interact 754{ 755 my $c = shift; 756 my $url = shift; 757 my $req = HTTP::Request->new(POST => $url); 758 $c->add_cookie_header($req); 759 my $cookie = $req->header("Cookie"); 760 my $res = HTTP::Response->new(200, "OK"); 761 $res->request($req); 762 for (@_) { $res->push_header("Set-Cookie2" => $_) } 763 $c->extract_cookies($res); 764 return $cookie; 765} 766 767sub count_cookies 768{ 769 my $c = shift; 770 my $no = 0; 771 $c->scan(sub { $no++ }); 772 $no; 773} 774