git.maemo.org Git - dh-make-perl/blob - dev/i386/libwww-perl/libwww-perl-5.813/t/base/cookies.t

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