@@ -4,7 +4,6 @@ use Test::Fatal;
44use Test::More;
55
66BEGIN {
7-
87 # Freeze time at Tue, 15-Jun-2010 00:00:00 GMT
98 *CORE::GLOBAL::time = sub { return 1276560000 }
109}
@@ -15,78 +14,77 @@ use Dancer2::Core::Request;
1514diag " If you want extra speed, install HTTP::XSCookies"
1615 if !Dancer2::Core::Cookie::_USE_XS;
1716
18- sub run_test {
19-
20- note " Constructor" ;
21-
22- my $cookie = Dancer2::Core::Cookie-> new( name => " foo" );
23-
24- isa_ok $cookie => ' Dancer2::Core::Cookie' ;
25- can_ok $cookie => ' to_header' ;
26-
27-
28- note " Setting values" ;
29-
30- is $cookie -> value(" foo" ) => " foo" , " Can set value" ;
31- is $cookie -> value => " foo" , " Set value stuck" ;
32-
33- is $cookie . " bar" , " foobar" , " Stringifies to desired value" ;
34-
35- ok $cookie -> value( [qw( a b c) ] ), " can set multiple values" ;
36- is $cookie -> value => ' a' , " get first value in scalar context" ;
37- is_deeply [ $cookie -> value ] => [qw( a b c) ],
38- " get all values in list context" ;;
39-
40- ok $cookie -> value( { x => 1, y => 2 } ), " can set values with a hashref" ;
41- like $cookie -> value => qr / ^[xy]$ / ; # hashes doesn't store order...
42- is_deeply [ sort $cookie -> value ] => [ sort ( 1, 2, ' x' , ' y' ) ];
43-
44-
45- note " accessors and defaults" ;
46-
47- is $cookie -> name => ' foo' , " name is as expected" ;
48- is $cookie -> name(" bar" ) => " bar" , " can change name" ;
49- is $cookie -> name => ' bar' , " name change stuck" ;
50-
51- ok !$cookie -> domain, " no domain set by default" ;
52- is $cookie -> domain(" dancer.org" ) => " dancer.org" ,
53- " setting domain returns new value" ;
54- is $cookie -> domain => " dancer.org" ,
55- " new domain valjue stuck" ;
56- is $cookie -> domain(" " ) => " " , " can clear domain" ;
57- ok !$cookie -> domain, " no domain set now" ;
58-
59- is $cookie -> path => ' /' , " by default, path is /" ;
60- ok $cookie -> has_path, " has_path" ;
61- is $cookie -> path(" /foo" ) => " /foo" , " setting path returns new value" ;
62- ok $cookie -> has_path, " has_path" ;
63- is $cookie -> path => " /foo" , " new path stuck" ;
64-
65- ok !$cookie -> secure, " no cookie secure flag by default" ;
66- is $cookie -> secure(1) => 1, " enabling \$ cookie->secure returns new value" ;
67- is $cookie -> secure => 1, " \$ cookie->secure flag is enabled" ;
68- is $cookie -> secure(0) => 0, " disabling \$ cookie->secure returns new value" ;
69- ok !$cookie -> secure, " \$ cookie->secure flag is disabled" ;
17+ subtest ' with HTTP::XSCookies' => \&all_tests
18+ if Dancer2::Core::Cookie::_USE_XS;
7019
71- ok $cookie -> http_only, " http_only by default" ;
72- is $cookie -> http_only(0) => 0,
73- " disabling \$ cookie->http_only returns new value" ;
74- ok !$cookie -> http_only,
75- " \$ cookie->http_only is now disabled" ;
20+ if ( Dancer2::Core::Cookie::_USE_XS ) {
21+ no warnings ' redefine' ;
22+ *Dancer2::Core::Cookie::to_header = \&Dancer2::Core::Cookie::pp_to_header;
23+ }
7624
77- like exception { $cookie -> same_site( ' foo ' ) },
78- qr / Value "foo" did not pass type constraint "Enum \[ "Strict","Lax","None" \] / ;
25+ subtest ' w/o HTTP::XSCookies ' => \&all_tests
26+ if Dancer2::Core::Cookie::_USE_XS ;
7927
80- note " expiration strings" ;
28+ sub all_tests {
29+ my $cookie = Dancer2::Core::Cookie-> new( name => " foo" );
8130
82- my $min = 60;
83- my $hour = 60 * $min ;
84- my $day = 24 * $hour ;
85- my $week = 7 * $day ;
86- my $mon = 30 * $day ;
87- my $year = 365 * $day ;
31+ subtest " Constructor" => sub {
32+ isa_ok $cookie => ' Dancer2::Core::Cookie' ;
33+ can_ok $cookie => ' to_header' ;
34+ };
35+
36+ subtest " Setting values" => sub {
37+ is $cookie -> value(" foo" ) => " foo" , " Can set value" ;
38+ is $cookie -> value => " foo" , " Set value stuck" ;
39+
40+ is $cookie . " bar" , " foobar" , " Stringifies to desired value" ;
41+
42+ ok $cookie -> value( [qw( a b c) ] ), " can set multiple values" ;
43+ is $cookie -> value => ' a' , " get first value in scalar context" ;
44+ is_deeply [ $cookie -> value ] => [qw( a b c) ],
45+ " get all values in list context" ;;
46+
47+ ok $cookie -> value( { x => 1, y => 2 } ), " can set values with a hashref" ;
48+ like $cookie -> value => qr / ^[xy]$ / ; # hashes doesn't store order...
49+ is_deeply [ sort $cookie -> value ] => [ sort ( 1, 2, ' x' , ' y' ) ];
50+ };
51+
52+
53+ subtest " accessors and defaults" => sub {
54+ is $cookie -> name => ' foo' , " name is as expected" ;
55+ is $cookie -> name(" bar" ) => " bar" , " can change name" ;
56+ is $cookie -> name => ' bar' , " name change stuck" ;
57+
58+ ok !$cookie -> domain, " no domain set by default" ;
59+ is $cookie -> domain(" dancer.org" ) => " dancer.org" ,
60+ " setting domain returns new value" ;
61+ is $cookie -> domain => " dancer.org" ,
62+ " new domain valjue stuck" ;
63+ is $cookie -> domain(" " ) => " " , " can clear domain" ;
64+ ok !$cookie -> domain, " no domain set now" ;
65+
66+ is $cookie -> path => ' /' , " by default, path is /" ;
67+ ok $cookie -> has_path, " has_path" ;
68+ is $cookie -> path(" /foo" ) => " /foo" , " setting path returns new value" ;
69+ ok $cookie -> has_path, " has_path" ;
70+ is $cookie -> path => " /foo" , " new path stuck" ;
71+
72+ ok !$cookie -> secure, " no cookie secure flag by default" ;
73+ is $cookie -> secure(1) => 1, " enabling \$ cookie->secure returns new value" ;
74+ is $cookie -> secure => 1, " \$ cookie->secure flag is enabled" ;
75+ is $cookie -> secure(0) => 0, " disabling \$ cookie->secure returns new value" ;
76+ ok !$cookie -> secure, " \$ cookie->secure flag is disabled" ;
77+
78+ ok $cookie -> http_only, " http_only by default" ;
79+ is $cookie -> http_only(0) => 0,
80+ " disabling \$ cookie->http_only returns new value" ;
81+ ok !$cookie -> http_only,
82+ " \$ cookie->http_only is now disabled" ;
83+
84+ like exception { $cookie -> same_site(' foo' ) },
85+ qr / Value "foo" did not pass type constraint "Enum\[ "Strict","Lax","None"\] / ;
86+ };
8887
89- ok !$cookie -> expires;
9088 my %times = (
9189 " +2" => " Tue, 15-Jun-2010 00:00:02 GMT" ,
9290 " +2h" => " Tue, 15-Jun-2010 02:00:00 GMT" ,
@@ -110,98 +108,100 @@ sub run_test {
110108 " +2 something" => " +2 something" ,
111109 );
112110
113- for my $exp ( keys %times ) {
114- my $want = $times {$exp };
115-
116- $cookie -> expires($exp );
117- is $cookie -> expires => $want , " expiry $exp => $want " ;;
118- }
119-
120-
121- note " to header" ;
122-
123- my @cake = (
124- { cookie => {
125- name => ' bar' ,
126- value => ' foo' ,
127- expires => ' +2h' ,
128- secure => 1
111+ subtest " expiration strings" => sub {
112+ my $min = 60;
113+ my $hour = 60 * $min ;
114+ my $day = 24 * $hour ;
115+ my $week = 7 * $day ;
116+ my $mon = 30 * $day ;
117+ my $year = 365 * $day ;
118+
119+ ok !$cookie -> expires;
120+
121+ for my $exp ( keys %times ) {
122+ my $want = $times {$exp };
123+
124+ $cookie -> expires($exp );
125+ is $cookie -> expires => $want , " expiry $exp => $want " ;;
126+ }
127+ };
128+
129+ subtest " to header" => sub {
130+
131+ my @cake = (
132+ { cookie => {
133+ name => ' bar' ,
134+ value => ' foo' ,
135+ expires => ' +2h' ,
136+ secure => 1
137+ },
138+ expected => sprintf (
139+ " bar=foo; Expires=%s ; HttpOnly; Path=/; Secure" ,
140+ $times {' +2h' },
141+ ),
129142 },
130- expected => sprintf (
131- " bar=foo; Expires=%s ; HttpOnly; Path=/; Secure" ,
132- $times {' +2h' },
133- ),
134- },
135- { cookie => {
136- name => ' bar' ,
137- value => ' foo' ,
138- domain => ' dancer.org' ,
139- path => ' /dance' ,
140- http_only => 1
143+ { cookie => {
144+ name => ' bar' ,
145+ value => ' foo' ,
146+ domain => ' dancer.org' ,
147+ path => ' /dance' ,
148+ http_only => 1
149+ },
150+ expected => " bar=foo; Domain=dancer.org; HttpOnly; Path=/dance" ,
141151 },
142- expected => " bar=foo; Domain=dancer.org; HttpOnly; Path=/dance " ,
143- } ,
144- { cookie => {
145- name => ' bar ' ,
146- value => ' foo' ,
152+ { cookie => {
153+ name => ' bar ' ,
154+ value => ' foo ' ,
155+ } ,
156+ expected => " bar= foo; HttpOnly; Path=/ " ,
147157 },
148- expected => " bar=foo; HttpOnly; Path=/ " ,
149- } ,
150- { cookie => {
151- name => ' bar ' ,
152- value => ' foo ' ,
153- http_only => 0 ,
158+ { cookie => {
159+ name => ' bar ' ,
160+ value => ' foo ' ,
161+ http_only => 0 ,
162+ } ,
163+ expected => " bar=foo; Path=/ " ,
154164 },
155- expected => " bar=foo; Path=/ " ,
156- } ,
157- { cookie => {
158- name => ' bar ' ,
159- value => ' foo ' ,
160- http_only => ' 0 ' ,
165+ { cookie => {
166+ name => ' bar ' ,
167+ value => ' foo ' ,
168+ http_only => ' 0 ' ,
169+ } ,
170+ expected => " bar=foo; Path=/ " ,
161171 },
162- expected => " bar=foo; Path=/ " ,
163- } ,
164- { cookie => {
165- name => ' same-site ' ,
166- value => ' strict ' ,
167- same_site => ' Strict' ,
172+ { cookie => {
173+ name => ' same-site ' ,
174+ value => ' strict ' ,
175+ same_site => ' Strict ' ,
176+ } ,
177+ expected => ' same-site=strict; HttpOnly; Path=/; SameSite= Strict' ,
168178 },
169- expected => ' same-site=strict; HttpOnly; Path=/; SameSite=Strict ' ,
170- } ,
171- { cookie => {
172- name => ' same-site ' ,
173- value => ' lax ' ,
174- same_site => ' Lax' ,
179+ { cookie => {
180+ name => ' same-site ' ,
181+ value => ' lax ' ,
182+ same_site => ' Lax ' ,
183+ } ,
184+ expected => ' same-site=lax; HttpOnly; Path=/; SameSite= Lax' ,
175185 },
176- expected => ' same-site=lax; HttpOnly; Path=/; SameSite=Lax' ,
177- },
178- );
179-
180- for my $cook (@cake ) {
181- my $c = Dancer2::Core::Cookie-> new(%{$cook -> {cookie }});
182- # name=value; sorted fields
183- my @a = split /; /, $c -> to_header;
184- is join (" ; " , shift @a , sort @a ), $cook -> {expected };
185- }
186-
187- note ' multi-value' ;
186+ );
188187
189- my $c = Dancer2::Core::Cookie-> new( name => ' foo' , value => [qw/ bar baz/ ] );
188+ for my $cook (@cake ) {
189+ my $c = Dancer2::Core::Cookie-> new(%{$cook -> {cookie }});
190+ # name=value; sorted fields
191+ my @a = split /; /, $c -> to_header;
192+ is join (" ; " , shift @a , sort @a ), $cook -> {expected };
193+ }
194+ };
190195
191- is $c -> to_header, ' foo=bar&baz; Path=/; HttpOnly' ;
196+ subtest ' multi-value' => sub {
197+ my $c = Dancer2::Core::Cookie-> new( name => ' foo' , value => [qw/ bar baz/ ] );
192198
193- my $r = Dancer2::Core::Request -> new( env => { HTTP_COOKIE => ' foo=bar&baz' } ) ;
199+ is $c -> to_header, ' foo=bar&baz; Path=/; HttpOnly ' ;
194200
195- is_deeply [ $r -> cookies-> {foo }-> value ], [qw/ bar baz/ ];
196- }
201+ my $r = Dancer2::Core::Request-> new( env => { HTTP_COOKIE => ' foo=bar&baz' } );
197202
198- note " Run test with XS_HTTP_COOKIES" if Dancer2::Core::Cookie::_USE_XS;
199- run_test();
200- if ( Dancer2::Core::Cookie::_USE_XS ) {
201- note " Run test without XS_HTTP_COOKIES" ;
202- no warnings ' redefine' ;
203- *Dancer2::Core::Cookie::to_header = \&Dancer2::Core::Cookie::pp_to_header;
204- run_test();
203+ is_deeply [ $r -> cookies-> {foo }-> value ], [qw/ bar baz/ ];
204+ };
205205}
206206
207207done_testing;
0 commit comments