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, $nested) = @_;
  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       if (/\G\)/gc) {
  31         $self->_blam("Found closing ) with no opening (") unless $nested;
  32         last PARSE;
  33       }
  34       last PARSE if (pos == length);
  35       $match[-1] = $self->_parse_spec_combinator($_, $match[-1])
  36         or $self->_blam('No valid combinator - expected + or |');
  37     } until (pos == length) }; # accept trailing whitespace
  38     if ($nested and pos == length) {
  39       pos = $nested;
  40       $self->_blam("No closing ) found for opening (");
  41     }
  42     return $match[0] if (@match == 1);
  43     return sub {
  44       my $env = { %{$_[0]} };
  45       my $new_env;
  46       my @got;
  47       foreach my $match (@match) {
  48         if (my @this_got = $match->($env)) {
  49           my %change_env = %{shift(@this_got)};
  50           @{$env}{keys %change_env} = values %change_env;
  51           @{$new_env}{keys %change_env} = values %change_env;
  52           push @got, @this_got;
  53         } else {
  54           return;
  55         }
  56       }
  57       return ($new_env, @got);
  58     };
  59   }
  60 }
  61
  62 sub _dupe_check {
  63   my ($self, $type) = @_;
  64   $self->_blam("Can't have more than one ${type} match in a specification")
  65     if $self->{already_have}{$type};
  66   $self->{already_have}{$type} = 1;
  67 }
  68
  69 sub _parse_spec_section {
  70   my ($self) = @_;
  71   for ($_[1]) {
  72
  73     # GET POST PUT HEAD ...
  74
  75     /\G([A-Z]+)/gc and
  76       return $self->_http_method_match($_, $1);
  77
  78     # /...
  79
  80     /\G(?=\/)/gc and
  81       return $self->_url_path_match($_);
  82
  83     # .* and .html
  84
  85     /\G\.(\*|\w+)/gc and
  86       return $self->_url_extension_match($_, $1);
  87
  88     # (
  89
  90     /\G\(/gc and
  91       return $self->_parse_spec($_, pos);
  92   }
  93   return; # () will trigger the blam in our caller
  94 }
  95
  96 sub _parse_spec_combinator {
  97   my ($self, $spec, $match) = @_;
  98   for ($_[1]) {
  99
 100     /\G\+/gc and
 101       return $match;
 102
 103     /\G\|/gc and
 104       return do {
 105         my @match = $match;
 106         PARSE: { do {
 107           local $self->{already_have};
 108           push @match, $self->_parse_spec_section($_)
 109             or $self->_blam("Unable to work out what the next section is");
 110           last PARSE if (pos == length);
 111           last PARSE unless /\G\|/gc; # give up when next thing isn't |
 112         } until (pos == length) }; # accept trailing whitespace
 113         return sub {
 114           foreach my $try (@match) {
 115             if (my @ret = $try->(@_)) {
 116               return @ret;
 117             }
 118           }
 119           return;
 120         };
 121       };
 122   }
 123   return;
 124 }
 125
 126 sub _http_method_match {
 127   my ($self, $str, $method) = @_;
 128   $self->_dupe_check('method');
 129   sub { shift->{REQUEST_METHOD} eq $method ? {} : () };
 130 }
 131
 132 sub _url_path_match {
 133   my ($self) = @_;
 134   $self->_dupe_check('path');
 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   $self->_dupe_check('extension');
 174   if ($extension eq '*') {
 175     sub {
 176       if ((my $tmp = shift->{PATH_INFO}) =~ s/\.(\w+)$//) {
 177         ({ PATH_INFO => $tmp }, $1);
 178       } else {
 179         ();
 180       }
 181     };
 182   } else {
 183     sub {
 184       if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) {
 185         ({ PATH_INFO => $tmp });
 186       } else {
 187         ();
 188       }
 189     };
 190   }
 191 }
 192
 193 1;