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   return $self->_cache->{$spec} ||= $self->_parse_spec($spec);
  33 }
  34
  35 sub _parse_spec {
  36   my ($self, $spec, $nested) = @_;
  37   for ($_[1]) {
  38     my @match;
  39     /^\G\s*/; # eat leading whitespace
  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 $self->_http_method_match($_, $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 $self->_url_extension_match($_, $1);
 100
 101     # (...)
 102
 103     /\G\(/gc and
 104       return $self->_parse_spec($_, pos);
 105
 106     # !something
 107
 108     /\G!/gc and
 109       return do {
 110         my $match = $self->_parse_spec_section($_);
 111         return sub {
 112           return {} unless $match->(@_);
 113           return;
 114         };
 115       };
 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   return; # () will trigger the blam in our caller
 126 }
 127
 128 sub _http_method_match {
 129   my ($self, $str, $method) = @_;
 130   match_method($method);
 131 }
 132
 133 sub _url_path_match {
 134   my ($self) = @_;
 135   for ($_[1]) {
 136     my @path;
 137     my $end = '';
 138     PATH: while (/\G\//gc) {
 139       /\G\.\.\./gc
 140         and do {
 141           $end = '(/.*)';
 142           last PATH;
 143         };
 144       push @path, $self->_url_path_segment_match($_)
 145         or $self->_blam("Couldn't parse path match segment");
 146     }
 147     !$end and length and $_ .= '(?:\.\w+)?' for $path[-1];
 148     my $re = '^('.join('/','',@path).')'.$end.'$';
 149     $re = qr/$re/;
 150     if ($end) {
 151       return match_path_strip($re);
 152     } else {
 153       return match_path($re);
 154     }
 155   }
 156   return;
 157 }
 158
 159 sub _url_path_segment_match {
 160   my ($self) = @_;
 161   for ($_[1]) {
 162     # trailing / -> require / on end of URL
 163     /\G(?:(?=[+|\)])|$)/gc and
 164       return '';
 165     # word chars only -> exact path part match
 166     /\G(\w+)/gc and
 167       return "\Q$1";
 168     # ** -> capture unlimited path parts
 169     /\G\*\*/gc and
 170       return '(.*?[^/])';
 171     # * -> capture path part
 172     /\G\*/gc and
 173       return '([^/]+)';
 174   }
 175   return ();
 176 }
 177
 178 sub _url_extension_match {
 179   my ($self, $str, $extension) = @_;
 180   if ($extension eq '*') {
 181     sub {
 182       if ((my $tmp = shift->{PATH_INFO}) =~ s/\.(\w+)$//) {
 183         ({ PATH_INFO => $tmp }, $1);
 184       } else {
 185         ();
 186       }
 187     };
 188   } else {
 189     sub {
 190       if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) {
 191         ({ PATH_INFO => $tmp });
 192       } else {
 193         ();
 194       }
 195     };
 196   }
 197 }
 198
 199 sub _parse_param_handler {
 200   my ($self, $spec, $type) = @_;
 201
 202   require Web::Simple::ParamParser;
 203   my $unpacker = Web::Simple::ParamParser->can("get_unpacked_${type}_from");
 204
 205   for ($_[1]) {
 206     my (@required, @single, %multi, $star, $multistar, %positional, $have_kw);
 207     my $pos_idx = 0;
 208     PARAM: { do {
 209
 210       # ?:foo or ?@:foo
 211
 212       my $is_kw = /\G\:/gc;
 213
 214       # ?@foo or ?@*
 215
 216       my $multi = /\G\@/gc;
 217
 218       # @* or *
 219
 220       if (/\G\*/gc) {
 221
 222         $self->_blam("* is always named; no need to supply :") if $is_kw;
 223
 224         $multi ? ($multistar = 1) : ($star = 1);
 225
 226         $have_kw = 1;
 227
 228         if ($star && $multistar) {
 229           $self->_blam("Can't use * and \@* in the same parameter match");
 230         }
 231       } else {
 232
 233         # @foo= or foo= or @foo~ or foo~
 234
 235         /\G(\w+)/gc or $self->_blam('Expected parameter name');
 236
 237         my $name = $1;
 238
 239         # check for = or ~ on the end
 240
 241         /\G\=/gc
 242           ? push(@required, $name)
 243           : (/\G\~/gc or $self->_blam('Expected = or ~ after parameter name'));
 244
 245         # record the key in the right category depending on the multi (@) flag
 246
 247         $multi ? ($multi{$name} = 1) : (push @single, $name);
 248
 249         # record positional or keyword
 250
 251         $is_kw ? ($have_kw = 1) : ($positional{$name} = $pos_idx++);
 252       }
 253     } while (/\G\&/gc) }
 254
 255     return sub {
 256       my $raw = $unpacker->($_[0]);
 257       foreach my $name (@required) {
 258         return unless exists $raw->{$name};
 259       }
 260       my (%p, %done);
 261       my @p = (undef) x $pos_idx;
 262       foreach my $name (
 263         @single,
 264         ($star
 265           ? (grep { !exists $multi{$_} } keys %$raw)
 266           : ()
 267         )
 268       ) {
 269         if (exists $raw->{$name}) {
 270           if (exists $positional{$name}) {
 271             $p[$positional{$name}] = $raw->{$name}->[-1];
 272           } else {
 273             $p{$name} = $raw->{$name}->[-1];
 274           }
 275         }
 276         $done{$name} = 1;
 277       }
 278       foreach my $name (
 279         keys %multi,
 280         ($multistar
 281           ? (grep { !exists $done{$_} && !exists $multi{$_} } keys %$raw)
 282           : ()
 283         )
 284       ) {
 285         if (exists $positional{$name}) {
 286           $p[$positional{$name}] = $raw->{$name}||[];
 287         } else {
 288           $p{$name} = $raw->{$name}||[];
 289         }
 290       }
 291       $p[$pos_idx] = \%p if $have_kw;
 292       return ({}, @p);
 293     };
 294   }
 295 }
 296
 297 1;