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   local $@;
 218   ok(
 219     !eval { $dp->parse('/foo+(GET'); 1 },
 220     'Death with missing closing )'
 221   );
 222   my $err = q{
 223     /foo+(GET
 224          ^
 225   };
 226   (s/^\n//s,s/\n  $//s,s/^    //mg) for $err;
 227   like(
 228     $@,
 229     qr{\Q$err\E},
 230     "Error $@ matches\n${err}\n"
 231   );
 232 }
 233
 234 {
 235    my $not = $dp->parse('!.html+.*');
 236
 237    is_deeply(
 238      [ $not->({ PATH_INFO => '/foo.xml' }) ],
 239      [ {}, 'xml' ],
 240      '!.html+.* matches /foo.xml'
 241    );
 242
 243    is_deeply(
 244      [ $not->({ PATH_INFO => '/foo.html' }) ],
 245      [],
 246      '!.html+.* does not match /foo.html'
 247    );
 248
 249    is_deeply(
 250      [ $not->({ PATH_INFO => '/foo' }) ],
 251      [],
 252      '!.html+.* does not match /foo'
 253    );
 254 }
 255
 256 {
 257    my $sub = $dp->parse('/foo/*/...');
 258
 259    is_deeply(
 260      [ $sub->({ PATH_INFO => '/foo/1/bar' }) ],
 261      [ { PATH_INFO => '/bar', SCRIPT_NAME => '/foo/1' }, 1 ],
 262      '/foo/*/... matches /foo/1/bar and strips to /bar'
 263    );
 264
 265    is_deeply(
 266      [ $sub->({ PATH_INFO => '/foo/1/' }) ],
 267      [ { PATH_INFO => '/', SCRIPT_NAME => '/foo/1' }, 1 ],
 268      '/foo/*/... matches /foo/1/bar and strips to /'
 269    );
 270
 271    is_deeply(
 272      [ $sub->({ PATH_INFO => '/foo/1' }) ],
 273      [],
 274      '/foo/*/... does not match /foo/1 (no trailing /)'
 275    );
 276 }
 277
 278 {
 279   my @dot_pairs = (
 280     [ '/one/*' => 'two' ],
 281     [ '/one/*.*' => 'two.three' ],
 282     [ '/**' => 'one/two' ],
 283     [ '/**.*' => 'one/two.three' ],
 284   );
 285
 286   foreach my $p (@dot_pairs) {
 287     is_deeply(
 288       [ $dp->parse($p->[0])->({ PATH_INFO => '/one/two.three' }) ],
 289       [ {}, $p->[1] ],
 290       "${\$p->[0]} matches /one/two.three and returns ${\$p->[1]}"
 291     );
 292   }
 293 }
 294
 295 #
 296 # query string
 297 #
 298
 299 my $q = 'foo=FOO&bar=BAR1&baz=one+two&quux=QUUX1&quux=QUUX2'
 300     .'&bar=BAR2&quux=QUUX3&evil=%2F';
 301
 302 my %all_single = (
 303     foo => 'FOO',
 304     bar => 'BAR2',
 305     baz => 'one two',
 306     quux => 'QUUX3',
 307     evil => '/',
 308 );
 309
 310 my %all_multi = (
 311     foo => [ 'FOO' ],
 312     bar => [ qw(BAR1 BAR2) ],
 313     baz => [ 'one two' ],
 314     quux => [ qw(QUUX1 QUUX2 QUUX3) ],
 315     evil => [ '/' ],
 316 );
 317
 318 foreach my $lose ('?foo=','?:foo=','?@foo=','?:@foo=') {
 319     my $foo = $dp->parse($lose);
 320
 321     is_deeply(
 322         [ $foo->({ QUERY_STRING => '' }) ],
 323         [],
 324         "${lose} fails with no query"
 325     );
 326
 327     is_deeply(
 328         [ $foo->({ QUERY_STRING => 'bar=baz' }) ],
 329         [],
 330         "${lose} fails with query missing foo key"
 331     );
 332 }
 333
 334 foreach my $win (
 335     [ '?foo=' => 'FOO' ],
 336     [ '?:foo=' => { foo => 'FOO' } ],
 337     [ '?spoo~' => undef ],
 338     [ '?:spoo~' => {} ],
 339     [ '?@spoo~' => [] ],
 340     [ '?:@spoo~' => { spoo => [] } ],
 341     [ '?bar=' => 'BAR2' ],
 342     [ '?:bar=' => { bar => 'BAR2' } ],
 343     [ '?@bar=' => [ qw(BAR1 BAR2) ] ],
 344     [ '?:@bar=' => { bar => [ qw(BAR1 BAR2) ] } ],
 345     [ '?foo=&@bar=' => 'FOO', [ qw(BAR1 BAR2) ] ],
 346     [ '?foo=&:@bar=' => 'FOO', { bar => [ qw(BAR1 BAR2) ] } ],
 347     [ '?:foo=&:@bar=' => { foo => 'FOO', bar => [ qw(BAR1 BAR2) ] } ],
 348     [ '?:baz=&:evil=' => { baz => 'one two', evil => '/' } ],
 349     [ '?*' => \%all_single ],
 350     [ '?@*' => \%all_multi ],
 351     [ '?foo=&@*' => 'FOO', \%all_multi ],
 352     [ '?:foo=&@*' => { %all_multi, foo => 'FOO' } ],
 353     [ '?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ],
 354 ) {
 355     my ($spec, @res) = @$win;
 356     my $match = $dp->parse($spec);
 357     #use Data::Dump::Streamer; warn Dump($match);
 358     is_deeply(
 359         [ $match->({ QUERY_STRING => $q }) ],
 360         [ {}, @res ],
 361         "${spec} matches correctly"
 362     );
 363 }
 364
 365 #
 366 # /path/info/ + query string
 367 #
 368
 369 foreach my $lose2 ('/foo/bar/+?foo=','/foo/bar/+?:foo=','/foo/bar/+?@foo=','/foo/bar/+?:@foo=') {
 370     my $foo = $dp->parse($lose2);
 371
 372     is_deeply(
 373         [ $foo->({ PATH_INFO => '/foo/bar/', QUERY_STRING => '' }) ],
 374         [ ],
 375         "${lose2} fails with no query"
 376     );
 377
 378     is_deeply(
 379         [ $foo->({ PATH_INFO => '/foo/bar/', QUERY_STRING => 'bar=baz' }) ],
 380         [ ],
 381         "${lose2} fails with query missing foo key"
 382     );
 383 }
 384
 385 foreach my $win2 (
 386     [ '/foo/bar/+?foo=' => 'FOO' ],
 387     [ '/foo/bar/+?:foo=' => { foo => 'FOO' } ],
 388     [ '/foo/bar/+?spoo~' => undef ],
 389     [ '/foo/bar/+?:spoo~' => {} ],
 390     [ '/foo/bar/+?@spoo~' => [] ],
 391     [ '/foo/bar/+?:@spoo~' => { spoo => [] } ],
 392     [ '/foo/bar/+?bar=' => 'BAR2' ],
 393     [ '/foo/bar/+?:bar=' => { bar => 'BAR2' } ],
 394     [ '/foo/bar/+?@bar=' => [ qw(BAR1 BAR2) ] ],
 395     [ '/foo/bar/+?:@bar=' => { bar => [ qw(BAR1 BAR2) ] } ],
 396     [ '/foo/bar/+?foo=&@bar=' => 'FOO', [ qw(BAR1 BAR2) ] ],
 397     [ '/foo/bar/+?foo=&:@bar=' => 'FOO', { bar => [ qw(BAR1 BAR2) ] } ],
 398     [ '/foo/bar/+?:foo=&:@bar=' => { foo => 'FOO', bar => [ qw(BAR1 BAR2) ] } ],
 399     [ '/foo/bar/+?:baz=&:evil=' => { baz => 'one two', evil => '/' } ],
 400     [ '/foo/bar/+?*' => \%all_single ],
 401     [ '/foo/bar/+?@*' => \%all_multi ],
 402     [ '/foo/bar/+?foo=&@*' => 'FOO', \%all_multi ],
 403     [ '/foo/bar/+?:foo=&@*' => { %all_multi, foo => 'FOO' } ],
 404     [ '/foo/bar/+?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ],
 405 ) {
 406     my ($spec, @res) = @$win2;
 407     my $match = $dp->parse($spec);
 408     # use Data::Dump::Streamer; warn Dump($match);
 409     is_deeply(
 410         [ $match->({ PATH_INFO => '/foo/bar/', QUERY_STRING => $q }) ],
 411         [ {}, @res ],
 412         "${spec} matches correctly"
 413     );
 414 }
 415
 416 #
 417 # /path/info + query string
 418 #
 419
 420 foreach my $lose3 ('/foo/bar+?foo=','/foo/bar+?:foo=','/foo/bar+?@foo=','/foo/bar+?:@foo=') {
 421     my $foo = $dp->parse($lose3);
 422
 423     is_deeply(
 424         [ $foo->({ PATH_INFO => '/foo/bar', QUERY_STRING => '' }) ],
 425         [ ],
 426         "${lose3} fails with no query"
 427     );
 428
 429     is_deeply(
 430         [ $foo->({ PATH_INFO => '/foo/bar', QUERY_STRING => 'bar=baz' }) ],
 431         [ ],
 432         "${lose3} fails with query missing foo key"
 433     );
 434 }
 435
 436 foreach my $win3 (
 437     [ '/foo/bar+?foo=' => 'FOO' ],
 438     [ '/foo/bar+?:foo=' => { foo => 'FOO' } ],
 439     [ '/foo/bar+?spoo~' => undef ],
 440     [ '/foo/bar+?:spoo~' => {} ],
 441     [ '/foo/bar+?@spoo~' => [] ],
 442     [ '/foo/bar+?:@spoo~' => { spoo => [] } ],
 443     [ '/foo/bar+?bar=' => 'BAR2' ],
 444     [ '/foo/bar+?:bar=' => { bar => 'BAR2' } ],
 445     [ '/foo/bar+?@bar=' => [ qw(BAR1 BAR2) ] ],
 446     [ '/foo/bar+?:@bar=' => { bar => [ qw(BAR1 BAR2) ] } ],
 447     [ '/foo/bar+?foo=&@bar=' => 'FOO', [ qw(BAR1 BAR2) ] ],
 448     [ '/foo/bar+?foo=&:@bar=' => 'FOO', { bar => [ qw(BAR1 BAR2) ] } ],
 449     [ '/foo/bar+?:foo=&:@bar=' => { foo => 'FOO', bar => [ qw(BAR1 BAR2) ] } ],
 450     [ '/foo/bar+?:baz=&:evil=' => { baz => 'one two', evil => '/' } ],
 451     [ '/foo/bar+?*' => \%all_single ],
 452     [ '/foo/bar+?@*' => \%all_multi ],
 453     [ '/foo/bar+?foo=&@*' => 'FOO', \%all_multi ],
 454     [ '/foo/bar+?:foo=&@*' => { %all_multi, foo => 'FOO' } ],
 455     [ '/foo/bar+?:@bar=&*' => { %all_single, bar => [ qw(BAR1 BAR2) ] } ],
 456 ) {
 457     my ($spec, @res) = @$win3;
 458     my $match = $dp->parse($spec);
 459     # use Data::Dump::Streamer; warn Dump($match);
 460     is_deeply(
 461         [ $match->({ PATH_INFO => '/foo/bar', QUERY_STRING => $q }) ],
 462         [ {}, @res ],
 463         "${spec} matches correctly"
 464     );
 465 }