lib/Web/Dispatch/Parser.pm

   1 package Web::Dispatch::Parser;
   2
   3 sub DEBUG () { 0 }
   4
   5 BEGIN {
   6   if ($ENV{WEB_DISPATCH_PARSER_DEBUG}) {
   7     no warnings 'redefine';
   8     *DEBUG = sub () { 1 }
   9   }
  10 }
  11
  12 use Sub::Quote;
  13 use Web::Dispatch::Predicates;
  14 use Moo;
  15
  16 has _cache => (
  17   is => 'lazy', default => quote_sub q{ {} }
  18 );
  19
  20 sub diag { if (DEBUG) { warn $_[0] } }
  21
  22 sub _wtf {
  23   my ($self, $error) = @_;
  24   my $hat = (' ' x (pos||0)).'^';
  25   warn "Warning parsing dispatch specification: ${error}\n
  26 ${_}
  27 ${hat} here\n";
  28 }
  29
  30 sub _blam {
  31   my ($self, $error) = @_;
  32   my $hat = (' ' x (pos||0)).'^';
  33   die "Error parsing dispatch specification: ${error}\n
  34 ${_}
  35 ${hat} here\n";
  36 }
  37
  38 sub parse {
  39   my ($self, $spec) = @_;
  40   $spec =~ s/\s+//g; # whitespace is not valid
  41   return $self->_cache->{$spec} ||= $self->_parse_spec($spec);
  42 }
  43
  44 sub _parse_spec {
  45   my ($self, $spec, $nested) = @_;
  46   return match_true() unless length($spec);
  47   for ($_[1]) {
  48     my @match;
  49     my $close;
  50     PARSE: { do {
  51       push @match, $self->_parse_spec_section($_)
  52         or $self->_blam("Unable to work out what the next section is");
  53       if (/\G\)/gc) {
  54         $self->_blam("Found closing ) with no opening (") unless $nested;
  55         $close = 1;
  56         last PARSE;
  57       }
  58       last PARSE if (pos == length);
  59       $match[-1] = $self->_parse_spec_combinator($_, $match[-1])
  60         or $self->_blam('No valid combinator - expected + or |');
  61     } until (pos == length) }; # accept trailing whitespace
  62     if (!$close and $nested and pos == length) {
  63       pos = $nested - 1;
  64       $self->_blam("No closing ) found for opening (");
  65     }
  66     return $match[0] if (@match == 1);
  67     return match_and(@match);
  68   }
  69 }
  70
  71 sub _parse_spec_combinator {
  72   my ($self, $spec, $match) = @_;
  73   for ($_[1]) {
  74
  75     /\G\+/gc and
  76       return $match;
  77
  78     /\G\|/gc and
  79       return do {
  80         my @match = $match;
  81         PARSE: { do {
  82           push @match, $self->_parse_spec_section($_)
  83             or $self->_blam("Unable to work out what the next section is");
  84           last PARSE if (pos == length);
  85           last PARSE unless /\G\|/gc; # give up when next thing isn't |
  86         } until (pos == length) }; # accept trailing whitespace
  87         return match_or(@match);
  88       };
  89   }
  90   return;
  91 }
  92
  93 sub _parse_spec_section {
  94   my ($self) = @_;
  95   for ($_[1]) {
  96
  97     # ~
  98
  99     /\G~/gc and
 100       return match_path('^$');
 101
 102     # GET POST PUT HEAD ...
 103
 104     /\G([A-Z]+)/gc and
 105       return match_method($1);
 106
 107     # /...
 108
 109     /\G(?=\/)/gc and
 110       return $self->_url_path_match($_);
 111
 112     # .* and .html
 113
 114     /\G\.(\*|\w+)/gc and
 115       return match_extension($1);
 116
 117     # (...)
 118
 119     /\G\(/gc and
 120       return $self->_parse_spec($_, pos);
 121
 122     # !something
 123
 124     /\G!/gc and
 125       return match_not($self->_parse_spec_section($_));
 126
 127     # ?<param spec>
 128     /\G\?/gc and
 129       return $self->_parse_param_handler($_, 'query');
 130
 131     # %<param spec>
 132     /\G\%/gc and
 133       return $self->_parse_param_handler($_, 'body');
 134
 135     # *<param spec>
 136     /\G\*/gc and
 137       return $self->_parse_param_handler($_, 'uploads');
 138   }
 139   return; # () will trigger the blam in our caller
 140 }
 141
 142 sub _url_path_match {
 143   my ($self) = @_;
 144   for ($_[1]) {
 145     my (@path, @names, $seen_nameless);
 146     my $end = '';
 147     my $keep_dot;
 148     PATH: while (/\G\//gc) {
 149       /\G\.\.\./gc
 150         and do {
 151           $end = '(/.*)';
 152           last PATH;
 153         };
 154
 155       my ($segment) = $self->_url_path_segment_match($_)
 156         or $self->_blam("Couldn't parse path match segment");
 157
 158       if (ref($segment)) {
 159         ($segment, $keep_dot, my $name) = @$segment;
 160         if (defined($name)) {
 161           $self->_blam("Can't mix positional and named captures in path match")
 162             if $seen_nameless;
 163           push @names, $name;
 164         } else {
 165           $self->_blam("Can't mix positional and named captures in path match")
 166             if @names;
 167           $seen_nameless = 1;
 168         }
 169       }
 170       push @path, $segment;
 171
 172       /\G\.\.\./gc
 173         and do {
 174           $end = '(|/.*)';
 175           last PATH;
 176         };
 177       /\G\.\*/gc
 178         and $keep_dot = 1;
 179
 180       last PATH if $keep_dot;
 181     }
 182     if (@path && !$end && !$keep_dot) {
 183       length and $_ .= '(?:\.\w+)?' for $path[-1];
 184     }
 185     my $re = '^('.join('/','',@path).')'.$end.'$';
 186     $re = qr/$re/;
 187     if ($end) {
 188       return match_path_strip($re, @names ? \@names : ());
 189     } else {
 190       return match_path($re, @names ? \@names : ());
 191     }
 192   }
 193   return;
 194 }
 195
 196 sub _url_path_segment_match {
 197   my ($self) = @_;
 198   for ($_[1]) {
 199     # trailing / -> require / on end of URL
 200     /\G(?:(?=[+|\)])|$)/gc and
 201       return '';
 202     # word chars only -> exact path part match
 203     /
 204         \G(
 205             (?:             # start matching at a space followed by:
 206                     [\w\-]  # word chars or dashes
 207                 |           # OR
 208                     \.      # a period
 209                     (?!\.)  # not followed by another period
 210             )
 211             +               # then grab as far as possible
 212         )
 213     /gcx and
 214       return "\Q$1";
 215     # ** -> capture unlimited path parts
 216     /\G\*\*(?:(\.\*)?\:(\w+))?/gc and
 217       return [ '(.*?[^/])', $1, $2 ];
 218     # * -> capture path part
 219     # *:name -> capture named path part
 220     /\G\*(?:(\.\*)?\:(\w+))?/gc and
 221       return [ '([^/]+?)', $1, $2 ];
 222
 223     # :name -> capture named path part
 224     /\G\:(\w+)/gc and
 225       return [ '([^/]+?)', 0, $1 ];
 226   }
 227   return ();
 228 }
 229
 230 sub _parse_param_handler {
 231   my ($self, $spec, $type) = @_;
 232
 233   for ($_[1]) {
 234     my (@required, @single, %multi, $star, $multistar, %positional, $have_kw);
 235     my %spec;
 236     my $pos_idx = 0;
 237     PARAM: { do {
 238
 239       # ?:foo or ?@:foo
 240
 241       my $is_kw = /\G\:/gc;
 242
 243       # ?@foo or ?@*
 244
 245       my $multi = /\G\@/gc;
 246
 247       # @* or *
 248
 249       if (/\G\*/gc) {
 250
 251         $self->_blam("* is always named; no need to supply :") if $is_kw;
 252
 253         if ($star) {
 254           $self->_blam("Can only use one * or \@* in a parameter match");
 255         }
 256
 257         $spec{star} = { multi => $multi };
 258       } else {
 259
 260         # @foo= or foo= or @foo~ or foo~
 261
 262         /\G([\w.]*)/gc or $self->_blam('Expected parameter name');
 263
 264         my $name = $1;
 265
 266         # check for = or ~ on the end
 267
 268         /\G\=/gc
 269           ? push(@{$spec{required}||=[]}, $name)
 270           : (/\G\~/gc or $self->_blam('Expected = or ~ after parameter name'));
 271
 272         # record positional or keyword
 273
 274         push @{$spec{$is_kw ? 'named' : 'positional'}||=[]},
 275           { name => $name, multi => $multi };
 276       }
 277     } while (/\G\&/gc) }
 278
 279     return Web::Dispatch::Predicates->can("match_${type}")->(\%spec);
 280   }
 281 }
 282
 283 1;