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   for ($_[1]) {
  39     my @match;
  40     PARSE: { do {
  41       push @match, $self->_parse_spec_section($_)
  42         or $self->_blam("Unable to work out what the next section is");
  43       if (/\G\)/gc) {
  44         $self->_blam("Found closing ) with no opening (") unless $nested;
  45         last PARSE;
  46       }
  47       last PARSE if (pos == length);
  48       $match[-1] = $self->_parse_spec_combinator($_, $match[-1])
  49         or $self->_blam('No valid combinator - expected + or |');
  50     } until (pos == length) }; # accept trailing whitespace
  51     if ($nested and pos == length) {
  52       pos = $nested - 1;
  53       $self->_blam("No closing ) found for opening (");
  54     }
  55     return $match[0] if (@match == 1);
  56     return match_and(@match);
  57   }
  58 }
  59
  60 sub _parse_spec_combinator {
  61   my ($self, $spec, $match) = @_;
  62   for ($_[1]) {
  63
  64     /\G\+/gc and
  65       return $match;
  66
  67     /\G\|/gc and
  68       return do {
  69         my @match = $match;
  70         PARSE: { do {
  71           push @match, $self->_parse_spec_section($_)
  72             or $self->_blam("Unable to work out what the next section is");
  73           last PARSE if (pos == length);
  74           last PARSE unless /\G\|/gc; # give up when next thing isn't |
  75         } until (pos == length) }; # accept trailing whitespace
  76         return match_or(@match);
  77       };
  78   }
  79   return;
  80 }
  81
  82 sub _parse_spec_section {
  83   my ($self) = @_;
  84   for ($_[1]) {
  85
  86     # GET POST PUT HEAD ...
  87
  88     /\G([A-Z]+)/gc and
  89       return match_method($1);
  90
  91     # /...
  92
  93     /\G(?=\/)/gc and
  94       return $self->_url_path_match($_);
  95
  96     # .* and .html
  97
  98     /\G\.(\*|\w+)/gc and
  99       return match_extension($1);
 100
 101     # (...)
 102
 103     /\G\(/gc and
 104       return $self->_parse_spec($_, pos);
 105
 106     # !something
 107
 108     /\G!/gc and
 109       return match_not($self->_parse_spec_section($_));
 110
 111     # ?<param spec>
 112     /\G\?/gc and
 113       return $self->_parse_param_handler($_, 'query');
 114
 115     # %<param spec>
 116     /\G\%/gc and
 117       return $self->_parse_param_handler($_, 'body');
 118
 119     # *<param spec>
 120     /\G\*/gc and
 121       return $self->_parse_param_handler($_, 'uploads');
 122   }
 123   return; # () will trigger the blam in our caller
 124 }
 125
 126 sub _url_path_match {
 127   my ($self) = @_;
 128   for ($_[1]) {
 129     my @path;
 130     my $end = '';
 131     my $keep_dot;
 132     PATH: while (/\G\//gc) {
 133       /\G\.\.\./gc
 134         and do {
 135           $end = '(/.*)';
 136           last PATH;
 137         };
 138       push @path, $self->_url_path_segment_match($_)
 139         or $self->_blam("Couldn't parse path match segment");
 140       /\G\.\*/gc
 141         and do {
 142           $keep_dot = 1;
 143           last PATH;
 144         };
 145     }
 146     if (@path && !$end && !$keep_dot) {
 147       length and $_ .= '(?:\.\w+)?' for $path[-1];
 148     }
 149     my $re = '^('.join('/','',@path).')'.$end.'$';
 150     $re = qr/$re/;
 151     if ($end) {
 152       return match_path_strip($re);
 153     } else {
 154       return match_path($re);
 155     }
 156   }
 157   return;
 158 }
 159
 160 sub _url_path_segment_match {
 161   my ($self) = @_;
 162   for ($_[1]) {
 163     # trailing / -> require / on end of URL
 164     /\G(?:(?=[+|\)])|$)/gc and
 165       return '';
 166     # word chars only -> exact path part match
 167     /\G([\w\-]+)/gc and
 168       return "\Q$1";
 169     # ** -> capture unlimited path parts
 170     /\G\*\*/gc and
 171       return '(.*?[^/])';
 172     # * -> capture path part
 173     /\G\*/gc and
 174       return '([^/]+?)';
 175   }
 176   return ();
 177 }
 178
 179 sub _parse_param_handler {
 180   my ($self, $spec, $type) = @_;
 181
 182   for ($_[1]) {
 183     my (@required, @single, %multi, $star, $multistar, %positional, $have_kw);
 184     my %spec;
 185     my $pos_idx = 0;
 186     PARAM: { do {
 187
 188       # ?:foo or ?@:foo
 189
 190       my $is_kw = /\G\:/gc;
 191
 192       # ?@foo or ?@*
 193
 194       my $multi = /\G\@/gc;
 195
 196       # @* or *
 197
 198       if (/\G\*/gc) {
 199
 200         $self->_blam("* is always named; no need to supply :") if $is_kw;
 201
 202         if ($star) {
 203           $self->_blam("Can only use one * or \@* in a parameter match");
 204         }
 205
 206         $spec{star} = { multi => $multi };
 207       } else {
 208
 209         # @foo= or foo= or @foo~ or foo~
 210
 211         /\G(\w+)/gc or $self->_blam('Expected parameter name');
 212
 213         my $name = $1;
 214
 215         # check for = or ~ on the end
 216
 217         /\G\=/gc
 218           ? push(@{$spec{required}||=[]}, $name)
 219           : (/\G\~/gc or $self->_blam('Expected = or ~ after parameter name'));
 220
 221         # record positional or keyword
 222
 223         push @{$spec{$is_kw ? 'named' : 'positional'}||=[]},
 224           { name => $name, multi => $multi };
 225       }
 226     } while (/\G\&/gc) }
 227
 228     return Web::Dispatch::Predicates->can("match_${type}")->(\%spec);
 229   }
 230 }
 231
 232 1;