Commit 9a23ea298c0c2154c9bfdd4b37677a4bbbe34c46

Gisle Aas
Wed Sep 24 19:50:05 CEST 2008

Tree SHA1: f890f17
Parent SHA1: 1ec5048 (Update Digest Authen to subclass Basic.)
raw diff | raw patch

Make tests use Test.pm

Diff rendering mode:
inline
side by side


1		print "1..45\n";
	1	#!perl -w
2	2
	3	use Test;
	4	plan tests => 62;
	5
3	6	#use LWP::Debug '+';
4	7	use HTTP::Cookies;
5	8	use HTTP::Request;
…	…
60	60	$req = HTTP::Request->new(GET => "http://www.acme.com/");
61	61	$c->add_cookie_header($req);
62	62
63		print "not " unless $req->header("Cookie") eq "CUSTOMER=WILE_E_COYOTE" &&
64		$req->header("Cookie2") eq "\$Version=\"1\"";
65		print "ok 1\n";
	63	ok($req->header("Cookie"), "CUSTOMER=WILE_E_COYOTE");
	64	ok($req->header("Cookie2"), "\$Version=\"1\"");
66	65
67	66	$res->request($req);
68	67	$res->header("Set-Cookie" => "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/");
…	…
71	71	$c->add_cookie_header($req);
72	72
73	73	$h = $req->header("Cookie");
74		print "not " unless $h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/ &&
75		$h =~ /CUSTOMER=WILE_E_COYOTE/;
76		print "ok 2\n";
	74	ok($h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/);
	75	ok($h =~ /CUSTOMER=WILE_E_COYOTE/);
77	76
78	77	$res->request($req);
79	78	$res->header("Set-Cookie", "SHIPPING=FEDEX; path=/foo");
…	…
82	82	$c->add_cookie_header($req);
83	83
84	84	$h = $req->header("Cookie");
85		print "not " unless $h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/ &&
86		$h =~ /CUSTOMER=WILE_E_COYOTE/ &&
87		$h !~ /SHIPPING=FEDEX/;
88		print "ok 3\n";
	85	ok($h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/);
	86	ok($h =~ /CUSTOMER=WILE_E_COYOTE/);
	87	ok($h !~ /SHIPPING=FEDEX/);
89	88
90	89
91	90	$req = HTTP::Request->new(GET => "http://www.acme.com/foo/");
92	91	$c->add_cookie_header($req);
93	92
94	93	$h = $req->header("Cookie");
95		print "not " unless $h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/ &&
96		$h =~ /CUSTOMER=WILE_E_COYOTE/ &&
97		$h =~ /^SHIPPING=FEDEX;/;
98		print "ok 4\n";
	94	ok($h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/);
	95	ok($h =~ /CUSTOMER=WILE_E_COYOTE/);
	96	ok($h =~ /^SHIPPING=FEDEX;/);
99	97
100	98	print $c->as_string;
101	99
…	…
133	133	$req = HTTP::Request->new(GET => "http://www.acme.com/");
134	134	$c->add_cookie_header($req);
135	135
136		print "not " unless $req->header("Cookie") eq "PART_NUMBER=ROCKET_LAUNCHER_0001";
137		print "ok 5\n";
	136	ok($req->header("Cookie"), "PART_NUMBER=ROCKET_LAUNCHER_0001");
138	137
139	138	$res->request($req);
140	139	$res->header("Set-Cookie", "PART_NUMBER=RIDING_ROCKET_0023; path=/ammo");
…	…
142	142	$req = HTTP::Request->new(GET => "http://www.acme.com/ammo");
143	143	$c->add_cookie_header($req);
144	144
145		print "not " unless $req->header("Cookie") =~
146		/^PART_NUMBER=RIDING_ROCKET_0023;\s*PART_NUMBER=ROCKET_LAUNCHER_0001/;
147		print "ok 6\n";
	145	ok($req->header("Cookie") =~
	146	/^PART_NUMBER=RIDING_ROCKET_0023;\s*PART_NUMBER=ROCKET_LAUNCHER_0001/);
148	147
149	148	print $c->as_string;
150	149	undef($c);
…	…
155	155
156	156	$c = HTTP::Cookies->new;
157	157	$c->extract_cookies(HTTP::Response->new("200", "OK"));
158		print "not " if count_cookies($c) != 0;
159		print "ok 7\n";
	158	ok(count_cookies($c), 0);
160	159
161	160
162	161	#-------------------------------------------------------------------
…	…
187	187
188	188	$cookie = interact($c, 'http://www.acme.com/acme/login',
189	189	'Customer="WILE_E_COYOTE"; Version="1"; Path="/acme"');
190		print "not " if $cookie;
191		print "ok 8\n";
	190	ok(!$cookie);
192	191
193	192	#
194	193	# 3. User Agent -> Server
…	…
208	208
209	209	$cookie = interact($c, 'http://www.acme.com/acme/pickitem',
210	210	'Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"');
211		print "not " unless $cookie =~ m(^\$Version="?1"?; Customer="?WILE_E_COYOTE"?; \$Path="/acme"$);
212		print "ok 9\n";
	211	ok($cookie =~ m(^\$Version="?1"?; Customer="?WILE_E_COYOTE"?; \$Path="/acme"$));
213	212
214	213	#
215	214	# 5. User Agent -> Server
…	…
231	231	$cookie = interact($c, "http://www.acme.com/acme/shipping",
232	232	'Shipping="FedEx"; Version="1"; Path="/acme"');
233	233
234		print "not " unless $cookie =~ /^\$Version="?1"?;/ &&
235		$cookie =~ /Part_Number="?Rocket_Launcher_0001"?;\s*\$Path="\/acme"/ &&
236		$cookie =~ /Customer="?WILE_E_COYOTE"?;\s*\$Path="\/acme"/;
237		print "ok 10\n";
	234	ok($cookie =~ /^\$Version="?1"?;/);
	235	ok($cookie =~ /Part_Number="?Rocket_Launcher_0001"?;\s*\$Path="\/acme"/);
	236	ok($cookie =~ /Customer="?WILE_E_COYOTE"?;\s*\$Path="\/acme"/);
238	237
239	238	#
240	239	# 7. User Agent -> Server
…	…
255	255
256	256	$cookie = interact($c, "http://www.acme.com/acme/process");
257	257	print "FINAL COOKIE: $cookie\n";
258		print "not " unless $cookie =~ /Shipping="?FedEx"?;\s*\$Path="\/acme"/ &&
259		$cookie =~ /WILE_E_COYOTE/;
260		print "ok 11\n";
	258	ok($cookie =~ /Shipping="?FedEx"?;\s*\$Path="\/acme"/);
	259	ok($cookie =~ /WILE_E_COYOTE/);
261	260
262	261	#
263	262	# The user agent makes a series of requests on the origin server, after
…	…
304	304	# than once.
305	305
306	306	$cookie = interact($c, "http://www.acme.com/acme/ammo/...");
307		print "not " unless $cookie =~ /Riding_Rocket_0023.*Rocket_Launcher_0001/;
308		print "ok 12\n";
	307	ok($cookie =~ /Riding_Rocket_0023.*Rocket_Launcher_0001/);
309	308
310	309	# A subsequent request by the user agent to the (same) server for a URL of
311	310	# the form /acme/parts/ would include the following request header:
…	…
316	316	# the server.
317	317
318	318	$cookie = interact($c, "http://www.acme.com/acme/parts/");
319		print "not " unless $cookie =~ /Rocket_Launcher_0001/ &&
320		$cookie !~ /Riding_Rocket_0023/;
321		print "ok 13\n";
	319	ok($cookie =~ /Rocket_Launcher_0001/);
	320	ok($cookie !~ /Riding_Rocket_0023/);
322	321
323	322	print $c->as_string;
324	323
…	…
329	329
330	330	# illegal domain (no embedded dots)
331	331	$cookie = interact($c, "http://www.acme.com", 'foo=bar; domain=".com"');
332		print "not " if count_cookies($c) > 0;
333		print "ok 14\n";
	332	ok(count_cookies($c), 0);
334	333
335	334	# legal domain
336	335	$cookie = interact($c, "http://www.acme.com", 'foo=bar; domain="acme.com"');
337		print "not " if count_cookies($c) != 1;
338		print "ok 15\n";
	336	ok(count_cookies($c), 1);
339	337
340	338	# illegal domain (host prefix "www.a" contains a dot)
341	339	$cookie = interact($c, "http://www.a.acme.com", 'foo=bar; domain="acme.com"');
342		print "not " if count_cookies($c) != 1;
343		print "ok 16\n";
	340	ok(count_cookies($c), 1);
344	341
345	342	# legal domain
346	343	$cookie = interact($c, "http://www.a.acme.com", 'foo=bar; domain=".a.acme.com"');
347		print "not " if count_cookies($c) != 2;
348		print "ok 17\n";
	344	ok(count_cookies($c), 2);
349	345
350	346	# can't use a IP-address as domain
351	347	$cookie = interact($c, "http://125.125.125.125", 'foo=bar; domain="125.125.125"');
352		print "not " if count_cookies($c) != 2;
353		print "ok 18\n";
	348	ok(count_cookies($c), 2);
354	349
355	350	# illegal path (must be prefix of request path)
356	351	$cookie = interact($c, "http://www.sol.no", 'foo=bar; domain=".sol.no"; path="/foo"');
357		print "not " if count_cookies($c) != 2;
358		print "ok 19\n";
	352	ok(count_cookies($c), 2);
359	353
360	354	# legal path
361	355	$cookie = interact($c, "http://www.sol.no/foo/bar", 'foo=bar; domain=".sol.no"; path="/foo"');
362		print "not " if count_cookies($c) != 3;
363		print "ok 20\n";
	356	ok(count_cookies($c), 3);
364	357
365	358	# illegal port (request-port not in list)
366	359	$cookie = interact($c, "http://www.sol.no", 'foo=bar; domain=".sol.no"; port="90,100"');
367		print "not " if count_cookies($c) != 3;
368		print "ok 21\n";
	360	ok(count_cookies($c), 3);
369	361
370	362	# legal port
371	363	$cookie = interact($c, "http://www.sol.no", 'foo=bar; domain=".sol.no"; port="90,100, 80,8080"; max-age=100; Comment = "Just kidding! (\"\|\\\\) "');
372		print "not " if count_cookies($c) != 4;
373		print "ok 22\n";
	364	ok(count_cookies($c), 4);
374	365
375	366	# port attribute without any value (current port)
376	367	$cookie = interact($c, "http://www.sol.no", 'foo9=bar; domain=".sol.no"; port; max-age=100;');
377		print "not " if count_cookies($c) != 5;
378		print "ok 23\n";
	368	ok(count_cookies($c), 5);
379	369
380	370	# encoded path
381	371	$cookie = interact($c, "http://www.sol.no/foo/", 'foo8=bar; path="/%66oo"');
382		print "not " if count_cookies($c) != 6;
383		print "ok 24\n";
	372	ok(count_cookies($c), 6);
384	373
385	374	my $file = "lwp-cookies-$$.txt";
386	375	$c->save($file);
…	…
380	380	$c->load($file);
381	381	unlink($file) \|\| warn "Can't unlink $file: $!";
382	382
383		print "not " unless $old eq $c->as_string;
384		print "ok 25\n";
	383	ok($old, $c->as_string);
385	384
386	385	undef($c);
387	386
…	…
392	392	print $c->as_string;
393	393
394	394	$cookie = interact($c, "http://www.acme.com/foo%2f%25/@@%0anew�/��", "bar=baz; path=\"/foo/\"; version=1");
395		print "not " unless $cookie =~ /foo=bar/ && $cookie =~ /^\$version=\"?1\"?/i;
396		print "ok 26\n";
	395	ok($cookie =~ /foo=bar/);
	396	ok($cookie =~ /^\$version=\"?1\"?/i);
397	397
398	398	$cookie = interact($c, "http://www.acme.com/foo/%25/@@%0anew�/��");
399		print "not " if $cookie;
400		print "ok 27\n";
	399	ok(!$cookie);
401	400
402	401	undef($c);
403	402
…	…
412	412	undef($c);
413	413
414	414	$c = HTTP::Cookies::Netscape->new(file => $file);
415		print "not " unless count_cookies($c) == 1; # 2 of them discarded on save
416		print "ok 28\n";
	415	ok(count_cookies($c), 1); # 2 of them discarded on save
417	416
418		print "not " unless $c->as_string =~ /foo1=bar/;
419		print "ok 29\n";
	417	ok($c->as_string =~ /foo1=bar/);
420	418	undef($c);
421	419	unlink($file);
422	420
…	…
445	445	$req = HTTP::Request->new(POST => URI->new("http://foo.bar.acme.com/foo"));
446	446	$c->add_cookie_header($req);
447	447	#print $req->as_string;
448		print "not " unless $req->header("Cookie") =~ /PART_NUMBER=3,4/ &&
449		$req->header("Cookie") =~ /Customer=WILE_E_COYOTE/;
450		print "ok 30\n";
	448	ok($req->header("Cookie") =~ /PART_NUMBER=3,4/);
	449	ok($req->header("Cookie") =~ /Customer=WILE_E_COYOTE/);
451	450
452	451
453
454	452	# Test handling of local intranet hostnames without a dot
455	453	$c->clear;
456	454	print "---\n";
…	…
457	457
458	458	interact($c, "http://example/", "foo1=bar; PORT; Discard;");
459	459	$_=interact($c, "http://example/", 'foo2=bar; domain=".local"');
460		print "not " unless /foo1=bar/;
461		print "ok 31\n";
	460	ok(/foo1=bar/);
462	461
463	462	$_=interact($c, "http://example/", 'foo3=bar');
464	463	$_=interact($c, "http://example/");
465	464	print "Cookie: $_\n";
466		print "not " unless /foo2=bar/ && count_cookies($c) == 3;
467		print "ok 32\n";
	465	ok(/foo2=bar/);
	466	ok(count_cookies($c), 3);
468	467	print $c->as_string;
469	468
470	469	# Test for empty path
…	…
490	490	$c->add_cookie_header($req);
491	491	#print $req->as_string;
492	492
493		print "not " unless $req->header("Cookie") eq "JSESSIONID=ABCDERANDOM123" &&
494		$req->header("Cookie2") eq "\$Version=\"1\"";
495		print "ok 33\n";
	493	ok($req->header("Cookie"), "JSESSIONID=ABCDERANDOM123");
	494	ok($req->header("Cookie2"), "\$Version=\"1\"");
496	495
497	496
498	497	# missing path in the request URI
…	…
499	499	$c->add_cookie_header($req);
500	500	#print $req->as_string;
501	501
502		print "not " unless $req->header("Cookie") eq "JSESSIONID=ABCDERANDOM123" &&
503		$req->header("Cookie2") eq "\$Version=\"1\"";
504		print "ok 34\n";
	502	ok($req->header("Cookie"), "JSESSIONID=ABCDERANDOM123");
	503	ok($req->header("Cookie2"), "\$Version=\"1\"");
505	504
506	505	# test mixing of Set-Cookie and Set-Cookie2 headers.
507	506	# Example from http://www.trip.com/trs/trip/flighttracker/flight_tracker_home.xsl
…	…
532	532	$c = HTTP::Cookies->new; # clear it
533	533	$c->extract_cookies($res);
534	534	print $c->as_string;
535		print "not " unless $c->as_string eq <<'EOT'; print "ok 35\n";
	535	ok($c->as_string, <<'EOT');
536	536	Set-Cookie3: trip.appServer=1111-0000-x-024; path="/"; domain=.trip.com; path_spec; discard; version=0
537	537	Set-Cookie3: JSESSIONID=fkumjm7nt1.JS24; path="/trs"; domain=www.trip.com; path_spec; discard; version=1
538	538	EOT
…	…
560	560	$c->clear_temporary_cookies();
561	561	# How many now?
562	562	$c->scan( sub { $counter{"${_[2]}_after"}++ } );
563		print "not " if # a permanent cookie got lost accidently
564		$counter{"perm_after"} != $counter{"perm_before"} or
565		# a session cookie hasn't been cleared
566		$counter{"session_after"} != 0 or
567		# we didn't have session cookies in the first place
568		$counter{"session_before"} == 0;
	563	ok($counter{"perm_after"}, $counter{"perm_before"}); # a permanent cookie got lost accidently
	564	ok($counter{"session_after"}, 0); # a session cookie hasn't been cleared
	565	ok($counter{"session_before"}, 3); # we didn't have session cookies in the first place
569	566	#print $c->as_string;
570		print "ok 36\n";
571	567
572	568
573	569	# Test handling of 'secure ' attribute for classic cookies
…	…
580	580	$req = HTTP::Request->new(GET => "http://www.acme.com/");
581	581	$c->add_cookie_header($req);
582	582
583		print "not " if $req->header("Cookie");
584		print "ok 37\n";
	583	ok(!$req->header("Cookie"));
585	584
586	585	$req->uri->scheme("https");
587	586	$c->add_cookie_header($req);
588	587
589		print "not " unless $req->header("Cookie") eq "CUSTOMER=WILE_E_COYOTE";
590		print "ok 38\n";
	588	ok($req->header("Cookie"), "CUSTOMER=WILE_E_COYOTE");
591	589
592	590	#print $req->as_string;
593	591	#print $c->as_string;
…	…
593	593
594	594	$req = HTTP::Request->new(GET => "ftp://ftp.activestate.com/");
595	595	$c->add_cookie_header($req);
	596	ok(!$req->header("Cookie"));
596	597
597		print "not " if $req->header("Cookie");
598		print "ok 39\n";
599
600	598	$req = HTTP::Request->new(GET => "file:/etc/motd");
601	599	$c->add_cookie_header($req);
	600	ok(!$req->header("Cookie"));
602	601
603		print "not " if $req->header("Cookie");
604		print "ok 40\n";
605
606	602	$req = HTTP::Request->new(GET => "mailto:gisle\@aas.no");
607	603	$c->add_cookie_header($req);
	604	ok(!$req->header("Cookie"));
608	605
609		print "not " if $req->header("Cookie");
610		print "ok 41\n";
611	606
612
613	607	# Test cookie called 'exipres' <https://rt.cpan.org/Ticket/Display.html?id=8108>
614	608	$c = HTTP::Cookies->new;
615	609	$req = HTTP::Request->new("GET" => "http://example.com");
…	…
612	612	$res->header("Set-Cookie" => "Expires=10101");
613	613	$c->extract_cookies($res);
614	614	#print $c->as_string;
615		print "not " unless $c->as_string eq <<'EOT'; print "ok 42\n";
	615	ok($c->as_string, <<'EOT');
616	616	Set-Cookie3: Expires=10101; path="/"; domain=example.com; discard; version=0
617	617	EOT
618	618
…	…
622	622	#print $res->as_string;
623	623	$c->extract_cookies($res);
624	624	#print $c->as_string;
625		print "not " unless $c->as_string eq <<'EOT'; print "ok 43\n";
	625	ok($c->as_string, <<'EOT');
626	626	Set-Cookie3: CUSTOMER=WILE_E_COYOTE; path="/"; domain=example.com; path_spec; discard; version=0
627	627	EOT
628	628
…	…
632	632	#print $res->as_string;
633	633	$c->extract_cookies($res);
634	634	#print $c->as_string;
635		print "not " unless $c->as_string eq <<'EOT'; print "ok 44\n";
	635	ok($c->as_string, <<'EOT');
636	636	Set-Cookie3: CUSTOMER=WILE_E_COYOTE; path="/"; domain=example.com; path_spec; discard; version=0
637	637	EOT
638	638
…	…
645	645	$req = HTTP::Request->new(GET => "http://www.example.com/foo");
646	646	$c->add_cookie_header($req);
647	647	#print $req->as_string;
648		print "not " unless $req->header("Cookie") eq "foo=\"bar\"";
649		print "ok 45\n";
	648	ok($req->header("Cookie"), "foo=\"bar\"");
650	649
651	650	#-------------------------------------------------------------------
652	651


	1	#!perl -w
	2
	3	use strict;
	4	use Test;
	5
	6	plan tests => 133;
	7
1	8	use HTTP::Date;
2	9
3	10	require Time::Local if $^O eq "MacOS";
4	11	my $offset = ($^O eq "MacOS") ? Time::Local::timegm(0,0,0,1,0,70) : 0;
5	12
6		print "1..59\n";
7
8		$no = 1;
9		$\| = 1;
10		sub ok {
11		print "not " if $_[0];
12		print "ok $no\n";
13		$no++;
14		}
15
16	13	# test str2time for supported dates. Test cases with 2 digit year
17	14	# will probably break in year 2044.
18	15	my(@tests) =
…	…
69	69	my $t2 = str2time(lc($_), "GMT");
70	70	my $t3 = str2time(uc($_), "GMT");
71	71
72		$t = "UNDEF" unless defined $t;
73		print "'$_' => $t\n";
74		print $@ if $@;
75		print "not " if $t eq 'UNDEF' \|\| $t != $time
76		\|\| $t2 != $time
77		\|\| $t3 != $time;
78		ok;
	72	print "\n# '$_'\n";
	73
	74	ok($t, $time);
	75	ok($t2, $time);
	76	ok($t3, $time);
79	77	}
80	78
81	79	# test time2str
82		die "time2str failed"
83		unless time2str($time) eq 'Thu, 03 Feb 1994 00:00:00 GMT';
	80	ok(time2str($time), 'Thu, 03 Feb 1994 00:00:00 GMT');
84	81
85	82	# test the 'ls -l' format with missing year$
86	83	# round to nearest minute 3 days ago.
87	84	$time = int((time - 3 * 246060) /60)*60;
88		($min, $hr, $mday, $mon) = (localtime $time)[1,2,3,4];
	85	my ($min, $hr, $mday, $mon) = (localtime $time)[1,2,3,4];
89	86	$mon = (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$mon];
90		$str = sprintf("$mon %02d %02d:%02d", $mday, $hr, $min);
91		$t = str2time($str);
92		$t = "UNDEF" unless defined $t;
93		print "'$str' => $t ($time)\n";
94		print "not " if $t != $time;
95		ok;
	87	my $str = sprintf("$mon %02d %02d:%02d", $mday, $hr, $min);
	88	my $t = str2time($str);
	89	ok($t, $time);
96	90
97	91	# try some garbage.
98	92	for (undef, '', 'Garbage',
…	…
112	112	$bad++;
113	113	}
114	114	};
115		print defined($_) ? "'$_'\n" : "undef\n";
116		print $@ if $@;
117		print "not " if $bad;
118		ok;
	115	print defined($_) ? "\n# '$_'\n" : "\n# undef\n";
	116	ok(!$@);
	117	ok(!$bad);
119	118	}
120	119
121	120	print "Testing AM/PM gruff...\n";
…	…
124	124
125	125	print "Testing time2iso functions\n";
126	126
127		$t = time2iso(str2time("11-12-96 0:00AM"));print "$t\n";
128		ok($t ne "1996-11-12 00:00:00");
	127	$t = time2iso(str2time("11-12-96 0:00AM"));
	128	ok($t, "1996-11-12 00:00:00");
129	129
130		$t = time2iso(str2time("11-12-96 12:00AM"));print "$t\n";
131		ok($t ne "1996-11-12 00:00:00");
	130	$t = time2iso(str2time("11-12-96 12:00AM"));
	131	ok($t, "1996-11-12 00:00:00");
132	132
133		$t = time2iso(str2time("11-12-96 0:00PM"));print "$t\n";
134		ok($t ne "1996-11-12 12:00:00");
	133	$t = time2iso(str2time("11-12-96 0:00PM"));
	134	ok($t, "1996-11-12 12:00:00");
135	135
136		$t = time2iso(str2time("11-12-96 12:00PM"));print "$t\n";
137		ok($t ne "1996-11-12 12:00:00");
	136	$t = time2iso(str2time("11-12-96 12:00PM"));
	137	ok($t, "1996-11-12 12:00:00");
138	138
139	139
140		$t = time2iso(str2time("11-12-96 1:05AM"));print "$t\n";
141		ok($t ne "1996-11-12 01:05:00");
	140	$t = time2iso(str2time("11-12-96 1:05AM"));
	141	ok($t, "1996-11-12 01:05:00");
142	142
143		$t = time2iso(str2time("11-12-96 12:05AM"));print "$t\n";
144		ok($t ne "1996-11-12 00:05:00");
	143	$t = time2iso(str2time("11-12-96 12:05AM"));
	144	ok($t, "1996-11-12 00:05:00");
145	145
146		$t = time2iso(str2time("11-12-96 1:05PM"));print "$t\n";
147		ok($t ne "1996-11-12 13:05:00");
	146	$t = time2iso(str2time("11-12-96 1:05PM"));
	147	ok($t, "1996-11-12 13:05:00");
148	148
149		$t = time2iso(str2time("11-12-96 12:05PM"));print "$t\n";
150		ok($t ne "1996-11-12 12:05:00");
	149	$t = time2iso(str2time("11-12-96 12:05PM"));
	150	ok($t, "1996-11-12 12:05:00");
151	151
152	152	$t = str2time("2000-01-01 00:00:01.234");
153	153	print "FRAC $t = ", time2iso($t), "\n";
154		ok(abs(($t - int($t)) - 0.234) > 0.000001);
	154	ok(abs(($t - int($t)) - 0.234) < 0.000001);
155	155
156	156	$a = time2iso;
157	157	$b = time2iso(500000);
158	158	print "LOCAL $a $b\n";
159		$az = time2isoz;
160		$bz = time2isoz(500000);
	159	my $az = time2isoz;
	160	my $bz = time2isoz(500000);
161	161	print "GMT $az $bz\n";
162	162
163		for ($a, $b) { ok if /^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d$/; }
164		for ($az, $bz) { ok if /^\d{4}-\d\d-\d\d \d\d:\d\d:\d\dZ$/; }
	163	for ($a, $b) { ok(/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d$/); }
	164	for ($az, $bz) { ok(/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\dZ$/); }
165	165
166	166	# Test the parse_date interface
167	167	use HTTP::Date qw(parse_date);
168	168
169		@d = parse_date("Jan 1 2001");
	169	my @d = parse_date("Jan 1 2001");
170	170
171		print "not " if defined(pop(@d)) \|\|
172		"@d" ne "2001 1 1 0 0 0";
173		ok;
	171	ok(!defined(pop(@d)));
	172	ok("@d", "2001 1 1 0 0 0");
174	173
175	174	# This test will break around year 2070
176		print "not " unless parse_date("03-Feb-20") eq "2020-02-03 00:00:00";
177		ok;
	175	ok(parse_date("03-Feb-20"), "2020-02-03 00:00:00");
178	176
179	177	# This test will break around year 2048
180		print "not " unless parse_date("03-Feb-98") eq "1998-02-03 00:00:00";
181		ok;
	178	ok(parse_date("03-Feb-98"), "1998-02-03 00:00:00");
182	179
183	180	print "HTTP::Date $HTTP::Date::VERSION\n";


1		print "1..4\n";
	1	#!perl -w
2	2
	3	use strict;
	4	use Test;
	5
	6	plan tests => 6;
	7
3	8	use HTTP::Response;
4	9	use HTTP::Headers::Auth;
5	10
6		$res = HTTP::Response->new(401);
	11	my $res = HTTP::Response->new(401);
7	12	$res->push_header(WWW_Authenticate => qq(Foo realm="WallyWorld", foo=bar, Bar realm="WallyWorld2"));
8	13	$res->push_header(WWW_Authenticate => qq(Basic Realm="WallyWorld", foo=bar, bar=baz));
9	14
10	15	print $res->as_string;
11	16
12		%auth = $res->www_authenticate;
	17	my %auth = $res->www_authenticate;
13	18
14		print "not " unless keys(%auth) == 3;
15		print "ok 1\n";
	19	ok(keys(%auth), 3);
16	20
17		print "not " unless $auth{basic}{realm} eq "WallyWorld" &&
18		$auth{bar}{realm} eq "WallyWorld2";
19		print "ok 2\n";
	21	ok($auth{basic}{realm}, "WallyWorld");
	22	ok($auth{bar}{realm}, "WallyWorld2");
20	23
21	24	$a = $res->www_authenticate;
22		print "not " unless $a eq 'Foo realm="WallyWorld", foo=bar, Bar realm="WallyWorld2", Basic Realm="WallyWorld", foo=bar, bar=baz';
23		print "ok 3\n";
	25	ok($a, 'Foo realm="WallyWorld", foo=bar, Bar realm="WallyWorld2", Basic Realm="WallyWorld", foo=bar, bar=baz');
24	26
25	27	$res->www_authenticate("Basic realm=foo1");
26	28	print $res->as_string;
27	29
28		$res->www_authenticate(Basic => {realm => foo2});
	30	$res->www_authenticate(Basic => {realm => "foo2"});
29	31	print $res->as_string;
30	32
31		$res->www_authenticate(Basic => [realm => foo3, foo=>33],
	33	$res->www_authenticate(Basic => [realm => "foo3", foo=>33],
32	34	Digest => {nonce=>"bar", foo=>'foo'});
33	35	print $res->as_string;
34	36
35	37	$_ = $res->as_string;
36	38
37		print "not " unless /WWW-Authenticate: Basic realm="foo3", foo=33/ &&
38		(/WWW-Authenticate: Digest nonce=bar, foo=foo/ \|\|
39		/WWW-Authenticate: Digest foo=foo, nonce=bar/);
40		print "ok 4\n";
	39	ok(/WWW-Authenticate: Basic realm="foo3", foo=33/);
	40	ok(/WWW-Authenticate: Digest nonce=bar, foo=foo/ \|\|
	41	/WWW-Authenticate: Digest foo=foo, nonce=bar/);


1		print "1..4\n";
	1	#!perl -w
2	2
	3	use strict;
	4	use Test;
	5
	6	plan tests => 4;
	7
3	8	require HTTP::Headers::ETag;
4	9
5		$h = HTTP::Headers->new;
	10	my $h = HTTP::Headers->new;
	11
6	12	$h->etag("tag1");
7		print "not " unless $h->etag eq qq("tag1");
8		print "ok 1\n";
	13	ok($h->etag, qq("tag1"));
9	14
10	15	$h->etag("w/tag2");
11		print "not " unless $h->etag eq qq(W/"tag2");
12		print "ok 2\n";
	16	ok($h->etag, qq(W/"tag2"));
13	17
14	18	$h->if_match(qq(W/"foo", bar, baz), "bar");
15	19	$h->if_none_match(333);
16	20
17	21	$h->if_range("tag3");
18		print "not " unless $h->if_range eq qq("tag3");
19		print "ok 3\n";
	22	ok($h->if_range, qq("tag3"));
20	23
21		$t = time;
	24	my $t = time;
22	25	$h->if_range($t);
23		print "not " unless $h->if_range == $t;
24		print "ok 4\n";
25
	26	ok($h->if_range, $t);
26	27
27	28	print $h->as_string;


	1	#!perl -w
	2
1	3	use strict;
	4	use Test;
	5
2	6	use HTTP::Headers::Util qw(split_header_words join_header_words);
3	7
4		my $extra_tests = 2;
5
6	8	my @s_tests = (
7	9
8	10	["foo" => "foo"],
…	…
28	28	'Basic; realm="\"foo\\\\bar\""'],
29	29	);
30	30
31		print "1..", @s_tests + $extra_tests, "\n";
	31	plan tests => @s_tests + 2;
32	32
33		my $testno = 1;
34
35		print "split_header_words() tests\n";
36	33	for (@s_tests) {
37	34	my($arg, $expect) = @$_;
38	35	my @arg = ref($arg) ? @$arg : $arg;
39	36
40	37	my $res = join_header_words(split_header_words(@arg));
41		if ($res ne $expect) {
42		print "\nUnexpected result: '$res'\n";
43		print " Expected: '$expect'\n";
44		print " when parsing '", join(", ", @arg), "'\n";
45		eval {
46		require Data::Dumper;
47		my @p = split_header_words(@arg);
48		print Data::Dumper::Dumper(\@p);
49		};
50		print "not ";
51		}
52		print "ok ", $testno++, "\n";
	38	ok($res, $expect);
53	39	}
54	40
55	41
56		print "Extra tests\n";
	42	print "# Extra tests\n";
57	43	# some extra tests
58		print "not " unless join_header_words("foo" => undef, "bar" => "baz")
59		eq "foo; bar=baz";
60		print "ok ", $testno++, "\n";
61
62		print "not " unless join_header_words() eq "";
63		print "ok ", $testno++, "\n";
	44	ok(join_header_words("foo" => undef, "bar" => "baz"), "foo; bar=baz");
	45	ok(join_header_words(), "");


1		#!./perl -w
	1	#!perl -w
2	2
3		print "1..16\n";
4
5	3	use strict;
	4	use Test;
	5
	6	plan tests => 34;
6	7	#use Data::Dump ();
7	8
8	9	my $CRLF = "\015\012";
…	…
120	120
121	121	#Data::Dump::dump($res);
122	122
123		print "not " unless $res->{code} eq "200" && $res->{content} eq "Hello\n";
124		print "ok 1\n";
	123	ok($res->{code}, 200);
	124	ok($res->{content}, "Hello\n");
125	125
126	126	$res = $h->request(GET => "/404");
127		print "not " unless $res->{code} eq "404";
128		print "ok 2\n";
	127	ok($res->{code}, 404);
129	128
130	129	$res = $h->request(TRACE => "/foo");
131		print "not " unless $res->{code} eq "200" &&
132		$res->{content} eq "TRACE /foo HTTP/1.1${CRLF}Keep-Alive: 300${CRLF}Connection: Keep-Alive${CRLF}Host: a${CRLF}${CRLF}";
133		print "ok 3\n";
	130	ok($res->{code}, 200);
	131	ok($res->{content}, "TRACE /foo HTTP/1.1${CRLF}Keep-Alive: 300${CRLF}Connection: Keep-Alive${CRLF}Host: a${CRLF}${CRLF}");
134	132
135	133	# try to turn off keep alive
136	134	$h->keep_alive(0);
137	135	$res = $h->request(TRACE => "/foo");
138		print "not " unless $res->{code} eq "200" &&
139		$res->{content} eq "TRACE /foo HTTP/1.1${CRLF}Connection: close${CRLF}Host: a${CRLF}${CRLF}";
140		print "ok 4\n";
	136	ok($res->{code}, "200");
	137	ok($res->{content}, "TRACE /foo HTTP/1.1${CRLF}Connection: close${CRLF}Host: a${CRLF}${CRLF}");
141	138
142	139	# try a bad one
143	140	$res = $h->request(GET => "/bad1", [], {laxed => 1});
144		print "not " unless $res->{code} eq "200" && $res->{message} eq "OK" &&
145		"@{$res->{headers}}" eq "Server foo Content-type text/foo" &&
146		$res->{content} eq "abc\n";
147		print "ok 5\n";
	141	ok($res->{code}, "200");
	142	ok($res->{message}, "OK");
	143	ok("@{$res->{headers}}", "Server foo Content-type text/foo");
	144	ok($res->{content}, "abc\n");
148	145
149	146	$res = $h->request(GET => "/bad1");
150		print "not " unless $res->{error} =~ /Bad header/ && !$res->{code};
151		print "ok 6\n";
	147	ok($res->{error} =~ /Bad header/);
	148	ok(!$res->{code});
152	149	$h = undef; # it is in a bad state now
153	150
154	151	$h = HTTP->new("a") \|\| die; # reconnect
155	152	$res = $h->request(GET => "/09", [], {laxed => 1});
156		print "not " unless $res->{code} eq "200" && $res->{message} eq "Assumed OK" &&
157		$res->{content} eq "Hello${CRLF}World!${CRLF}" &&
158		$h->peer_http_version eq "0.9";
159		print "ok 7\n";
	153	ok($res->{code}, "200");
	154	ok($res->{message}, "Assumed OK");
	155	ok($res->{content}, "Hello${CRLF}World!${CRLF}");
	156	ok($h->peer_http_version, "0.9");
160	157
161	158	$res = $h->request(GET => "/09");
162		print "not " unless $res->{error} =~ /^Bad response status line: 'Hello'/;
163		print "ok 8\n";
	159	ok($res->{error} =~ /^Bad response status line: 'Hello'/);
164	160	$h = undef; # it's in a bad state again
165	161
166	162	$h = HTTP->new(Host => "a", KeepAlive => 1, ReadChunkSize => 1) \|\| die; # reconnect
167	163	$res = $h->request(GET => "/chunked");
168		print "not " unless $res->{code} eq "200" && $res->{content} eq "Hello" &&
169		"@{$res->{headers}}" eq "Transfer-Encoding chunked Content-MD5 xxx";
170		print "ok 9\n";
	164	ok($res->{code}, 200);
	165	ok($res->{content}, "Hello");
	166	ok("@{$res->{headers}}", "Transfer-Encoding chunked Content-MD5 xxx");
171	167
172	168	# once more
173	169	$res = $h->request(GET => "/chunked");
174		print "not " unless $res->{code} eq "200" && $res->{content} eq "Hello" &&
175		"@{$res->{headers}}" eq "Transfer-Encoding chunked Content-MD5 xxx";
176		print "ok 10\n";
	170	ok($res->{code}, "200");
	171	ok($res->{content}, "Hello");
	172	ok("@{$res->{headers}}", "Transfer-Encoding chunked Content-MD5 xxx");
177	173
178	174	# test head
179	175	$res = $h->request(HEAD => "/head");
180		print "not " unless $res->{code} eq "200" && $res->{content} eq "" &&
181		"@{$res->{headers}}" eq "Content-Length 16 Content-Type text/plain";
182		print "ok 11\n";
	176	ok($res->{code}, "200");
	177	ok($res->{content}, "");
	178	ok("@{$res->{headers}}", "Content-Length 16 Content-Type text/plain");
183	179
184	180	$res = $h->request(GET => "/");
185		print "not " unless $res->{code} eq "200" && $res->{content} eq "Hello\n";
186		print "ok 12\n";
187		#use Data::Dump; Data::Dump::dump($res);
	181	ok($res->{code}, "200");
	182	ok($res->{content}, "Hello\n");
188	183
189
190	184	$h = HTTP->new(Host => undef, PeerAddr => "a", );
191	185	$h->http_version("1.0");
192		print "not " if defined $h->host;
193		print "ok 13\n";
	186	ok(!defined $h->host);
194	187	$res = $h->request(TRACE => "/");
195		print "not " unless $res->{code} eq "200" && $res->{content} eq "TRACE / HTTP/1.0\r\n\r\n";
196		print "ok 14\n";
	188	ok($res->{code}, "200");
	189	ok($res->{content}, "TRACE / HTTP/1.0\r\n\r\n");
197	190
198	191	# check that headers with colons at the start of values don't break
199	192	$res = $h->request(GET => '/colon-header');
200		print "not " unless "@{$res->{headers}}" eq "Content-Type text/plain Content-Length 6 Bad-Header :foo";
201		print "ok 15\n";
	193	ok("@{$res->{headers}}", "Content-Type text/plain Content-Length 6 Bad-Header :foo");
202	194
203	195	require Net::HTTP;
204	196	eval {
205	197	$h = Net::HTTP->new;
206	198	};
207	199	print "# $@";
208		print "not " unless $@;
209		print "ok 16\n";
	200	ok($@);


1		print "1..10\n";
	1	#!perl -w
2	2
	3	use Test;
	4	plan tests => 10;
3	5
4	6	use File::Listing;
5	7
…	…
53	53
54	54	@dir = parse_dir($dir, undef, 'unix');
55	55
56		print int(@dir) ." lines found\n";
57		@dir != 25 && print "not ";
58		print "ok 1\n";
	56	ok(@dir, 25);
59	57
60	58	for (@dir) {
61	59	($name, $type, $size, $mtime, $mode) = @$_;
62	60	$size \|\|= 0; # ensure that it is defined
63		printf "%-25s $type %6d ", $name, $size;
	61	printf "# %-25s $type %6d ", $name, $size;
64	62	print scalar(localtime($mtime));
65	63	printf " %06o", $mode;
66	64	print "\n";
…	…
67	67	# Pick out the Socket.pm line as the sample we check carefully
68	68	($name, $type, $size, $mtime, $mode) = @{$dir[9]};
69	69
70		$name eq "Socket.pm" \|\| print "not ";
71		print "ok 2\n";
	70	ok($name, "Socket.pm");
	71	ok($type, "f");
	72	ok($size, 8817);
72	73
73		$type eq "f" \|\| print "not ";
74		print "ok 3\n";
75
76		$size == 8817 \|\| print "not ";
77		print "ok 4\n";
78
79	74	# Must be careful when checking the time stamps because we don't know
80	75	# which year if this script lives for a long time.
81	76	$timestring = scalar(localtime($mtime));
82		$timestring =~ /Mar\s+15\s+18:05/ or print "not ";
83		print "ok 5\n";
	77	ok($timestring =~ /Mar\s+15\s+18:05/);
84	78
85		$mode == 0100644 \|\| print "not ";
86		print "ok 6\n";
	79	ok($mode, 0100644);
87	80
88	81	@dir = parse_dir(<<'EOT');
89	82	drwxr-xr-x 21 root root 704 2007-03-22 21:48 dir
90	83	EOT
91	84
92		print "not " unless @dir == 1;
93		print "ok 7\n";
	85	ok(@dir, 1);
	86	ok($dir[0][0], "dir");
	87	ok($dir[0][1], "d");
94	88
95		print "not " unless $dir[0][0] eq "dir";
96		print "ok 8\n";
97
98		print "not " unless $dir[0][1] eq "d";
99		print "ok 9\n";
100
101	89	$timestring = scalar(localtime($dir[0][3]));
102	90	print "# $timestring\n";
103		print "not " unless $timestring =~ /^Thu Mar 22 21:48/;
104		print "ok 10\n";
	91	ok($timestring =~ /^Thu Mar 22 21:48/);


	1	#!perl -w
	2
	3	use Test;
	4
1	5	use LWP::MediaTypes;
2	6
3	7	require URI::URL;
…	…
46	46	["x.ppm.Z.UU" => "image/x-portable-pixmap","compress","x-uuencode",],
47	47	);
48	48
49		$notests = @tests + 3;
50		print "1..$notests\n";
	49	plan tests => @tests * 3 + 4;
51	50
52	51	if ($ENV{HOME} and -f "$ENV{HOME}/.mime.types") {
53	52	warn "
…	…
56	56	}
57	57
58	58
59		$testno = 1;
60	59	for (@tests) {
61	60	($file, $expectedtype, @expectedEnc) = @$_;
62	61	$type1 = guess_media_type($file);
63	62	($type, @enc) = guess_media_type($file);
64		if ($type1 ne $type) {
65		print "guess_media_type does not return same content-type in scalar and array conext.\n";
66		next;
67		}
68		$type = "undef" unless defined $type;
69		if ($type eq $expectedtype and "@enc" eq "@expectedEnc") {
70		print "ok $testno\n";
71		}
72		else {
73		print "expected '$expectedtype' for '$file', got '$type'\n";
74		print "encoding: expected: '@expectedEnc', got '@enc'\n"
75		if @expectedEnc \|\| @enc;
76		print "nok ok $testno\n";
77		}
78		$testno++;
	63	ok($type1, $type);
	64	ok($type, $expectedtype);
	65	ok("@enc", "@expectedEnc");
79	66	}
80	67
81	68	@imgSuffix = media_suffix('image/*');
82		print "Image suffixes: @imgSuffix\n";
	69	print "# Image suffixes: @imgSuffix\n";
	70	ok(grep $_ eq "gif", @imgSuffix);
83	71
84		print "\n";
85	72	require HTTP::Response;
86	73	$r = new HTTP::Response 200, "Document follows";
87	74	$r->title("file.tar.gz.uu");
88	75	guess_media_type($r->title, $r);
89		print $r->as_string;
	76	#print $r->as_string;
90	77
91		print "not " unless $r->content_type eq "application/x-tar";
92		print "ok $testno\n"; $testno++;
	78	ok($r->content_type, "application/x-tar");
93	79
94	80	@enc = $r->header("Content-Encoding");
95		print "not " unless "@enc" eq "gzip x-uuencode";
96		print "ok $testno\n"; $testno++;
	81	ok("@enc", "gzip x-uuencode");
97	82
98	83	#
99	84	use LWP::MediaTypes qw(add_type add_encoding);
…	…
88	88
89	89	@x = guess_media_type("foo.vrml.r13.gz");
90	90	#print "@x\n";
91		print "not " unless "@x" eq "x-world/x-vrml rot13 x-gzip";
92		print "ok $testno\n"; $testno++;
	91	ok("@x", "x-world/x-vrml rot13 x-gzip");
93	92
94	93	#print LWP::MediaTypes::_dump();
95	94


1		print "1..5\n";
	1	#!perl -w
2	2
	3	use Test;
	4	plan tests => 5;
	5
3	6	use HTTP::Request;
4	7	use HTTP::Negotiate;
5	8
6	9
7		$no = 1;
8		sub ok
9		{
10		print "ok " . $no++ . "\n";
11		}
12
13		sub not_ok
14		{
15		print "not ";
16		ok;
17		}
18
19
20	10	# ID QS Content-Type Encoding Char-Set Lang Size
21	11	$variants =
22	12	[
…	…
30	30
31	31	$a = choose($variants, $request);
32	32	print "The chosen one is '$a'\n";
33		if ($a eq 'var2') {
34		ok;
35		}
36		else {
37		not_ok;
38		}
	33	ok($a, "var2");
39	34
40	35	#------------------
41	36
…	…
61	61
62	62	$a = choose($variants);
63	63
64		if ($a eq 'var-de') {
65		ok;
66		}
67		else {
68		not_ok
69		}
	64	ok($a, 'var-de');
70	65
71	66
72	67	$variants = [
…	…
72	72
73	73	$ENV{HTTP_ACCEPT_LANGUAGE}='en-US';
74	74	$a = choose($variants);
75		if ($a eq 'Generic English') {
76		ok;
77		}
78		else {
79		not_ok;
80		}
	75	ok($a, 'Generic English');
81	76
82	77	#------------------
83	78
…	…
88	88	($vb, $qb) = @$b;
89	89	if ($va ne $vb) {
90	90	print "$va == $vb ?\n";
91		not_ok;
	91	ok(0);
92	92	return;
93	93	}
94	94	if (abs($qa - $qb) > 0.002) {
95	95	print "$qa ~= $qb ?\n";
96		not_ok;
	96	ok(0);
97	97	return;
98	98	}
99	99	}
100	100
101	101	} until (!defined($a) \|\| !defined($b));
102		return not_ok if defined($a) ne defined($b);
103		ok;
	102	ok(defined($a), defined($b));
104	103	}
105	104
106	105	sub show_res


1		print "1..6\n";
	1	use Test;
	2	plan tests => 6;
2	3
3	4	use LWP::UserAgent;
4
5	5	$ua = LWP::UserAgent->new();
6	6
7	7	$ua->protocols_forbidden(['hTtP']);
8		print "not " unless scalar(@{$ua->protocols_forbidden()}) == 1;
9		print "ok 1\n";
	8	ok(scalar(@{$ua->protocols_forbidden()}), 1);
	9	ok(@{$ua->protocols_forbidden()}[0], 'hTtP');
10	10
11		print "not " unless @{$ua->protocols_forbidden()}[0] eq 'hTtP';
12		print "ok 2\n";
13
14	11	$response = $ua->get('http://www.cpan.org/');
	12	ok($response->is_error());
	13	ok(!$ua->is_protocol_supported('http'));
	14	ok(!$ua->protocols_allowed());
15	15
16		print "not " unless $response->is_error();
17		print "ok 3\n";
18
19		print "not " if $ua->is_protocol_supported('http');
20		print "ok 4\n";
21
22		print "not " if $ua->protocols_allowed();
23		print "ok 5\n";
24
25	16	$ua->protocols_forbidden(undef);
26
27		print "not " if $ua->protocols_forbidden();
28		print "ok 6\n";
	17	ok(!$ua->protocols_forbidden());


	1	#!perl -w
1	2
2	3	# Test extra HTTP::Response methods. Basic operation is tested in the
3	4	# message.t test suite.
4	5
	6	use strict;
	7	use Test;
	8	plan tests => 8;
5	9
6		print "1..8\n";
7
8
9	10	use HTTP::Date;
10	11	use HTTP::Request;
11	12	use HTTP::Response;
12	13
13	14	my $time = time;
14	15
15		$req = HTTP::Request->new(GET => 'http://www.sn.no');
	16	my $req = HTTP::Request->new(GET => 'http://www.sn.no');
16	17	$req->date($time - 30);
17	18
18		$r = new HTTP::Response 200, "OK";
	19	my $r = new HTTP::Response 200, "OK";
19	20	$r->client_date($time - 20);
20	21	$r->date($time - 25);
21	22	$r->last_modified($time - 5000000);
22	23	$r->request($req);
23	24
24		print $r->as_string;
	25	#print $r->as_string;
25	26
26		$current_age = $r->current_age;
	27	my $current_age = $r->current_age;
27	28
28		if ($current_age < 35 \|\| $current_age > 40) {
29		print "not ";
30		}
31		print "ok 1\n";
	29	ok($current_age >= 35 && $current_age <= 40);
32	30
33		$freshness_lifetime = $r->freshness_lifetime;
34		if ($freshness_lifetime < 12 * 3600) {
35		print "not ";
36		}
37		print "ok 2\n";
	31	my $freshness_lifetime = $r->freshness_lifetime;
	32	ok($freshness_lifetime >= 12 * 3600);
38	33
39		$is_fresh = $r->is_fresh;
	34	my $is_fresh = $r->is_fresh;
	35	ok($is_fresh);
40	36
41		print "not " unless $is_fresh;
42		print "ok 3\n";
43
44		print "current_age = $current_age\n";
45		print "freshness_lifetime = $freshness_lifetime\n";
46		print "response is ";
47		print "not " unless $is_fresh;
	37	print "# current_age = $current_age\n";
	38	print "# freshness_lifetime = $freshness_lifetime\n";
	39	print "# response is ";
	40	print " not " unless $is_fresh;
48	41	print "fresh\n";
49	42
50
51		print "it will be fresh is ";
	43	print "# it will be fresh for ";
52	44	print $freshness_lifetime - $current_age;
53	45	print " more seconds\n";
54	46
55	47	# OK, now we add an Expires header
56	48	$r->expires($time);
57		print $r->as_string;
	49	#print $r->as_string;
58	50
59	51	$freshness_lifetime = $r->freshness_lifetime;
60		print "freshness_lifetime = $freshness_lifetime\n";
61		print "not " unless $freshness_lifetime == 25;
62		print "ok 4\n";
	52	ok($freshness_lifetime, 25);
63	53	$r->remove_header('expires');
64	54
65	55	# Now we try the 'Age' header and the Cache-Contol:
66
67	56	$r->header('Age', 300);
68	57	$r->push_header('Cache-Control', 'junk');
69	58	$r->push_header(Cache_Control => 'max-age = 10');
70	59
71		print $r->as_string;
	60	#print $r->as_string;
72	61
73	62	$current_age = $r->current_age;
74	63	$freshness_lifetime = $r->freshness_lifetime;
75	64
76		print "current_age = $current_age\n";
77		print "freshness_lifetime = $freshness_lifetime\n";
	65	print "# current_age = $current_age\n";
	66	print "# freshness_lifetime = $freshness_lifetime\n";
78	67
79		print "not " if $current_age < 300;
80		print "ok 5\n";
	68	ok($current_age >= 300);
	69	ok($freshness_lifetime, 10);
81	70
82		print "not " if $freshness_lifetime != 10;
83		print "ok 6\n";
	71	ok($r->fresh_until); # should return something
84	72
85		print "not " unless $r->fresh_until; # should return something
86		print "ok 7\n";
87
88	73	my $r2 = HTTP::Response->parse($r->as_string);
89	74	my @h = $r2->header('Cache-Control');
90		print "not " unless scalar @h == 2;
91		print "ok 8\n"
	75	ok(@h, 2);


1		use HTTP::Status;
	1	#!perl -w
2	2
3		print "1..8\n";
	3	use Test;
	4	plan tests => 8;
4	5
5		200 == RC_OK \|\| print "not ";
6		print "ok 1\n";
	6	use HTTP::Status;
7	7
8		is_success(RC_ACCEPTED) \|\| print "not ";
9		print "ok 2\n";
	8	ok(RC_OK, 200);
10	9
11		is_error(RC_BAD_REQUEST) \|\| print "not ";
12		print "ok 3\n";
	10	ok(is_info(RC_CONTINUE));
	11	ok(is_success(RC_ACCEPTED));
	12	ok(is_error(RC_BAD_REQUEST));
	13	ok(is_redirect(RC_MOVED_PERMANENTLY));
13	14
14		is_redirect(RC_MOVED_PERMANENTLY) \|\| print "not ";
15		print "ok 4\n";
	15	ok(!is_success(RC_NOT_FOUND));
16	16
17		is_success(RC_NOT_FOUND) && print "not ";
18		print "ok 5\n";
19
20		$mess = status_message(0);
21
22		defined $mess && print "not ";
23		print "ok 6\n";
24
25		$mess = status_message(200);
26
27		if ($mess =~ /ok/i) {
28		print "ok 7\n";
29		}
30
31		is_info(RC_CONTINUE) \|\| print "not ";
32		print "ok 8\n";
	17	ok(status_message(0), undef);
	18	ok(status_message(200), "OK");


1		print "1..10\n";
	1	#!perl -w
2	2
3		use LWP::UserAgent;
	3	use strict;
	4	use Test;
4	5
5		$ua = LWP::UserAgent->new;
6		$clone = $ua->clone;
	6	plan tests => 10;
7	7
8		print "not " unless $ua->agent =~ /^libwww-perl/;
9		print "ok 1\n";
	8	use LWP::UserAgent;
10	9
	10	my $ua = LWP::UserAgent->new;
	11	my $clone = $ua->clone;
11	12
12		print "not " if defined $ua->proxy(ftp => "http://www.sol.no");
13		print "ok 2\n";
	13	ok($ua->agent =~ /^libwww-perl/);
	14	ok(!defined $ua->proxy(ftp => "http://www.sol.no"));
	15	ok($ua->proxy("ftp"), "http://www.sol.no");
14	16
15		print "not " unless $ua->proxy("ftp") eq "http://www.sol.no";
16		print "ok 3\n";
17
18		@a = $ua->proxy([qw(ftp http wais)], "http://proxy.foo.com");
19
	17	my @a = $ua->proxy([qw(ftp http wais)], "http://proxy.foo.com");
20	18	for (@a) { $_ = "undef" unless defined; }
21	19
22		print "not " unless "@a" eq "http://www.sol.no undef undef";
23		print "ok 4\n";
	20	ok("@a", "http://www.sol.no undef undef");
	21	ok($ua->proxy("http"), "http://proxy.foo.com");
	22	ok(ref($ua->default_headers), "HTTP::Headers");
24	23
25		print "not " unless $ua->proxy("http") eq "http://proxy.foo.com";
26		print "ok 5\n";
27
28		print "not " unless ref($ua->default_headers) eq "HTTP::Headers";
29		print "ok 6\n";
30
31	24	$ua->default_header("Foo" => "bar", "Multi" => [1, 2]);
32		print "not " unless $ua->default_headers->header("Foo") eq "bar";
33		print "ok 7\n";
	25	ok($ua->default_headers->header("Foo"), "bar");
	26	ok($ua->default_header("Foo"), "bar");
34	27
35		print "not " unless $ua->default_header("Foo") eq "bar";
36		print "ok 8\n";
37
38	28	# Try it
39	29	$ua->proxy(http => "loopback:");
40	30	$ua->agent("foo/0.1");
41	31
42		print "not " unless $ua->get("http://www.example.com", x => "y")->content eq <<EOT; print "ok 9\n";
	32	ok($ua->get("http://www.example.com", x => "y")->content, <<EOT);
43	33	GET http://www.example.com
44	34	User-Agent: foo/0.1
45	35	Foo: bar
…	…
39	39
40	40	EOT
41	41
42		print "not " unless (ref($clone->{proxy}) eq 'HASH');
43		print "ok 10\n";
	42	ok(ref($clone->{proxy}), 'HASH');


1		#!/usr/bin/perl
	1	#!perl -w
2	2
	3	use Test;
	4
3	5	use strict;
4	6	use File::Listing;
5	7	use LWP::Simple;
6	8
7		my $ok = 1;
8
9	9	# some sample URLs
10	10	my @urls = (
11	11	"http://www.apache.org/dist/apr/?C=N&O=D",
…	…
13	13	"http://stein.cshl.org/WWW/software/",
14	14	"http://www.cpan.org/modules/by-module/",
15	15	);
16		print "1.." . scalar(@urls) . "\n";
	16	plan tests => scalar(@urls);
17	17
18	18	for my $url (@urls) {
19	19	print "# $url\n";
20	20	my @listing = parse_dir(get($url),undef,"apache");
21		print "not " if @listing == 0;
22		print "ok " . $ok++ . "\n";
23		#require Data::Dumper; print Data::Dumper->Dump(["Listing for $url", \@listing],[]);
	21	ok(@listing);
24	22	}


1		print "1..1\n";
	1	#!perl -w
2	2
3	3	use strict;
	4	use Test;
	5	plan tests => 6;
	6
4	7	use Net::HTTP;
5	8
6	9
…	…
13	13	PeerHTTPVersion => "1.1",
14	14	MaxLineLength => 512) \|\| die "$@";
15	15
16		for (1..1) {
	16	for (1..2) {
17	17	$s->write_request(TRACE => "/libwww-perl",
18	18	'User-Agent' => 'Mozilla/5.0',
19	19	'Accept-Language' => 'no,en',
…	…
26	26	}
27	27	print "\n";
28	28
29		my $err;
30		$err++ unless $code eq "200";
31		$err++ unless $h{'Content-Type'} eq "message/http";
	29	ok($code, "200");
	30	ok($h{'Content-Type'}, "message/http");
32	31
33	32	my $buf;
34	33	while (1) {
…	…
38	38	}
39	39	$buf =~ s/\r//g;
40	40
41		$err++ unless $buf eq "TRACE /libwww-perl HTTP/1.1
	41	ok($buf, <<EOT);
	42	TRACE /libwww-perl HTTP/1.1
42	43	Host: www.apache.org
43	44	User-Agent: Mozilla/5.0
44	45	Accept-Language: no,en
45	46	Accept: /
46	47
47		";
48
49		print "not " if $err;
50		print "ok $_\n";
	48	EOT
51	49	}


1	1	#!perl -w
2	2
3	3	use strict;
	4	use Test;
	5
4	6	use LWP::UserAgent;
5	7
6	8	my $ua = LWP::UserAgent->new();
…	…
13	13	exit;
14	14	}
15	15
16		print "1..2\n";
17		print "not " unless $res->is_success;
18		print "ok 1\n";
19
20		print "not " unless $res->content =~ /Sun Microsystems/;
21		print "ok 2\n";
	16	plan tests => 2;
	17	ok($res->is_success);
	18	ok($res->content =~ /Sun Microsystems/);
22	19
23	20	my $cref = $res->content_ref;
24	21	substr($$cref, 100) = "..." if length($$cref) > 100;


1		print "1..3\n";
2
3	1	use strict;
	2	use Test;
	3
	4	plan tests => 5;
	5
4	6	use LWP::UserAgent;
5	7
6	8	my $ua = LWP::UserAgent->new(keep_alive => 1);
…	…
13	13
14	14	#print $res->as_string;
15	15
16		print "not " unless $res->code eq "401";
17		print "ok 1\n";
	16	ok($res->code, 401);
18	17
19	18	$req->authorization_basic('guest', 'guest');
20		$res = $ua->request($req);
	19	$res = $ua->simple_request($req);
21	20
	21	print $req->as_string, "\n";
	22
22	23	#print $res->as_string;
23		print "not " unless $res->code eq "200" && $res->content =~ /Your browser made it!/;
24		print "ok 2\n";
	24	ok($res->code, 200);
	25	ok($res->content =~ /Your browser made it!/);
25	26
26	27	{
27	28	package MyUA;
…	…
33	33
34	34	sub get_basic_credentials {
35	35	my($self,$realm, $uri, $proxy) = @_;
36		print "$realm/$uri/$proxy\n";
	36	#print "$realm/$uri/$proxy\n";
37	37	my $p = shift @try;
38		print join("/", @$p), "\n";
	38	#print join("/", @$p), "\n";
39	39	return @$p;
40	40	}
41	41
…	…
48	48
49	49	#print $res->as_string;
50	50
51		print "not " unless $res->content =~ /Your browser made it!/ &&
52		$res->header("Client-Response-Num") == 5;
53		print "ok 3\n";
	51	ok($res->content =~ /Your browser made it!/);
	52	ok($res->header("Client-Response-Num"), 5);


1		print "1..1\n";
2
3	1	use strict;
	2	use Test;
	3
	4	plan tests => 2;
	5
4	6	use LWP::UserAgent;
5	7
6	8	{
…	…
14	14
15	15	sub get_basic_credentials {
16	16	my($self,$realm, $uri, $proxy) = @_;
17		print "$realm/$uri/$proxy\n";
	17	print "$realm:$uri:$proxy => ";
18	18	my $p = shift @try;
19	19	print join("/", @$p), "\n";
20	20	return @$p;
…	…
29	29
30	30	#print $res->as_string;
31	31
32		print "not " unless $res->content =~ /Your browser made it!/ &&
33		$res->header("Client-Response-Num") == 5;
34		print "ok 1\n";
	32	ok($res->content =~ /Your browser made it!/);
	33	ok($res->header("Client-Response-Num"), 5);


26	26	exit;
27	27	}
28	28	$TMPDIR =~ tr\|\\\|/\|;
29		print "1..2\n";
30	29
	30	use Test;
	31	plan tests => 2;
	32
31	33	use LWP::Simple;
32	34	require LWP::Protocol::file;
33	35
…	…
39	39	# First we create the original
40	40	open(OUT, ">$orig") or die "Cannot open $orig: $!";
41	41	binmode(OUT);
42		for (1..100) {
	42	for (1..5) {
43	43	print OUT "This is line $_ of $orig\n";
44	44	}
45	45	close(OUT);
…	…
67	67
68	68	unlink($copy);
69	69
70		if ($origtext eq $copytext) {
71		print "ok 1\n";
72		}
73		else {
74		print "not ok 1\n";
75		}
	70	ok($copytext, $origtext);
76	71
77	72
78	73	# Test getstore() function
…	…
83	83	unlink($orig);
84	84	unlink($copy);
85	85
86		if ($origtext eq $copytext) {
87		print "ok 2\n";
88		}
89		else {
90		print "not ok 2\n";
91		}
	86	ok($copytext, $origtext);

Commit 9a23ea298c0c2154c9bfdd4b37677a4bbbe34c46

Gitorious