2 use warnings FATAL => 'all';
4 use Test::More qw(no_plan);
6 use Web::Simple::DispatchParser;
8 my $dp = Web::Simple::DispatchParser->new;
10 my $get = $dp->parse_dispatch_specification('GET');
13 [ $get->({ REQUEST_METHOD => 'GET' }) ],
19 [ $get->({ REQUEST_METHOD => 'POST' }) ],
25 !eval { $dp->parse_dispatch_specification('GET POST'); 1; },
26 "Don't yet allow two methods"
29 my $html = $dp->parse_dispatch_specification('.html');
32 [ $html->({ PATH_INFO => '/foo/bar.html' }) ],
33 [ { PATH_INFO => '/foo/bar' } ],
38 [ $html->({ PATH_INFO => '/foo/bar.xml' }) ],
40 '.xml does not match .html'
43 my $any_ext = $dp->parse_dispatch_specification('.*');
46 [ $any_ext->({ PATH_INFO => '/foo/bar.html' }) ],
47 [ { PATH_INFO => '/foo/bar' }, 'html' ],
48 '.html matches .* and extension returned'
52 [ $any_ext->({ PATH_INFO => '/foo/bar' }) ],
54 'no extension does not match .*'
58 my $slash = $dp->parse_dispatch_specification('/');
61 [ $slash->({ PATH_INFO => '/' }) ],
67 [ $slash->({ PATH_INFO => '/foo' }) ],
69 '/foo does not match /'
72 my $post = $dp->parse_dispatch_specification('/post/*');
75 [ $post->({ PATH_INFO => '/post/one' }) ],
77 '/post/one parses out one'
81 [ $post->({ PATH_INFO => '/post/one/' }) ],
83 '/post/one/ does not match'
86 my $combi = $dp->parse_dispatch_specification('GET+/post/*');
89 [ $combi->({ PATH_INFO => '/post/one', REQUEST_METHOD => 'GET' }) ],
91 '/post/one parses out one'
95 [ $combi->({ PATH_INFO => '/post/one/', REQUEST_METHOD => 'GET' }) ],
97 '/post/one/ does not match'
101 [ $combi->({ PATH_INFO => '/post/one', REQUEST_METHOD => 'POST' }) ],
103 'POST /post/one does not match'
106 my $or = $dp->parse_dispatch_specification('GET|POST');
108 foreach my $meth (qw(GET POST)) {
111 [ $or->({ REQUEST_METHOD => $meth }) ],
113 'GET|POST matches method '.$meth
118 [ $or->({ REQUEST_METHOD => 'PUT' }) ],
120 'GET|POST does not match PUT'
123 $or = $dp->parse_dispatch_specification('GET|POST|DELETE');
125 foreach my $meth (qw(GET POST DELETE)) {
128 [ $or->({ REQUEST_METHOD => $meth }) ],
130 'GET|POST|DELETE matches method '.$meth
135 [ $or->({ REQUEST_METHOD => 'PUT' }) ],
137 'GET|POST|DELETE does not match PUT'
140 my $nest = $dp->parse_dispatch_specification('(GET+/foo)|POST');
143 [ $nest->({ PATH_INFO => '/foo', REQUEST_METHOD => 'GET' }) ],
145 '(GET+/foo)|POST matches GET /foo'
149 [ $nest->({ PATH_INFO => '/bar', REQUEST_METHOD => 'GET' }) ],
151 '(GET+/foo)|POST does not match GET /bar'
155 [ $nest->({ PATH_INFO => '/bar', REQUEST_METHOD => 'POST' }) ],
157 '(GET+/foo)|POST matches POST /bar'
161 [ $nest->({ PATH_INFO => '/foo', REQUEST_METHOD => 'PUT' }) ],
163 '(GET+/foo)|POST does not match PUT /foo'
169 !eval { $dp->parse_dispatch_specification('/foo+(GET'); 1 },
170 'Death with missing closing )'
176 (s/^\n//s,s/\n $//s,s/^ //mg) for $err;
180 "Error $@ matches\n${err}\n"
184 my $not = $dp->parse_dispatch_specification('!.html+.*');
187 [ $not->({ PATH_INFO => '/foo.xml' }) ],
188 [ { PATH_INFO => '/foo' }, 'xml' ],
189 '!.html+.* matches /foo.xml'
193 [ $not->({ PATH_INFO => '/foo.html' }) ],
195 '!.html+.* does not match /foo.html'
199 [ $not->({ PATH_INFO => '/foo' }) ],
201 '!.html+.* does not match /foo'
204 my $sub = $dp->parse_dispatch_specification('/foo/*/...');
207 [ $sub->({ PATH_INFO => '/foo/1/bar' }) ],
208 [ { PATH_INFO => '/bar' }, 1 ],
209 '/foo/*/... matches /foo/1/bar and strips to /bar'
213 [ $sub->({ PATH_INFO => '/foo/1/' }) ],
214 [ { PATH_INFO => '/' }, 1 ],
215 '/foo/*/... matches /foo/1/bar and strips to /'
219 [ $sub->({ PATH_INFO => '/foo/1' }) ],
221 '/foo/*/... does not match /foo/1 (no trailing /)'
224 my $q = 'foo=FOO&bar=BAR1&baz=one+two&quux=QUUX1&quux=QUUX2'
225 .'&bar=BAR2&quux=QUUX3&evil=%2F';
237 bar => [ qw(BAR1 BAR2) ],
238 baz => [ 'one two' ],
239 quux => [ qw(QUUX1 QUUX2 QUUX3) ],
243 my $foo = $dp->parse_dispatch_specification('?foo=');
246 [ $foo->({ QUERY_STRING => '' }) ],
248 '?foo= fails with no query'
252 [ '?foo=' => { foo => 'FOO' } ],
254 [ '?@spoo~' => { spoo => [] } ],
255 [ '?bar=' => { bar => 'BAR2' } ],
256 [ '?@bar=' => { bar => [ qw(BAR1 BAR2) ] } ],
257 [ '?foo=&@bar=' => { foo => 'FOO', bar => [ qw(BAR1 BAR2) ] } ],
258 [ '?baz=&evil=' => { baz => 'one two', evil => '/' } ],
259 [ '?*' => \%all_single ],
260 [ '?@*' => \%all_multi ],
261 [ '?foo=&@*' => { %all_multi, foo => 'FOO' } ],
262 [ '?@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ],
264 my ($spec, $res) = @$win;
265 my $match = $dp->parse_dispatch_specification($spec);
266 #use Data::Dump::Streamer; warn Dump($match);
268 [ $match->({ QUERY_STRING => $q }) ],
270 "${spec} matches correctly"