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 /)'