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 $all = $dp->parse('');
  12
  13   is_deeply(
  14     [ $all->({ REQUEST_METHOD => 'GET' }) ],
  15     [ {} ],
  16     'GET matches'
  17   );
  18
  19   is_deeply(
  20     [ $all->({ REQUEST_METHOD => 'POST' }) ],
  21     [ {} ],
  22     'POST matches'
  23   );
  24 };
  25
  26 {
  27   my $get = $dp->parse('GET');
  28
  29   is_deeply(
  30     [ $get->({ REQUEST_METHOD => 'GET' }) ],
  31     [ {} ],
  32     'GET matches'
  33   );
  34
  35   is_deeply(
  36     [ $get->({ REQUEST_METHOD => 'POST' }) ],
  37     [],
  38     'POST does not match'
  39   );
  40 }
  41
  42 {
  43   my $html = $dp->parse('.html');
  44
  45   is_deeply(
  46     [ $html->({ PATH_INFO => '/foo/bar.html' }) ],
  47     [ { } ],
  48     '.html matches'
  49   );
  50
  51   is_deeply(
  52     [ $html->({ PATH_INFO => '/foo/bar.xml' }) ],
  53     [],
  54     '.xml does not match .html'
  55   );
  56 }
  57
  58 {
  59   my $any_ext = $dp->parse('.*');
  60
  61   is_deeply(
  62     [ $any_ext->({ PATH_INFO => '/foo/bar.html' }) ],
  63     [ { }, 'html' ],
  64     '.html matches .* and extension returned'
  65   );
  66
  67   is_deeply(
  68     [ $any_ext->({ PATH_INFO => '/foo/bar' }) ],
  69     [],
  70     'no extension does not match .*'
  71   );
  72 }
  73
  74 {
  75   my $slash = $dp->parse('/');
  76
  77   is_deeply(
  78     [ $slash->({ PATH_INFO => '/' }) ],
  79     [ {} ],
  80     '/ matches /'
  81   );
  82
  83   is_deeply(
  84     [ $slash->({ PATH_INFO => '/foo' }) ],
  85     [ ],
  86     '/foo does not match /'
  87   );
  88 }
  89
  90 {
  91   my $post = $dp->parse('/post/*');
  92
  93   is_deeply(
  94     [ $post->({ PATH_INFO => '/post/one' }) ],
  95     [ {}, 'one' ],
  96     '/post/one parses out one'
  97   );
  98
  99   is_deeply(
 100     [ $post->({ PATH_INFO => '/post/one/' }) ],
 101     [],
 102     '/post/one/ does not match'
 103   );
 104
 105   is_deeply(
 106     [ $post->({ PATH_INFO => '/post/one.html' }) ],
 107     [ {}, 'one' ],
 108     '/post/one.html still parses out one'
 109   );
 110 }
 111
 112 {
 113   my $post = $dp->parse('/foo-bar/*');
 114
 115   is_deeply(
 116     [ $post->({ PATH_INFO => '/foo-bar/one' }) ],
 117     [ {}, 'one' ],
 118     '/foo-bar/one parses out one'
 119   );
 120
 121   is_deeply(
 122     [ $post->({ PATH_INFO => '/foo-bar/one/' }) ],
 123     [],
 124     '/foo-bar/one/ does not match'
 125   );
 126 }
 127
 128 {
 129   my $combi = $dp->parse('GET+/post/*');
 130
 131   is_deeply(
 132     [ $combi->({ PATH_INFO => '/post/one', REQUEST_METHOD => 'GET' }) ],
 133     [ {}, 'one' ],
 134     '/post/one parses out one'
 135   );
 136
 137   is_deeply(
 138     [ $combi->({ PATH_INFO => '/post/one/', REQUEST_METHOD => 'GET' }) ],
 139     [],
 140     '/post/one/ does not match'
 141   );
 142
 143   is_deeply(
 144     [ $combi->({ PATH_INFO => '/post/one', REQUEST_METHOD => 'POST' }) ],
 145     [],
 146     'POST /post/one does not match'
 147   );
 148 }
 149
 150 {
 151   my $or = $dp->parse('GET|POST');
 152
 153   foreach my $meth (qw(GET POST)) {
 154
 155     is_deeply(
 156       [ $or->({ REQUEST_METHOD => $meth }) ],
 157       [ {} ],
 158       'GET|POST matches method '.$meth
 159     );
 160   }
 161
 162   is_deeply(
 163     [ $or->({ REQUEST_METHOD => 'PUT' }) ],
 164     [],
 165     'GET|POST does not match PUT'
 166   );
 167 }
 168
 169 {
 170   my $or = $dp->parse('GET|POST|DELETE');
 171
 172   foreach my $meth (qw(GET POST DELETE)) {
 173
 174     is_deeply(
 175       [ $or->({ REQUEST_METHOD => $meth }) ],
 176       [ {} ],
 177       'GET|POST|DELETE matches method '.$meth
 178     );
 179   }
 180
 181   is_deeply(
 182     [ $or->({ REQUEST_METHOD => 'PUT' }) ],
 183     [],
 184     'GET|POST|DELETE does not match PUT'
 185   );
 186 }
 187
 188 {
 189   my $nest = $dp->parse('(GET+/foo)|POST');
 190
 191   is_deeply(
 192     [ $nest->({ PATH_INFO => '/foo', REQUEST_METHOD => 'GET' }) ],
 193     [ {} ],
 194     '(GET+/foo)|POST matches GET /foo'
 195   );
 196
 197   is_deeply(
 198     [ $nest->({ PATH_INFO => '/bar', REQUEST_METHOD => 'GET' }) ],
 199     [],
 200     '(GET+/foo)|POST does not match GET /bar'
 201   );
 202
 203   is_deeply(
 204     [ $nest->({ PATH_INFO => '/bar', REQUEST_METHOD => 'POST' }) ],
 205     [ {} ],
 206     '(GET+/foo)|POST matches POST /bar'
 207   );
 208
 209   is_deeply(
 210     [ $nest->({ PATH_INFO => '/foo', REQUEST_METHOD => 'PUT' }) ],
 211     [],
 212     '(GET+/foo)|POST does not match PUT /foo'
 213   );
 214 }
 215
 216 {
 217   my $spec = '(GET+/foo)|(POST+/foo)';
 218   my $nest = $dp->parse($spec);
 219
 220   for my $method (qw( GET POST )) {
 221       is_deeply(
 222         [ $nest->({ PATH_INFO => '/foo', REQUEST_METHOD => $method }) ],
 223         [ {} ],
 224         "$spec matches $method /foo"
 225       );
 226       is_deeply(
 227         [ $nest->({ PATH_INFO => '/bar', REQUEST_METHOD => $method }) ],
 228         [],
 229         "$spec does not match $method /bar"
 230       );
 231   }
 232
 233   is_deeply(
 234     [ $nest->({ PATH_INFO => '/foo', REQUEST_METHOD => 'PUT' }) ],
 235     [],
 236     "$spec does not match PUT /foo"
 237   );
 238 }
 239
 240 {
 241   local $@;
 242   ok(
 243     !eval { $dp->parse('/foo+(GET'); 1 },
 244     'Death with missing closing )'
 245   );
 246   my $err = q{
 247     /foo+(GET
 248          ^
 249   };
 250   (s/^\n//s,s/\n  $//s,s/^    //mg) for $err;
 251   like(
 252     $@,
 253     qr{\Q$err\E},
 254     "Error $@ matches\n${err}\n"
 255   );
 256 }
 257
 258 {
 259   my $not = $dp->parse('!.html+.*');
 260
 261   is_deeply(
 262     [ $not->({ PATH_INFO => '/foo.xml' }) ],
 263     [ {}, 'xml' ],
 264     '!.html+.* matches /foo.xml'
 265   );
 266
 267   is_deeply(
 268     [ $not->({ PATH_INFO => '/foo.html' }) ],
 269     [],
 270     '!.html+.* does not match /foo.html'
 271   );
 272
 273   is_deeply(
 274     [ $not->({ PATH_INFO => '/foo' }) ],
 275     [],
 276     '!.html+.* does not match /foo'
 277   );
 278 }
 279
 280 {
 281   my $ext = $dp->parse('/foo.bar');
 282
 283   is_deeply(
 284     [ $ext->({ PATH_INFO => '/foo.bar' }) ],
 285     [ {} ],
 286     '/foo.bar matches /foo.bar'
 287   );
 288
 289   is_deeply(
 290     [ $ext->({ PATH_INFO => '/foo.bar.ext' }) ],
 291     [ {} ],
 292     '/foo.bar matches /foo.bar.ext'
 293   );
 294
 295   is_deeply(
 296     [ $ext->({ PATH_INFO => '/foo.notbar' }) ],
 297     [],
 298     '/foo.bar does not match /foo.notbar'
 299   );
 300 }
 301
 302 {
 303   my $sub = $dp->parse('/foo/*/...');
 304
 305   is_deeply(
 306     [ $sub->({ PATH_INFO => '/foo/1/bar' }) ],
 307     [ { PATH_INFO => '/bar', SCRIPT_NAME => '/foo/1' }, 1 ],
 308     '/foo/*/... matches /foo/1/bar and strips to /bar'
 309   );
 310
 311   is_deeply(
 312     [ $sub->({ PATH_INFO => '/foo/1/' }) ],
 313     [ { PATH_INFO => '/', SCRIPT_NAME => '/foo/1' }, 1 ],
 314     '/foo/*/... matches /foo/1/bar and strips to /'
 315   );
 316
 317   is_deeply(
 318     [ $sub->({ PATH_INFO => '/foo/1' }) ],
 319     [],
 320     '/foo/*/... does not match /foo/1 (no trailing /)'
 321   );
 322 }
 323
 324 {
 325   my $sub = $dp->parse('/foo/**/belief');
 326   my $match = 'barred/beyond';
 327   is_deeply(
 328     [ $sub->({ PATH_INFO => "/foo/${match}/belief" }) ],
 329     [ {}, $match ],
 330     "/foo/**/belief matches /foo/${match}/belief"
 331   );
 332 }
 333
 334 {
 335   my $match = '~';
 336   my $sub = $dp->parse($match);
 337
 338   is_deeply(
 339     [ $sub->({ PATH_INFO => '/foo' }) ],
 340     [],
 341     "$match does not match /foo"
 342   );
 343
 344   is_deeply(
 345     [ $sub->({ PATH_INFO => '' }) ],
 346     [ {} ],
 347     "$match matches empty path with empty env"
 348   );
 349 }
 350
 351 {
 352   my $match = '/foo...';
 353   my $sub = $dp->parse($match);
 354
 355   is_deeply(
 356     [ $sub->({ PATH_INFO => '/foobar' }) ],
 357     [],
 358     "$match does not match /foobar"
 359   );
 360
 361   is_deeply(
 362     [ $sub->({ PATH_INFO => '/foo/bar' }) ],
 363     [ { PATH_INFO => '/bar', SCRIPT_NAME => '/foo' } ],
 364     "$match matches /foo/bar and strips to /bar"
 365   );
 366
 367   is_deeply(
 368     [ $sub->({ PATH_INFO => '/foo/' }) ],
 369     [ { PATH_INFO => '/', SCRIPT_NAME => '/foo' } ],
 370     "$match matches /foo/ and strips to /"
 371   );
 372
 373   is_deeply(
 374     [ $sub->({ PATH_INFO => '/foo' }) ],
 375     [ { PATH_INFO => '', SCRIPT_NAME => '/foo' } ],
 376     "$match matches /foo and strips to empty path"
 377   );
 378 }
 379
 380 {
 381   my @dot_pairs = (
 382     [ '/one/*' => 'two' ],
 383     [ '/one/*.*' => 'two.three' ],
 384     [ '/**' => 'one/two' ],
 385     [ '/**.*' => 'one/two.three' ],
 386   );
 387
 388   foreach my $p (@dot_pairs) {
 389     is_deeply(
 390       [ $dp->parse($p->[0])->({ PATH_INFO => '/one/two.three' }) ],
 391       [ {}, $p->[1] ],
 392       "${\$p->[0]} matches /one/two.three and returns ${\$p->[1]}"
 393     );
 394   }
 395 }
 396
 397 {
 398   my @named = (
 399     [ '/foo/*:foo_id' => '/foo/1' => { foo_id => 1 } ],
 400     [ '/foo/:foo_id' => '/foo/1' => { foo_id => 1 } ],
 401     [ '/foo/:id/**:rest' => '/foo/id/rest/of/the/path.ext'
 402       => { id => 'id', rest => 'rest/of/the/path' } ],
 403     [ '/foo/:id/**.*:rest' => '/foo/id/rest/of/the/path.ext'
 404       => { id => 'id', rest => 'rest/of/the/path.ext' } ],
 405   );
 406   foreach my $n (@named) {
 407     is_deeply(
 408       [ $dp->parse($n->[0])->({ PATH_INFO => $n->[1] }) ],
 409       [ {}, $n->[2] ],
 410       "${\$n->[0]} matches ${\$n->[1]} with correct captures"
 411     );
 412   }
 413 }
 414
 415 #
 416 # query string
 417 #
 418
 419 my $q = 'foo=FOO&bar=BAR1&baz=one+two&quux=QUUX1&quux=QUUX2'
 420   .'&foo.bar=FOOBAR1&foo.bar=FOOBAR2&foo.baz=FOOBAZ'
 421   .'&bar=BAR2&quux=QUUX3&evil=%2F';
 422
 423 my %all_single = (
 424   foo => 'FOO',
 425   bar => 'BAR2',
 426   baz => 'one two',
 427   quux => 'QUUX3',
 428   evil => '/',
 429   'foo.baz' => 'FOOBAZ',
 430   'foo.bar' => 'FOOBAR2',
 431 );
 432
 433 my %all_multi = (
 434   foo => [ 'FOO' ],
 435   bar => [ qw(BAR1 BAR2) ],
 436   baz => [ 'one two' ],
 437   quux => [ qw(QUUX1 QUUX2 QUUX3) ],
 438   evil => [ '/' ],
 439   'foo.baz' => [ 'FOOBAZ' ],
 440   'foo.bar' => [ qw(FOOBAR1 FOOBAR2) ],
 441 );
 442
 443 foreach my $lose ('?foo=','?:foo=','?@foo=','?:@foo=') {
 444   my $foo = $dp->parse($lose);
 445
 446   is_deeply(
 447     [ $foo->({ QUERY_STRING => '' }) ],
 448     [],
 449     "${lose} fails with no query"
 450   );
 451
 452   is_deeply(
 453     [ $foo->({ QUERY_STRING => 'bar=baz' }) ],
 454     [],
 455     "${lose} fails with query missing foo key"
 456   );
 457 }
 458
 459 foreach my $win (
 460   [ '?foo=' => 'FOO' ],
 461   [ '?:foo=' => { foo => 'FOO' } ],
 462   [ '?spoo~' => undef ],
 463   [ '?:spoo~' => {} ],
 464   [ '?@spoo~' => [] ],
 465   [ '?:@spoo~' => { spoo => [] } ],
 466   [ '?bar=' => 'BAR2' ],
 467   [ '?:bar=' => { bar => 'BAR2' } ],
 468   [ '?@bar=' => [ qw(BAR1 BAR2) ] ],
 469   [ '?:@bar=' => { bar => [ qw(BAR1 BAR2) ] } ],
 470   [ '?foo=&@bar=' => 'FOO', [ qw(BAR1 BAR2) ] ],
 471   [ '?foo=&:@bar=' => 'FOO', { bar => [ qw(BAR1 BAR2) ] } ],
 472   [ '?:foo=&:@bar=' => { foo => 'FOO', bar => [ qw(BAR1 BAR2) ] } ],
 473   [ '?:baz=&:evil=' => { baz => 'one two', evil => '/' } ],
 474   [ '?*' => \%all_single ],
 475   [ '?@*' => \%all_multi ],
 476   [ '?foo=&@*' => 'FOO', \%all_multi ],
 477   [ '?:foo=&@*' => { %all_multi, foo => 'FOO' } ],
 478   [ '?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ],
 479   [ '?foo.baz=' => 'FOOBAZ' ],
 480   [ '?:foo.baz=' => { 'foo.baz' => 'FOOBAZ' } ],
 481   [ '?foo.bar=' => 'FOOBAR2' ],
 482   [ '?:foo.bar=' => { 'foo.bar' => 'FOOBAR2' } ],
 483   [ '?@foo.bar=' => [ qw(FOOBAR1 FOOBAR2) ] ],
 484   [ '?:@foo.bar=' => { 'foo.bar' => [ qw(FOOBAR1 FOOBAR2) ] } ],
 485 ) {
 486   my ($spec, @res) = @$win;
 487   my $match = $dp->parse($spec);
 488   #use Data::Dump::Streamer; warn Dump($match);
 489   is_deeply(
 490     [ $match->({ QUERY_STRING => $q }) ],
 491     [ {}, @res ],
 492     "${spec} matches correctly"
 493   );
 494 }
 495
 496 #
 497 # /path/info/ + query string
 498 #
 499
 500 foreach my $lose2 ('/foo/bar/+?foo=','/foo/bar/+?:foo=','/foo/bar/+?@foo=','/foo/bar/+?:@foo=') {
 501   my $foo = $dp->parse($lose2);
 502
 503   is_deeply(
 504     [ $foo->({ PATH_INFO => '/foo/bar/', QUERY_STRING => '' }) ],
 505     [ ],
 506     "${lose2} fails with no query"
 507   );
 508
 509   is_deeply(
 510     [ $foo->({ PATH_INFO => '/foo/bar/', QUERY_STRING => 'bar=baz' }) ],
 511     [ ],
 512     "${lose2} fails with query missing foo key"
 513   );
 514 }
 515
 516 foreach my $win2 (
 517   [ '/foo/bar/+?foo=' => 'FOO' ],
 518   [ '/foo/bar/+?:foo=' => { foo => 'FOO' } ],
 519   [ '/foo/bar/+?spoo~' => undef ],
 520   [ '/foo/bar/+?:spoo~' => {} ],
 521   [ '/foo/bar/+?@spoo~' => [] ],
 522   [ '/foo/bar/+?:@spoo~' => { spoo => [] } ],
 523   [ '/foo/bar/+?bar=' => 'BAR2' ],
 524   [ '/foo/bar/+?:bar=' => { bar => 'BAR2' } ],
 525   [ '/foo/bar/+?@bar=' => [ qw(BAR1 BAR2) ] ],
 526   [ '/foo/bar/+?:@bar=' => { bar => [ qw(BAR1 BAR2) ] } ],
 527   [ '/foo/bar/+?foo=&@bar=' => 'FOO', [ qw(BAR1 BAR2) ] ],
 528   [ '/foo/bar/+?foo=&:@bar=' => 'FOO', { bar => [ qw(BAR1 BAR2) ] } ],
 529   [ '/foo/bar/+?:foo=&:@bar=' => { foo => 'FOO', bar => [ qw(BAR1 BAR2) ] } ],
 530   [ '/foo/bar/+?:baz=&:evil=' => { baz => 'one two', evil => '/' } ],
 531   [ '/foo/bar/+?*' => \%all_single ],
 532   [ '/foo/bar/+?@*' => \%all_multi ],
 533   [ '/foo/bar/+?foo=&@*' => 'FOO', \%all_multi ],
 534   [ '/foo/bar/+?:foo=&@*' => { %all_multi, foo => 'FOO' } ],
 535   [ '/foo/bar/+?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ],
 536   [ '/foo/bar/+?foo.baz=' => 'FOOBAZ' ],
 537   [ '/foo/bar/+?:foo.baz=' => { 'foo.baz' => 'FOOBAZ' } ],
 538   [ '/foo/bar/+?foo.bar=' => 'FOOBAR2' ],
 539   [ '/foo/bar/+?:foo.bar=' => { 'foo.bar' => 'FOOBAR2' } ],
 540   [ '/foo/bar/+?@foo.bar=' => [ qw(FOOBAR1 FOOBAR2) ] ],
 541   [ '/foo/bar/+?:@foo.bar=' => { 'foo.bar' => [ qw(FOOBAR1 FOOBAR2) ] } ],
 542 ) {
 543   my ($spec, @res) = @$win2;
 544   my $match = $dp->parse($spec);
 545   # use Data::Dump::Streamer; warn Dump($match);
 546   is_deeply(
 547     [ $match->({ PATH_INFO => '/foo/bar/', QUERY_STRING => $q }) ],
 548     [ {}, @res ],
 549     "${spec} matches correctly"
 550   );
 551 }
 552
 553 #
 554 # /path/info + query string
 555 #
 556
 557 foreach my $lose3 ('/foo/bar+?foo=','/foo/bar+?:foo=','/foo/bar+?@foo=','/foo/bar+?:@foo=') {
 558   my $foo = $dp->parse($lose3);
 559
 560   is_deeply(
 561     [ $foo->({ PATH_INFO => '/foo/bar', QUERY_STRING => '' }) ],
 562     [ ],
 563     "${lose3} fails with no query"
 564   );
 565
 566   is_deeply(
 567     [ $foo->({ PATH_INFO => '/foo/bar', QUERY_STRING => 'bar=baz' }) ],
 568     [ ],
 569     "${lose3} fails with query missing foo key"
 570   );
 571 }
 572
 573 foreach my $win3 (
 574   [ '/foo/bar+?foo=' => 'FOO' ],
 575   [ '/foo/bar+?:foo=' => { foo => 'FOO' } ],
 576   [ '/foo/bar+?spoo~' => undef ],
 577   [ '/foo/bar+?:spoo~' => {} ],
 578   [ '/foo/bar+?@spoo~' => [] ],
 579   [ '/foo/bar+?:@spoo~' => { spoo => [] } ],
 580   [ '/foo/bar+?bar=' => 'BAR2' ],
 581   [ '/foo/bar+?:bar=' => { bar => 'BAR2' } ],
 582   [ '/foo/bar+?@bar=' => [ qw(BAR1 BAR2) ] ],
 583   [ '/foo/bar+?:@bar=' => { bar => [ qw(BAR1 BAR2) ] } ],
 584   [ '/foo/bar+?foo=&@bar=' => 'FOO', [ qw(BAR1 BAR2) ] ],
 585   [ '/foo/bar+?foo=&:@bar=' => 'FOO', { bar => [ qw(BAR1 BAR2) ] } ],
 586   [ '/foo/bar+?:foo=&:@bar=' => { foo => 'FOO', bar => [ qw(BAR1 BAR2) ] } ],
 587   [ '/foo/bar+?:baz=&:evil=' => { baz => 'one two', evil => '/' } ],
 588   [ '/foo/bar+?*' => \%all_single ],
 589   [ '/foo/bar+?@*' => \%all_multi ],
 590   [ '/foo/bar+?foo=&@*' => 'FOO', \%all_multi ],
 591   [ '/foo/bar+?:foo=&@*' => { %all_multi, foo => 'FOO' } ],
 592   [ '/foo/bar+?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ],
 593   [ '/foo/bar+?foo.baz=' => 'FOOBAZ' ],
 594   [ '/foo/bar+?:foo.baz=' => { 'foo.baz' => 'FOOBAZ' } ],
 595   [ '/foo/bar+?foo.bar=' => 'FOOBAR2' ],
 596   [ '/foo/bar+?:foo.bar=' => { 'foo.bar' => 'FOOBAR2' } ],
 597   [ '/foo/bar+?@foo.bar=' => [ qw(FOOBAR1 FOOBAR2) ] ],
 598   [ '/foo/bar+?:@foo.bar=' => { 'foo.bar' => [ qw(FOOBAR1 FOOBAR2) ] } ],
 599 ) {
 600   my ($spec, @res) = @$win3;
 601   my $match = $dp->parse($spec);
 602   # use Data::Dump::Streamer; warn Dump($match);
 603   is_deeply(
 604     [ $match->({ PATH_INFO => '/foo/bar', QUERY_STRING => $q }) ],
 605     [ {}, @res ],
 606     "${spec} matches correctly"
 607   );
 608 }