t/dispatch_parser.t

   1 use strict;
   2 use warnings FATAL => 'all';
   3
   4 use Test::More qw(no_plan);
   5
   6 use Web::Dispatch::Parser;
   7
   8 my $dp = Web::Dispatch::Parser->new;
   9
  10 {
  11    my $get = $dp->parse('GET');
  12
  13    is_deeply(
  14      [ $get->({ REQUEST_METHOD => 'GET' }) ],
  15      [ {} ],
  16      'GET matches'
  17    );
  18
  19    is_deeply(
  20      [ $get->({ REQUEST_METHOD => 'POST' }) ],
  21      [],
  22      'POST does not match'
  23    );
  24 }
  25
  26 ok(
  27   !eval { $dp->parse('GET POST'); 1; },
  28   "Don't yet allow two methods"
  29 );
  30
  31 {
  32    my $html = $dp->parse('.html');
  33
  34    is_deeply(
  35      [ $html->({ PATH_INFO => '/foo/bar.html' }) ],
  36      [ { PATH_INFO => '/foo/bar' } ],
  37      '.html matches'
  38    );
  39
  40    is_deeply(
  41      [ $html->({ PATH_INFO => '/foo/bar.xml' }) ],
  42      [],
  43      '.xml does not match .html'
  44    );
  45 }
  46
  47 {
  48    my $any_ext = $dp->parse('.*');
  49
  50    is_deeply(
  51      [ $any_ext->({ PATH_INFO => '/foo/bar.html' }) ],
  52      [ { PATH_INFO => '/foo/bar' }, 'html' ],
  53      '.html matches .* and extension returned'
  54    );
  55
  56    is_deeply(
  57      [ $any_ext->({ PATH_INFO => '/foo/bar' }) ],
  58      [],
  59      'no extension does not match .*'
  60    );
  61 }
  62
  63 {
  64    my $slash = $dp->parse('/');
  65
  66    is_deeply(
  67      [ $slash->({ PATH_INFO => '/' }) ],
  68      [ {} ],
  69      '/ matches /'
  70    );
  71
  72    is_deeply(
  73      [ $slash->({ PATH_INFO => '/foo' }) ],
  74      [ ],
  75      '/foo does not match /'
  76    );
  77 }
  78
  79 {
  80    my $post = $dp->parse('/post/*');
  81
  82    is_deeply(
  83      [ $post->({ PATH_INFO => '/post/one' }) ],
  84      [ {}, 'one' ],
  85      '/post/one parses out one'
  86    );
  87
  88    is_deeply(
  89      [ $post->({ PATH_INFO => '/post/one/' }) ],
  90      [],
  91      '/post/one/ does not match'
  92    );
  93 }
  94
  95 {
  96    my $combi = $dp->parse('GET+/post/*');
  97
  98    is_deeply(
  99      [ $combi->({ PATH_INFO => '/post/one', REQUEST_METHOD => 'GET' }) ],
 100      [ {}, 'one' ],
 101      '/post/one parses out one'
 102    );
 103
 104    is_deeply(
 105      [ $combi->({ PATH_INFO => '/post/one/', REQUEST_METHOD => 'GET' }) ],
 106      [],
 107      '/post/one/ does not match'
 108    );
 109
 110    is_deeply(
 111      [ $combi->({ PATH_INFO => '/post/one', REQUEST_METHOD => 'POST' }) ],
 112      [],
 113      'POST /post/one does not match'
 114    );
 115 }
 116
 117 {
 118    my $or = $dp->parse('GET|POST');
 119
 120    foreach my $meth (qw(GET POST)) {
 121
 122      is_deeply(
 123        [ $or->({ REQUEST_METHOD => $meth }) ],
 124        [ {} ],
 125        'GET|POST matches method '.$meth
 126      );
 127    }
 128
 129    is_deeply(
 130      [ $or->({ REQUEST_METHOD => 'PUT' }) ],
 131      [],
 132      'GET|POST does not match PUT'
 133    );
 134 }
 135
 136 {
 137    my $or = $dp->parse('GET|POST|DELETE');
 138
 139    foreach my $meth (qw(GET POST DELETE)) {
 140
 141      is_deeply(
 142        [ $or->({ REQUEST_METHOD => $meth }) ],
 143        [ {} ],
 144        'GET|POST|DELETE matches method '.$meth
 145      );
 146    }
 147
 148    is_deeply(
 149      [ $or->({ REQUEST_METHOD => 'PUT' }) ],
 150      [],
 151      'GET|POST|DELETE does not match PUT'
 152    );
 153 }
 154
 155 {
 156    my $nest = $dp->parse('(GET+/foo)|POST');
 157
 158    is_deeply(
 159      [ $nest->({ PATH_INFO => '/foo', REQUEST_METHOD => 'GET' }) ],
 160      [ {} ],
 161      '(GET+/foo)|POST matches GET /foo'
 162    );
 163
 164    is_deeply(
 165      [ $nest->({ PATH_INFO => '/bar', REQUEST_METHOD => 'GET' }) ],
 166      [],
 167      '(GET+/foo)|POST does not match GET /bar'
 168    );
 169
 170    is_deeply(
 171      [ $nest->({ PATH_INFO => '/bar', REQUEST_METHOD => 'POST' }) ],
 172      [ {} ],
 173      '(GET+/foo)|POST matches POST /bar'
 174    );
 175
 176    is_deeply(
 177      [ $nest->({ PATH_INFO => '/foo', REQUEST_METHOD => 'PUT' }) ],
 178      [],
 179      '(GET+/foo)|POST does not match PUT /foo'
 180    );
 181 }
 182
 183 {
 184   local $@;
 185   ok(
 186     !eval { $dp->parse('/foo+(GET'); 1 },
 187     'Death with missing closing )'
 188   );
 189   my $err = q{
 190     /foo+(GET
 191          ^
 192   };
 193   (s/^\n//s,s/\n  $//s,s/^    //mg) for $err;
 194   like(
 195     $@,
 196     qr{\Q$err\E},
 197     "Error $@ matches\n${err}\n"
 198   );
 199 }
 200
 201 {
 202    my $not = $dp->parse('!.html+.*');
 203
 204    is_deeply(
 205      [ $not->({ PATH_INFO => '/foo.xml' }) ],
 206      [ { PATH_INFO => '/foo' }, 'xml' ],
 207      '!.html+.* matches /foo.xml'
 208    );
 209
 210    is_deeply(
 211      [ $not->({ PATH_INFO => '/foo.html' }) ],
 212      [],
 213      '!.html+.* does not match /foo.html'
 214    );
 215
 216    is_deeply(
 217      [ $not->({ PATH_INFO => '/foo' }) ],
 218      [],
 219      '!.html+.* does not match /foo'
 220    );
 221 }
 222
 223 {
 224    my $sub = $dp->parse('/foo/*/...');
 225
 226    is_deeply(
 227      [ $sub->({ PATH_INFO => '/foo/1/bar' }) ],
 228      [ { PATH_INFO => '/bar', SCRIPT_NAME => '/foo/1' }, 1 ],
 229      '/foo/*/... matches /foo/1/bar and strips to /bar'
 230    );
 231
 232    is_deeply(
 233      [ $sub->({ PATH_INFO => '/foo/1/' }) ],
 234      [ { PATH_INFO => '/', SCRIPT_NAME => '/foo/1' }, 1 ],
 235      '/foo/*/... matches /foo/1/bar and strips to /'
 236    );
 237
 238    is_deeply(
 239      [ $sub->({ PATH_INFO => '/foo/1' }) ],
 240      [],
 241      '/foo/*/... does not match /foo/1 (no trailing /)'
 242    );
 243 }
 244
 245 #
 246 # query string
 247 #
 248
 249 my $q = 'foo=FOO&bar=BAR1&baz=one+two&quux=QUUX1&quux=QUUX2'
 250     .'&bar=BAR2&quux=QUUX3&evil=%2F';
 251
 252 my %all_single = (
 253     foo => 'FOO',
 254     bar => 'BAR2',
 255     baz => 'one two',
 256     quux => 'QUUX3',
 257     evil => '/',
 258 );
 259
 260 my %all_multi = (
 261     foo => [ 'FOO' ],
 262     bar => [ qw(BAR1 BAR2) ],
 263     baz => [ 'one two' ],
 264     quux => [ qw(QUUX1 QUUX2 QUUX3) ],
 265     evil => [ '/' ],
 266 );
 267
 268 foreach my $lose ('?foo=','?:foo=','?@foo=','?:@foo=') {
 269     my $foo = $dp->parse($lose);
 270
 271     is_deeply(
 272         [ $foo->({ QUERY_STRING => '' }) ],
 273         [],
 274         "${lose} fails with no query"
 275     );
 276
 277     is_deeply(
 278         [ $foo->({ QUERY_STRING => 'bar=baz' }) ],
 279         [],
 280         "${lose} fails with query missing foo key"
 281     );
 282 }
 283
 284 foreach my $win (
 285     [ '?foo=' => 'FOO' ],
 286     [ '?:foo=' => { foo => 'FOO' } ],
 287     [ '?spoo~' => undef ],
 288     [ '?:spoo~' => {} ],
 289     [ '?@spoo~' => [] ],
 290     [ '?:@spoo~' => { spoo => [] } ],
 291     [ '?bar=' => 'BAR2' ],
 292     [ '?:bar=' => { bar => 'BAR2' } ],
 293     [ '?@bar=' => [ qw(BAR1 BAR2) ] ],
 294     [ '?:@bar=' => { bar => [ qw(BAR1 BAR2) ] } ],
 295     [ '?foo=&@bar=' => 'FOO', [ qw(BAR1 BAR2) ] ],
 296     [ '?foo=&:@bar=' => 'FOO', { bar => [ qw(BAR1 BAR2) ] } ],
 297     [ '?:foo=&:@bar=' => { foo => 'FOO', bar => [ qw(BAR1 BAR2) ] } ],
 298     [ '?:baz=&:evil=' => { baz => 'one two', evil => '/' } ],
 299     [ '?*' => \%all_single ],
 300     [ '?@*' => \%all_multi ],
 301     [ '?foo=&@*' => 'FOO', do { my %h = %all_multi; delete $h{foo}; \%h } ],
 302     [ '?:foo=&@*' => { %all_multi, foo => 'FOO' } ],
 303     [ '?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ],
 304 ) {
 305     my ($spec, @res) = @$win;
 306     my $match = $dp->parse($spec);
 307     #use Data::Dump::Streamer; warn Dump($match);
 308     is_deeply(
 309         [ $match->({ QUERY_STRING => $q }) ],
 310         [ {}, @res ],
 311         "${spec} matches correctly"
 312     );
 313 }
 314
 315 #
 316 # /path/info/ + query string
 317 #
 318
 319 foreach my $lose2 ('/foo/bar/+?foo=','/foo/bar/+?:foo=','/foo/bar/+?@foo=','/foo/bar/+?:@foo=') {
 320     my $foo = $dp->parse($lose2);
 321
 322     is_deeply(
 323         [ $foo->({ PATH_INFO => '/foo/bar/', QUERY_STRING => '' }) ],
 324         [ ],
 325         "${lose2} fails with no query"
 326     );
 327
 328     is_deeply(
 329         [ $foo->({ PATH_INFO => '/foo/bar/', QUERY_STRING => 'bar=baz' }) ],
 330         [ ],
 331         "${lose2} fails with query missing foo key"
 332     );
 333 }
 334
 335 foreach my $win2 (
 336     [ '/foo/bar/+?foo=' => 'FOO' ],
 337     [ '/foo/bar/+?:foo=' => { foo => 'FOO' } ],
 338     [ '/foo/bar/+?spoo~' => undef ],
 339     [ '/foo/bar/+?:spoo~' => {} ],
 340     [ '/foo/bar/+?@spoo~' => [] ],
 341     [ '/foo/bar/+?:@spoo~' => { spoo => [] } ],
 342     [ '/foo/bar/+?bar=' => 'BAR2' ],
 343     [ '/foo/bar/+?:bar=' => { bar => 'BAR2' } ],
 344     [ '/foo/bar/+?@bar=' => [ qw(BAR1 BAR2) ] ],
 345     [ '/foo/bar/+?:@bar=' => { bar => [ qw(BAR1 BAR2) ] } ],
 346     [ '/foo/bar/+?foo=&@bar=' => 'FOO', [ qw(BAR1 BAR2) ] ],
 347     [ '/foo/bar/+?foo=&:@bar=' => 'FOO', { bar => [ qw(BAR1 BAR2) ] } ],
 348     [ '/foo/bar/+?:foo=&:@bar=' => { foo => 'FOO', bar => [ qw(BAR1 BAR2) ] } ],
 349     [ '/foo/bar/+?:baz=&:evil=' => { baz => 'one two', evil => '/' } ],
 350     [ '/foo/bar/+?*' => \%all_single ],
 351     [ '/foo/bar/+?@*' => \%all_multi ],
 352     [ '/foo/bar/+?foo=&@*' => 'FOO', do { my %h = %all_multi; delete $h{foo}; \%h } ],
 353     [ '/foo/bar/+?:foo=&@*' => { %all_multi, foo => 'FOO' } ],
 354     [ '/foo/bar/+?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ],
 355 ) {
 356     my ($spec, @res) = @$win2;
 357     my $match = $dp->parse($spec);
 358     # use Data::Dump::Streamer; warn Dump($match);
 359     is_deeply(
 360         [ $match->({ PATH_INFO => '/foo/bar/', QUERY_STRING => $q }) ],
 361         [ {}, @res ],
 362         "${spec} matches correctly"
 363     );
 364 }
 365
 366 #
 367 # /path/info + query string
 368 #
 369
 370 foreach my $lose3 ('/foo/bar+?foo=','/foo/bar+?:foo=','/foo/bar+?@foo=','/foo/bar+?:@foo=') {
 371     my $foo = $dp->parse($lose3);
 372
 373     is_deeply(
 374         [ $foo->({ PATH_INFO => '/foo/bar', QUERY_STRING => '' }) ],
 375         [ ],
 376         "${lose3} fails with no query"
 377     );
 378
 379     is_deeply(
 380         [ $foo->({ PATH_INFO => '/foo/bar', QUERY_STRING => 'bar=baz' }) ],
 381         [ ],
 382         "${lose3} fails with query missing foo key"
 383     );
 384 }
 385
 386 foreach my $win3 (
 387     [ '/foo/bar+?foo=' => 'FOO' ],
 388     [ '/foo/bar+?:foo=' => { foo => 'FOO' } ],
 389     [ '/foo/bar+?spoo~' => undef ],
 390     [ '/foo/bar+?:spoo~' => {} ],
 391     [ '/foo/bar+?@spoo~' => [] ],
 392     [ '/foo/bar+?:@spoo~' => { spoo => [] } ],
 393     [ '/foo/bar+?bar=' => 'BAR2' ],
 394     [ '/foo/bar+?:bar=' => { bar => 'BAR2' } ],
 395     [ '/foo/bar+?@bar=' => [ qw(BAR1 BAR2) ] ],
 396     [ '/foo/bar+?:@bar=' => { bar => [ qw(BAR1 BAR2) ] } ],
 397     [ '/foo/bar+?foo=&@bar=' => 'FOO', [ qw(BAR1 BAR2) ] ],
 398     [ '/foo/bar+?foo=&:@bar=' => 'FOO', { bar => [ qw(BAR1 BAR2) ] } ],
 399     [ '/foo/bar+?:foo=&:@bar=' => { foo => 'FOO', bar => [ qw(BAR1 BAR2) ] } ],
 400     [ '/foo/bar+?:baz=&:evil=' => { baz => 'one two', evil => '/' } ],
 401     [ '/foo/bar+?*' => \%all_single ],
 402     [ '/foo/bar+?@*' => \%all_multi ],
 403     [ '/foo/bar+?foo=&@*' => 'FOO', do { my %h = %all_multi; delete $h{foo}; \%h } ],
 404     [ '/foo/bar+?:foo=&@*' => { %all_multi, foo => 'FOO' } ],
 405     [ '/foo/bar+?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ],
 406 ) {
 407     my ($spec, @res) = @$win3;
 408     my $match = $dp->parse($spec);
 409     # use Data::Dump::Streamer; warn Dump($match);
 410     is_deeply(
 411         [ $match->({ PATH_INFO => '/foo/bar', QUERY_STRING => $q }) ],
 412         [ {}, @res ],
 413         "${spec} matches correctly"
 414     );
 415 }