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_section {
  62   my ($self) = @_;
  63   for ($_[1]) {
  64
  65     # GET POST PUT HEAD ...
  66
  67     /\G([A-Z]+)/gc and
  68       return $self->_http_method_match($_, $1);
  69
  70     # /...
  71
  72     /\G(?=\/)/gc and
  73       return $self->_url_path_match($_);
  74
  75     # .* and .html
  76
  77     /\G\.(\*|\w+)/gc and
  78       return $self->_url_extension_match($_, $1);
  79
  80     # (...)
  81
  82     /\G\(/gc and
  83       return $self->_parse_spec($_, pos);
  84
  85     # !something
  86
  87     /\G!/gc and
  88       return do {
  89         my $match = $self->_parse_spec_section($_);
  90         return sub {
  91           return {} unless $match->(@_);
  92           return;
  93         };
  94       };
  95   }
  96   return; # () will trigger the blam in our caller
  97 }
  98
  99 sub _parse_spec_combinator {
 100   my ($self, $spec, $match) = @_;
 101   for ($_[1]) {
 102
 103     /\G\+/gc and
 104       return $match;
 105
 106     /\G\|/gc and
 107       return do {
 108         my @match = $match;
 109         PARSE: { do {
 110           push @match, $self->_parse_spec_section($_)
 111             or $self->_blam("Unable to work out what the next section is");
 112           last PARSE if (pos == length);
 113           last PARSE unless /\G\|/gc; # give up when next thing isn't |
 114         } until (pos == length) }; # accept trailing whitespace
 115         return sub {
 116           foreach my $try (@match) {
 117             if (my @ret = $try->(@_)) {
 118               return @ret;
 119             }
 120           }
 121           return;
 122         };
 123       };
 124   }
 125   return;
 126 }
 127
 128 sub _http_method_match {
 129   my ($self, $str, $method) = @_;
 130   sub { shift->{REQUEST_METHOD} eq $method ? {} : () };
 131 }
 132
 133 sub _url_path_match {
 134   my ($self) = @_;
 135   for ($_[1]) {
 136     my @path;
 137     my $full_path = '$';
 138     PATH: while (/\G\//gc) {
 139       /\G\.\.\./gc
 140         and do {
 141           $full_path = '';
 142           last PATH;
 143         };
 144       push @path, $self->_url_path_segment_match($_)
 145         or $self->_blam("Couldn't parse path match segment");
 146     }
 147     my $re = '^()'.join('/','',@path).($full_path ? '$' : '(/.*)$');
 148     $re = qr/$re/;
 149     if ($full_path) {
 150       return sub {
 151         if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
 152           $cap[0] = {}; return @cap;
 153         }
 154         return ();
 155       };
 156     }
 157     return sub {
 158       if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
 159         $cap[0] = { PATH_INFO => pop(@cap) }; return @cap;
 160       }
 161       return ();
 162     };
 163   }
 164   return;
 165 }
 166
 167 sub _url_path_segment_match {
 168   my ($self) = @_;
 169   for ($_[1]) {
 170     # trailing / -> require / on end of URL
 171     /\G(?:(?=\s)|$)/gc and
 172       return '$';
 173     # word chars only -> exact path part match
 174     /\G(\w+)/gc and
 175       return "\Q$1";
 176     # ** -> capture unlimited path parts
 177     /\G\*\*/gc and
 178       return '(.*?[^/])';
 179     # * -> capture path part
 180     /\G\*/gc and
 181       return '([^/]+)';
 182   }
 183   return ();
 184 }
 185
 186 sub _url_extension_match {
 187   my ($self, $str, $extension) = @_;
 188   if ($extension eq '*') {
 189     sub {
 190       if ((my $tmp = shift->{PATH_INFO}) =~ s/\.(\w+)$//) {
 191         ({ PATH_INFO => $tmp }, $1);
 192       } else {
 193         ();
 194       }
 195     };
 196   } else {
 197     sub {
 198       if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) {
 199         ({ PATH_INFO => $tmp });
 200       } else {
 201         ();
 202       }
 203     };
 204   }
 205 }
 206
 207 1;