lib/Web/Simple/DispatchParser.pm

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