Commit aa20e7a31311288127cc70d629e9e658e667a2c7 - libhttp-cookiejar-perl

dump/load_cookies without save/load to file David Golden 11 years ago

2 changed file(s) with 38 addition(s) and 30 deletion(s). Raw diff Collapse all Expand all

+11

-19

lib/HTTP/CookieJar.pm less more

4	4	package HTTP::CookieJar;
5	5	# ABSTRACT: A minimalist HTTP user agent cookie jar
6	6	# VERSION
7
8		use Path::Tiny ();
9	7
10	8	sub new {
11	9	my ($class) = @_;

27	25	# XXX doesn't check for public suffixes; see Mozilla::PublicSuffix
28	26	if ( exists $parse->{domain} ) {
29	27	return unless _domain_match( $host, $parse->{domain} );
30		$parse->{hostonly} = 0;
31	28	}
32	29	else {
33	30	$parse->{domain} = $host;

42	39	# set timestamps and normalize expires
43	40	my $now = $parse->{creation_time} = $parse->{last_access_time} = time;
44	41	if ( exists $parse->{'max-age'} ) {
45		$parse->{expires} = $now + $parse->{'max-age'};
	42	$parse->{expires} = $now + delete $parse->{'max-age'};
46	43	}
47	44	# update creation time from old cookie, if exists
48	45	if ( my $old = $self->{store}{$domain}{$path}{$name} ) {

89	86	}
90	87
91	88	# generate as list that can be fed back in to add
92		sub as_list {
	89	sub dump_cookies {
93	90	my ( $self, $args ) = @_;
94	91	my @list;
95	92	for my $c ( $self->_all_cookies ) {
96		next if $args->{persistent} && !defined $c->{expires};
97	93	my @parts = "$c->{name}=$c->{value}";
98		for my $attr (qw/Domain Path Expires Creation_Time Last_Access_Time/) {
	94	if ( defined $c->{expires} ) {
	95	push @parts, 'Expires=' . _http_date($c->{expires});
	96	} else {
	97	next if $args->{persistent};
	98	}
	99	for my $attr (qw/Domain Path Creation_Time Last_Access_Time/) {
99	100	push @parts, "$attr=$c->{lc $attr}" if defined $c->{ lc $attr };
100	101	}
101	102	for my $attr (qw/Secure HttpOnly HostOnly/) {

106	107	return @list;
107	108	}
108	109
109		sub from_list {
	110	# returns self
	111	sub load_cookies {
110	112	my ( $self, @cookies ) = @_;
111	113	for my $cookie ( @cookies ) {
112	114	my $p = _parse_cookie($cookie, 1);
	115	next unless exists $p->{domain} && exists $p->{path};
113	116	$p->{$_} //= time for qw/creation_time last_access_time/;
114	117	$self->{store}{ $p->{domain} }{ $p->{path} }{ $p->{name} } = $p;
115	118	}
116		return;
117		}
118
119		sub save {
120		my ( $self, $filename ) = @_;
121		Path::Tiny::path($filename)->spew( join( "\n", $self->as_list ) );
122		}
123
124		sub load {
125		my ( $self, $filename ) = @_;
126		$self->from_list( Path::Tiny::path($filename)->lines( { chomp => 1 } ) );
127	119	return $self;
128	120	}
129	121

+27

-11

t/save.t less more

2	2	use warnings;
3	3	use Test::More 0.96;
4	4	use Test::Deep '!blessed';
5		use Path::Tiny;
6	5
7	6	use HTTP::CookieJar;
8	7

13	12	'SID=31d4d96e407aad42; Path=/; Secure; HttpOnly',
14	13	);
15	14
16		my $file = Path::Tiny->tempfile;
	15	my @persistent = (
	16	'lang=en_US; Path=/; Domain=example.com; Secure; HttpOnly; Max-Age = 3600',
	17	);
17	18
18	19	subtest "empty cookie jar" => sub {
19	20	my $jar = HTTP::CookieJar->new;
20		ok( $jar->save("$file"), "save cookie jar");
21		ok( my $jar2 = HTTP::CookieJar->new->load("$file"), "load cookie jar" );
22		is( scalar $jar2->_all_cookies, 0, "jar is empty" );
	21	my @list = $jar->dump_cookies;
	22	is( scalar @list, 0, "dumped zero cookies" );
	23	ok( my $jar2 = HTTP::CookieJar->new->load_cookies(@list), "load new cookie jar" );
	24	is( scalar $jar2->dump_cookies, 0, "second jar is empty" );
23	25	};
24	26
25	27	subtest "roundtrip" => sub {
26	28	my $jar = HTTP::CookieJar->new;
27		$jar->add("http://www.example.com/", $_) for @cookies;
28		ok( $jar->save("$file"), "save cookie jar");
29		ok( my $jar2 = HTTP::CookieJar->new->load("$file"), "load cookie jar" );
30		is( scalar $jar2->_all_cookies, 1, "jar has a cookie" );
31		cmp_deeply( $jar, $jar2, "old and new jars are the same" );
	29	$jar->add("http://www.example.com/", $_) for @cookies, @persistent;
	30	my @list = $jar->dump_cookies;
	31	is( scalar @list, @cookies + @persistent, "dumped correct number of cookies" );
	32	ok( my $jar2 = HTTP::CookieJar->new->load_cookies(@list), "load new cookie jar" );
	33	is( scalar $jar2->dump_cookies, @cookies+@persistent, "second jar has correct count" );
	34	cmp_deeply( $jar, $jar2, "old and new jars are the same" ) or diag explain [$jar, $jar2];
32	35	};
33	36
34		# test cookie jar load without private stuff
	37	subtest "persistent" => sub {
	38	my $jar = HTTP::CookieJar->new;
	39	$jar->add("http://www.example.com/", $_) for @cookies, @persistent;
	40	my @list = $jar->dump_cookies({persistent => 1});
	41	is( scalar @list, @cookies, "dumped correct number of cookies" );
	42	ok( my $jar2 = HTTP::CookieJar->new->load_cookies(@list), "load new cookie jar" );
	43	is( scalar $jar2->dump_cookies, @cookies, "second jar has correct count" );
	44	};
35	45
	46	# can load raw cookies with both path and domain
	47	subtest "liberal load" => sub {
	48	my $jar = HTTP::CookieJar->new;
	49	ok( $jar->load_cookies(@persistent, @cookies), "load_cookies with raw cookies" );
	50	is( scalar $jar->dump_cookies, @persistent, "jar has correct count" );
	51	};
36	52
37	53	done_testing;
38	54	# COPYRIGHT