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