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   for ($spec) {
  19     my @match;
  20     local $self->{already_have};
  21     /^\G\s*/; # eat leading whitespace
  22     PARSE: { do {
  23       push @match, $self->_parse_spec_section($spec)
  24         or $self->_blam("Unable to work out what the next section is");
  25       last PARSE if (pos == length);
  26       /\G\+/gc or $self->_blam('Spec sections must be separated by +');
  27     } until (pos == length) }; # accept trailing whitespace
  28     return $match[0] if (@match == 1);
  29     return sub {
  30       my $env = { %{$_[0]} };
  31       my $new_env;
  32       my @got;
  33       foreach my $match (@match) {
  34         if (my @this_got = $match->($env)) {
  35           my %change_env = %{shift(@this_got)};
  36           @{$env}{keys %change_env} = values %change_env;
  37           @{$new_env}{keys %change_env} = values %change_env;
  38           push @got, @this_got;
  39         } else {
  40           return;
  41         }
  42       }
  43       return ($new_env, @got);
  44     };
  45   }
  46 }
  47
  48 sub _dupe_check {
  49   my ($self, $type) = @_;
  50   $self->_blam("Can't have more than one ${type} match in a specification")
  51     if $self->{already_have}{$type};
  52   $self->{already_have}{$type} = 1;
  53 }
  54
  55 sub _parse_spec_section {
  56   my ($self) = @_;
  57   for ($_[1]) {
  58
  59     # GET POST PUT HEAD ...
  60
  61     /\G([A-Z]+)/gc and
  62       return $self->_http_method_match($_, $1);
  63
  64     # /...
  65
  66     /\G(?=\/)/gc and
  67       return $self->_url_path_match($_);
  68
  69     /\G\.(\w+)/gc and
  70       return $self->_url_extension_match($_, $1);
  71   }
  72   return; # () will trigger the blam in our caller
  73 }
  74
  75 sub _http_method_match {
  76   my ($self, $str, $method) = @_;
  77   $self->_dupe_check('method');
  78   sub { shift->{REQUEST_METHOD} eq $method ? {} : () };
  79 }
  80
  81 sub _url_path_match {
  82   my ($self) = @_;
  83   $self->_dupe_check('path');
  84   for ($_[1]) {
  85     my @path;
  86     while (/\G\//gc) {
  87       push @path, $self->_url_path_segment_match($_)
  88         or $self->_blam("Couldn't parse path match segment");
  89     }
  90     my $re = '^()'.join('/','',@path).'$';
  91     return sub {
  92       if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
  93         $cap[0] = {}; return @cap;
  94       }
  95       return ();
  96     };
  97   }
  98   return;
  99 }
 100
 101 sub _url_path_segment_match {
 102   my ($self) = @_;
 103   for ($_[1]) {
 104     # trailing / -> require / on end of URL
 105     /\G(?:(?=\s)|$)/gc and
 106       return '$';
 107     # word chars only -> exact path part match
 108     /\G(\w+)/gc and
 109       return "\Q$1";
 110     # * -> capture path part
 111     /\G\*/gc and
 112       return '([^/]+)';
 113   }
 114   return ();
 115 }
 116
 117 sub _url_extension_match {
 118   my ($self, $str, $extension) = @_;
 119   $self->_dupe_check('extension');
 120   sub {
 121     if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) {
 122       ({ PATH_INFO => $tmp });
 123     } else {
 124       ();
 125     }
 126   };
 127 }
 128
 129 1;