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     while (/\G\//gc) {
 138       push @path, $self->_url_path_segment_match($_)
 139         or $self->_blam("Couldn't parse path match segment");
 140     }
 141     my $re = '^()'.join('/','',@path).'$';
 142     return sub {
 143       if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
 144         $cap[0] = {}; return @cap;
 145       }
 146       return ();
 147     };
 148   }
 149   return;
 150 }
 151
 152 sub _url_path_segment_match {
 153   my ($self) = @_;
 154   for ($_[1]) {
 155     # trailing / -> require / on end of URL
 156     /\G(?:(?=\s)|$)/gc and
 157       return '$';
 158     # word chars only -> exact path part match
 159     /\G(\w+)/gc and
 160       return "\Q$1";
 161     # ** -> capture unlimited path parts
 162     /\G\*\*/gc and
 163       return '(.*?[^/])';
 164     # * -> capture path part
 165     /\G\*/gc and
 166       return '([^/]+)';
 167   }
 168   return ();
 169 }
 170
 171 sub _url_extension_match {
 172   my ($self, $str, $extension) = @_;
 173   if ($extension eq '*') {
 174     sub {
 175       if ((my $tmp = shift->{PATH_INFO}) =~ s/\.(\w+)$//) {
 176         ({ PATH_INFO => $tmp }, $1);
 177       } else {
 178         ();
 179       }
 180     };
 181   } else {
 182     sub {
 183       if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) {
 184         ({ PATH_INFO => $tmp });
 185       } else {
 186         ();
 187       }
 188     };
 189   }
 190 }
 191
 192 1;