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).'^';
  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) = @_;
  23   for ($_[1]) {
  24     my @match;
  25     local $self->{already_have};
  26     /^\G\s*/; # eat leading whitespace
  27     PARSE: { do {
  28       push @match, $self->_parse_spec_section($_)
  29         or $self->_blam("Unable to work out what the next section is");
  30       last PARSE if (pos == length);
  31       $match[-1] = $self->_parse_spec_combinator($_, $match[-1])
  32         or $self->_blam('No valid combinator - expected + or |');
  33     } until (pos == length) }; # accept trailing whitespace
  34     return $match[0] if (@match == 1);
  35     return sub {
  36       my $env = { %{$_[0]} };
  37       my $new_env;
  38       my @got;
  39       foreach my $match (@match) {
  40         if (my @this_got = $match->($env)) {
  41           my %change_env = %{shift(@this_got)};
  42           @{$env}{keys %change_env} = values %change_env;
  43           @{$new_env}{keys %change_env} = values %change_env;
  44           push @got, @this_got;
  45         } else {
  46           return;
  47         }
  48       }
  49       return ($new_env, @got);
  50     };
  51   }
  52 }
  53
  54 sub _dupe_check {
  55   my ($self, $type) = @_;
  56   $self->_blam("Can't have more than one ${type} match in a specification")
  57     if $self->{already_have}{$type};
  58   $self->{already_have}{$type} = 1;
  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   return; # () will trigger the blam in our caller
  81 }
  82
  83 sub _parse_spec_combinator {
  84   my ($self, $spec, $match) = @_;
  85   for ($_[1]) {
  86
  87     /\G\+/gc and
  88       return $match;
  89
  90     /\G\|/gc and
  91       return do {
  92         my @match = $match;
  93         PARSE: { do {
  94           local $self->{already_have};
  95           push @match, $self->_parse_spec_section($_)
  96             or $self->_blam("Unable to work out what the next section is");
  97           last PARSE if (pos == length);
  98           last PARSE unless /\G\|/gc; # give up when next thing isn't |
  99         } until (pos == length) }; # accept trailing whitespace
 100         return sub {
 101           foreach my $try (@match) {
 102             if (my @ret = $try->(@_)) {
 103               return @ret;
 104             }
 105           }
 106           return;
 107         };
 108       };
 109   }
 110   return;
 111 }
 112
 113 sub _http_method_match {
 114   my ($self, $str, $method) = @_;
 115   $self->_dupe_check('method');
 116   sub { shift->{REQUEST_METHOD} eq $method ? {} : () };
 117 }
 118
 119 sub _url_path_match {
 120   my ($self) = @_;
 121   $self->_dupe_check('path');
 122   for ($_[1]) {
 123     my @path;
 124     while (/\G\//gc) {
 125       push @path, $self->_url_path_segment_match($_)
 126         or $self->_blam("Couldn't parse path match segment");
 127     }
 128     my $re = '^()'.join('/','',@path).'$';
 129     return sub {
 130       if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
 131         $cap[0] = {}; return @cap;
 132       }
 133       return ();
 134     };
 135   }
 136   return;
 137 }
 138
 139 sub _url_path_segment_match {
 140   my ($self) = @_;
 141   for ($_[1]) {
 142     # trailing / -> require / on end of URL
 143     /\G(?:(?=\s)|$)/gc and
 144       return '$';
 145     # word chars only -> exact path part match
 146     /\G(\w+)/gc and
 147       return "\Q$1";
 148     # ** -> capture unlimited path parts
 149     /\G\*\*/gc and
 150       return '(.*?[^/])';
 151     # * -> capture path part
 152     /\G\*/gc and
 153       return '([^/]+)';
 154   }
 155   return ();
 156 }
 157
 158 sub _url_extension_match {
 159   my ($self, $str, $extension) = @_;
 160   $self->_dupe_check('extension');
 161   if ($extension eq '*') {
 162     sub {
 163       if ((my $tmp = shift->{PATH_INFO}) =~ s/\.(\w+)$//) {
 164         ({ PATH_INFO => $tmp }, $1);
 165       } else {
 166         ();
 167       }
 168     };
 169   } else {
 170     sub {
 171       if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) {
 172         ({ PATH_INFO => $tmp });
 173       } else {
 174         ();
 175       }
 176     };
 177   }
 178 }
 179
 180 1;