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