lib/Web/Simple/DispatchParser.pm

   1 package Web::Simple::DispatchParser;
   2
   3 use strict;
   4 use warnings FATAL => 'all';
   5
   6 sub DEBUG () { 0 }
   7
   8 BEGIN {
   9   if ($ENV{WEB_SIMPLE_DISPATCHPARSER_DEBUG}) {
  10     no warnings 'redefine';
  11     *DEBUG = sub () { 1 }
  12   }
  13 }
  14
  15 sub diag { if (DEBUG) { warn $_[0] } }
  16
  17 sub new { bless({}, ref($_[0])||$_[0]) }
  18
  19 sub _blam {
  20   my ($self, $error) = @_;
  21   my $hat = (' ' x (pos||0)).'^';
  22   die "Error parsing dispatch specification: ${error}\n
  23 ${_}
  24 ${hat} here\n";
  25 }
  26
  27 sub parse_dispatch_specification {
  28   my ($self, $spec) = @_;
  29   return $self->_parse_spec($spec);
  30 }
  31
  32 sub _parse_spec {
  33   my ($self, $spec, $nested) = @_;
  34   for ($_[1]) {
  35     my @match;
  36     /^\G\s*/; # eat leading whitespace
  37     PARSE: { do {
  38       push @match, $self->_parse_spec_section($_)
  39         or $self->_blam("Unable to work out what the next section is");
  40       if (/\G\)/gc) {
  41         $self->_blam("Found closing ) with no opening (") unless $nested;
  42         last PARSE;
  43       }
  44       last PARSE if (pos == length);
  45       $match[-1] = $self->_parse_spec_combinator($_, $match[-1])
  46         or $self->_blam('No valid combinator - expected + or |');
  47     } until (pos == length) }; # accept trailing whitespace
  48     if ($nested and pos == length) {
  49       pos = $nested - 1;
  50       $self->_blam("No closing ) found for opening (");
  51     }
  52     return $match[0] if (@match == 1);
  53     return sub {
  54       my $env = { %{$_[0]} };
  55       my $new_env;
  56       my @got;
  57       foreach my $match (@match) {
  58         if (my @this_got = $match->($env)) {
  59           my %change_env = %{shift(@this_got)};
  60           @{$env}{keys %change_env} = values %change_env;
  61           @{$new_env}{keys %change_env} = values %change_env;
  62           push @got, @this_got;
  63         } else {
  64           return;
  65         }
  66       }
  67       return ($new_env, @got);
  68     };
  69   }
  70 }
  71
  72 sub _parse_spec_combinator {
  73   my ($self, $spec, $match) = @_;
  74   for ($_[1]) {
  75
  76     /\G\+/gc and
  77       return $match;
  78
  79     /\G\|/gc and
  80       return do {
  81         my @match = $match;
  82         PARSE: { do {
  83           push @match, $self->_parse_spec_section($_)
  84             or $self->_blam("Unable to work out what the next section is");
  85           last PARSE if (pos == length);
  86           last PARSE unless /\G\|/gc; # give up when next thing isn't |
  87         } until (pos == length) }; # accept trailing whitespace
  88         return sub {
  89           foreach my $try (@match) {
  90             if (my @ret = $try->(@_)) {
  91               return @ret;
  92             }
  93           }
  94           return;
  95         };
  96       };
  97   }
  98   return;
  99 }
 100
 101 sub _parse_spec_section {
 102   my ($self) = @_;
 103   for ($_[1]) {
 104
 105     # GET POST PUT HEAD ...
 106
 107     /\G([A-Z]+)/gc and
 108       return $self->_http_method_match($_, $1);
 109
 110     # /...
 111
 112     /\G(?=\/)/gc and
 113       return $self->_url_path_match($_);
 114
 115     # .* and .html
 116
 117     /\G\.(\*|\w+)/gc and
 118       return $self->_url_extension_match($_, $1);
 119
 120     # (...)
 121
 122     /\G\(/gc and
 123       return $self->_parse_spec($_, pos);
 124
 125     # !something
 126
 127     /\G!/gc and
 128       return do {
 129         my $match = $self->_parse_spec_section($_);
 130         return sub {
 131           return {} unless $match->(@_);
 132           return;
 133         };
 134       };
 135
 136     # ?<param spec>
 137     /\G\?/gc and
 138       return $self->_parse_param_handler($_, 'query');
 139   }
 140   return; # () will trigger the blam in our caller
 141 }
 142
 143 sub _http_method_match {
 144   my ($self, $str, $method) = @_;
 145   sub { shift->{REQUEST_METHOD} eq $method ? {} : () };
 146 }
 147
 148 sub _url_path_match {
 149   my ($self) = @_;
 150   for ($_[1]) {
 151     my @path;
 152     my $full_path = '$';
 153     PATH: while (/\G\//gc) {
 154       /\G\.\.\./gc
 155         and do {
 156           $full_path = '';
 157           last PATH;
 158         };
 159       push @path, $self->_url_path_segment_match($_)
 160         or $self->_blam("Couldn't parse path match segment");
 161     }
 162     my $re = '^()'.join('/','',@path).($full_path ? '$' : '(/.*)$');
 163     $re = qr/$re/;
 164     if ($full_path) {
 165       return sub {
 166         if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
 167           $cap[0] = {}; return @cap;
 168         }
 169         return ();
 170       };
 171     }
 172     return sub {
 173       if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
 174         $cap[0] = { PATH_INFO => pop(@cap) }; return @cap;
 175       }
 176       return ();
 177     };
 178   }
 179   return;
 180 }
 181
 182 sub _url_path_segment_match {
 183   my ($self) = @_;
 184   for ($_[1]) {
 185     # trailing / -> require / on end of URL
 186     /\G(?:(?=\s)|$)/gc and
 187       return '$';
 188     # word chars only -> exact path part match
 189     /\G(\w+)/gc and
 190       return "\Q$1";
 191     # ** -> capture unlimited path parts
 192     /\G\*\*/gc and
 193       return '(.*?[^/])';
 194     # * -> capture path part
 195     /\G\*/gc and
 196       return '([^/]+)';
 197   }
 198   return ();
 199 }
 200
 201 sub _url_extension_match {
 202   my ($self, $str, $extension) = @_;
 203   if ($extension eq '*') {
 204     sub {
 205       if ((my $tmp = shift->{PATH_INFO}) =~ s/\.(\w+)$//) {
 206         ({ PATH_INFO => $tmp }, $1);
 207       } else {
 208         ();
 209       }
 210     };
 211   } else {
 212     sub {
 213       if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) {
 214         ({ PATH_INFO => $tmp });
 215       } else {
 216         ();
 217       }
 218     };
 219   }
 220 }
 221
 222 sub _parse_param_handler {
 223   my ($self, $spec, $type) = @_;
 224
 225   require Web::Simple::ParamParser;
 226   my $unpacker = Web::Simple::ParamParser->can("get_unpacked_${type}_from");
 227
 228   for ($_[1]) {
 229     my (@required, @single, %multi, $star, $multistar);
 230     PARAM: { do {
 231
 232       # per param flag
 233
 234       my $multi = 0;
 235
 236       # ?@foo or ?@*
 237
 238       /\G\@/gc and $multi = 1;
 239
 240       # @* or *
 241
 242       if (/\G\*/gc) {
 243
 244         $multi ? ($multistar = 1) : ($star = 1);
 245
 246         if ($star && $multistar) {
 247           $self->_blam("Can't use * and \@* in the same parameter match");
 248         }
 249       } else {
 250
 251         # @foo= or foo= or @foo~ or foo~
 252
 253         /\G(\w+)/gc or $self->_blam('Expected parameter name');
 254
 255         my $name = $1;
 256
 257         # check for = or ~ on the end
 258
 259         /\G\=/gc
 260           ? push(@required, $name)
 261           : (/\G\~/gc or $self->_blam('Expected = or ~ after parameter name'));
 262
 263         # record the key in the right category depending on the multi (@) flag
 264
 265         $multi ? ($multi{$name} = 1) : (push @single, $name);
 266       }
 267     } while (/\G\&/gc) }
 268
 269     return sub {
 270       my $raw = $unpacker->($_[0]);
 271       foreach my $name (@required) {
 272         return unless exists $raw->{$name};
 273       }
 274       my %p;
 275       foreach my $name (
 276         @single,
 277         ($star
 278           ? (grep { !exists $multi{$_} } keys %$raw)
 279           : ()
 280         )
 281       ) {
 282         $p{$name} = $raw->{$name}->[-1] if exists $raw->{$name};
 283       }
 284       foreach my $name (
 285         keys %multi,
 286         ($multistar
 287           ? (grep { !exists $p{$_} } keys %$raw)
 288           : ()
 289         )
 290       ) {
 291         $p{$name} = $raw->{$name}||[];
 292       }
 293       return ({}, \%p);
 294     };
 295   }
 296 }
 297
 298 1;