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