CGI-Lite-3.02.tar.gz: CGI-Lite-3.02/t/cookie.t

"Fossies" - the Fresh Open Source Software Archive

Member "CGI-Lite-3.02/t/cookie.t" (19 May 2018, 9657 Bytes) of package /linux/www/CGI-Lite-3.02.tar.gz:

As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "cookie.t":

3.01_vs_3.02.

1 # 2 #=============================================================================== 3 # 4 # FILE: cookie.t 5 # 6 # DESCRIPTION: Test of cookie parsing 7 # 8 # FILES: --- 9 # BUGS: --- 10 # NOTES: --- 11 # AUTHOR: Pete Houston (cpan@openstrike.co.uk) 12 # COMPANY: Openstrike 13 # CREATED: 20/05/14 16:12:33 14 # 15 # Updates: 16 # 25/08/2014 Now tests get_ordered_keys and print_data. 17 #=============================================================================== 18 19 use strict; 20 use warnings; 21 22 use Test::More tests => 264; # last test to print 23 24 use lib './lib'; 25 26 BEGIN { use_ok ('CGI::Lite') } 27 28 # Set up a CGI environment 29 $ENV{REQUEST_METHOD} = 'GET'; 30 $ENV{PATH_INFO} = '/somewhere/else'; 31 $ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else'; 32 $ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi'; 33 $ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; 34 $ENV{SERVER_PORT} = 8080; 35 $ENV{SERVER_NAME} = 'there.is.no.try.com'; 36 $ENV{QUERY_STRING} = ''; 37 38 my $cgi = CGI::Lite->new (); 39 my $cookies = $cgi->parse_cookies; 40 is ($cgi->is_error, 0, 'Cookie parse: no cookies, no error'); 41 is ($cookies, undef, 'Cookie parse: no cookies'); 42 43 $ENV{HTTP_COOKIE} = 'foo=bar; baz=quux'; 44 $cgi = CGI::Lite->new (); 45 $cookies = $cgi->parse_cookies; 46 my $testname = 'simple'; 47 48 is ($cgi->is_error, 0, "Cookie parse ($testname)"); 49 is (scalar keys %$cookies, 2, "Cookie count ($testname)"); 50 ok (exists $cookies->{foo}, "First cookie name ($testname)"); 51 is ($cookies->{foo}, 'bar', "First cookie value ($testname)"); 52 ok (exists $cookies->{baz}, "Second cookie name ($testname)"); 53 is ($cookies->{baz}, 'quux', "Second cookie value ($testname)"); 54 55 # And again but with a hash 56 $cgi = CGI::Lite->new (); 57 $testname = 'simple, return hash'; 58 my %cookies = $cgi->parse_cookies; 59 is ($cgi->is_error, 0, "Cookie parse ($testname)"); 60 is (scalar keys %cookies, 2, "Cookie count ($testname)"); 61 ok (exists $cookies{foo}, "First cookie name ($testname)"); 62 is ($cookies{foo}, 'bar', "First cookie value ($testname)"); 63 ok (exists $cookies{baz}, "Second cookie name ($testname)"); 64 is ($cookies{baz}, 'quux', "Second cookie value ($testname)"); 65 66 67 68 $ENV{HTTP_COOKIE} = ' foo=bar ; baz = quux '; 69 $cgi = CGI::Lite->new (); 70 $cookies = $cgi->parse_cookies; 71 $testname = 'extra space'; 72 73 is ($cgi->is_error, 0, "Cookie parse ($testname)"); 74 is (scalar keys %$cookies, 2, "Cookie count ($testname)"); 75 ok (exists $cookies->{foo}, "First cookie name ($testname)"); 76 is ($cookies->{foo}, 'bar', "First cookie value ($testname)"); 77 ok (exists $cookies->{baz}, "Second cookie name ($testname)"); 78 is ($cookies->{baz}, 'quux', "Second cookie value ($testname)"); 79 80 $ENV{HTTP_COOKIE} = 'foo=bar;baz=quux'; 81 $cgi = CGI::Lite->new (); 82 $cookies = $cgi->parse_cookies; 83 $testname = 'zero space'; 84 85 is ($cgi->is_error, 0, "Cookie parse ($testname)"); 86 is (scalar keys %$cookies, 2, "Cookie count ($testname)"); 87 ok (exists $cookies->{foo}, "First cookie name ($testname)"); 88 is ($cookies->{foo}, 'bar', "First cookie value ($testname)"); 89 ok (exists $cookies->{baz}, "Second cookie name ($testname)"); 90 is ($cookies->{baz}, 'quux', "Second cookie value ($testname)"); 91 92 $ENV{HTTP_COOKIE} = '%20foo%20=%20bar%20;b%20a%20z=qu%20ux'; 93 $cgi = CGI::Lite->new (); 94 $cookies = $cgi->parse_cookies; 95 $testname = 'interstitial space'; 96 97 is ($cgi->is_error, 0, "Cookie parse ($testname)"); 98 is (scalar keys %$cookies, 2, "Cookie count ($testname)"); 99 ok (exists $cookies->{' foo '}, "First cookie name ($testname)"); 100 is ($cookies->{' foo '}, ' bar ', "First cookie value ($testname)"); 101 ok (exists $cookies->{'b a z'}, "Second cookie name ($testname)"); 102 is ($cookies->{'b a z'}, 'qu ux', "Second cookie value ($testname)"); 103 104 my $ref = []; 105 $ref = $cgi->get_ordered_keys; 106 is_deeply ($ref, [' foo ', 'b a z'], 107 'get_ordered_keys arrayref for cookie data'); 108 my @ref = $cgi->get_ordered_keys; 109 is_deeply (\@ref, [' foo ', 'b a z'], 110 'get_ordered_keys array for cookie data'); 111 112 113 SKIP: { 114 my $tmpfile = 'tmpout-cookie'; 115 skip "No file created for stdout", 2 unless open my $tmp, '>', $tmpfile; 116 select $tmp; 117 $cgi->print_data; 118 close $tmp; 119 open $tmp, '<', $tmpfile; 120 chomp (my $printed = <$tmp>); 121 is ($printed, q# foo = bar #, 'print_data first cookie'); 122 chomp ($printed = <$tmp>); 123 is ($printed, q#b a z = qu ux#, 'print_data second cookie'); 124 close $tmp and unlink $tmpfile; 125 } 126 127 # Other url-escaped chars here 128 129 for my $special (33 .. 47, 58 .. 64, 91 .. 96, 123 .. 126) { 130 $ENV{HTTP_COOKIE} = sprintf 'a=%%%X;%%%X=1', $special, $special; 131 $cgi = CGI::Lite->new (); 132 $cookies = $cgi->parse_cookies; 133 $testname = "Special value ($ENV{HTTP_COOKIE})"; 134 is ($cgi->is_error, 0, "Cookie parse ($testname)"); 135 is (scalar keys %$cookies, 2, "Cookie count ($testname)"); 136 ok (exists $cookies->{'a'}, "First cookie name ($testname)"); 137 is ($cookies->{'a'}, chr($special), "First cookie value ($testname)"); 138 ok (exists $cookies->{chr($special)}, "Second cookie name ($testname)"); 139 is ($cookies->{chr($special)}, 1, "Second cookie value ($testname)"); 140 } 141 142 $ENV{HTTP_COOKIE} = '=bar'; 143 $cgi = CGI::Lite->new (); 144 $cookies = $cgi->parse_cookies; 145 $testname = 'Missing key'; 146 147 is ($cgi->is_error, 0, "Cookie parse ($testname)"); 148 is (scalar keys %$cookies, 1, "Cookie count ($testname)"); 149 ok (exists $cookies->{''}, "First cookie name ($testname)"); 150 is ($cookies->{''}, 'bar', "First cookie value ($testname)"); 151 152 # Bad cookies! 153 154 $ENV{HTTP_COOKIE} = 'f;o;o=b;a;r'; 155 $cgi = CGI::Lite->new (); 156 $cookies = $cgi->parse_cookies; 157 $testname = 'Extra semicolons'; 158 159 is ($cgi->is_error, 0, "Cookie parse ($testname)"); 160 is (scalar keys %$cookies, 4, "Cookie count ($testname)"); 161 ok (exists $cookies->{'o'}, "First cookie name ($testname)"); 162 is (ref $cookies->{'o'}, 'ARRAY', "First cookie ref ($testname)"); 163 is ($cookies->{'o'}->[0], '', "First cookie first elem ($testname)"); 164 is ($cookies->{'o'}->[1], 'b', "First cookie second elem ($testname)"); 165 166 $ENV{HTTP_COOKIE} = 'foo==bar'; 167 $cgi = CGI::Lite->new (); 168 $cookies = $cgi->parse_cookies; 169 $testname = 'Extra equals'; 170 171 is ($cgi->is_error, 0, "Cookie parse ($testname)"); 172 is (scalar keys %$cookies, 1, "Cookie count ($testname)"); 173 ok (exists $cookies->{'foo'}, "First cookie name ($testname)"); 174 is ($cookies->{'foo'}, '=bar', "First cookie value ($testname)"); 175 176 # Need to decide how strict the cookie validation should be. If strict, 177 # then these tests could be used. Leaving it lax for now. 178 # See eg. http://bugs.python.org/issue2193 179 # 180 #for my $char (split (//, '()<>@:\"/[]?={} ')) { 181 # 182 # $ENV{HTTP_COOKIE} = "f${char}o=bar"; 183 # $cgi = CGI::Lite->new (); 184 # $cookies = $cgi->parse_cookies; 185 # $testname = qq#Bad key char: "$char"#; 186 # 187 # is ($cgi->is_error, 1, "Cookie parse ($testname)"); 188 # is (scalar keys %$cookies, 0, "Cookie count ($testname)"); 189 # 190 # $ENV{HTTP_COOKIE} = "foo=b${char}r"; 191 # $cgi = CGI::Lite->new (); 192 # $cookies = $cgi->parse_cookies; 193 # $testname = qq#Bad value char: "$char"#; 194 # 195 # is ($cgi->is_error, 1, "Cookie parse ($testname)"); 196 # is (scalar keys %$cookies, 0, "Cookie count ($testname)"); 197 # 198 #} 199 # 200 # What about multiple cookies with the same name? 201 # cookie o is actually an arrayref, which is neat, but does it match the 202 # RFC? 203 #ok (exists $cookies->{'b a z'}, "Second cookie name ($testname)"); 204 #is ($cookies->{'b a z'}, 'qu ux', "Second cookie value ($testname)"); 205 206 $ENV{HTTP_COOKIE} = 'foo=bar;foo=baz;foo=quux'; 207 $cgi = CGI::Lite->new (); 208 $cookies = $cgi->parse_cookies; 209 $testname = 'triple value'; 210 211 is ($cgi->is_error, 0, "Cookie parse ($testname)"); 212 is (scalar keys %$cookies, 1, "Cookie count ($testname)"); 213 ok (exists $cookies->{foo}, "First cookie name ($testname)"); 214 is ($cookies->{foo}->[0], 'bar', "First cookie value ($testname)"); 215 is ($cookies->{foo}->[1], 'baz', "First cookie value ($testname)"); 216 is ($cookies->{foo}->[2], 'quux', "First cookie value ($testname)"); 217 218 219 $cgi = CGI::Lite->new (); 220 is ($cgi->force_unique_cookies(), 0, "force_unique_cookies undef arg"); 221 is ($cgi->force_unique_cookies('foo'), 0, "force_unique_cookies string arg"); 222 is ($cgi->force_unique_cookies(100), 0, "force_unique_cookies arg > 3"); 223 is ($cgi->force_unique_cookies(1), 1, "force_unique_cookies arg == 1"); 224 $cookies = $cgi->parse_cookies; 225 $testname = 'unique, take first'; 226 is ($cgi->is_error, 0, "Cookie parse ($testname)"); 227 is (scalar keys %$cookies, 1, "Cookie count ($testname)"); 228 ok (exists $cookies->{foo}, "Cookie name ($testname)"); 229 is ($cookies->{foo}, 'bar', "Cookie value ($testname)"); 230 231 $cgi = CGI::Lite->new (); 232 is ($cgi->force_unique_cookies(2), 2, "force_unique_cookies arg == 2"); 233 $cookies = $cgi->parse_cookies; 234 $testname = 'unique, take last'; 235 is ($cgi->is_error, 0, "Cookie parse ($testname)"); 236 is (scalar keys %$cookies, 1, "Cookie count ($testname)"); 237 ok (exists $cookies->{foo}, "Cookie name ($testname)"); 238 is ($cookies->{foo}, 'quux', "Cookie value ($testname)"); 239 240 $cgi = CGI::Lite->new (); 241 is ($cgi->force_unique_cookies(3), 3, "force_unique_cookies arg == 3"); 242 $cookies = $cgi->parse_cookies; 243 $testname = 'unique, raise error'; 244 is ($cgi->is_error, 1, "Cookie parse ($testname)"); 245