dispatch parser

diff --git a/lib/Web/Simple/DispatchParser.pm b/lib/Web/Simple/DispatchParser.pm
new file mode 100644 (file)
index 0000000..71568de
--- /dev/null
+++ b/lib/Web/Simple/DispatchParser.pm
@@ -0,0 +1,129 @@
+package Web::Simple::DispatchParser;
+
+use strict;
+use warnings FATAL => 'all';
+
+sub new { bless({}, ref($_[0])||$_[0]) }
+
+sub _blam {
+  my ($self, $error) = @_;
+  my $hat = (' ' x pos).'^';
+  die "Error parsing dispatch specification: ${error}\n
+${_}
+${hat} here\n";
+}
+
+sub parse_dispatch_specification {
+  my ($self, $spec) = @_;
+  for ($spec) {
+    my @match;
+    local $self->{already_have};
+    /^\G\s*/; # eat leading whitespace
+    PARSE: { do {
+      push @match, $self->_parse_spec_section($spec)
+        or $self->_blam("Unable to work out what the next section is");
+      last PARSE if (pos == length);
+      /\G\s+/gc or $self->_blam('Spec sections not space separated');
+    } until (pos == length) }; # accept trailing whitespace
+    return $match[0] if (@match == 1);
+    return sub {
+      my $env = { %{$_[0]} };
+      my $new_env;
+      my @got;
+      foreach my $match (@match) {
+        if (my @this_got = $match->($env)) {
+          my %change_env = %{shift(@this_got)};
+          @{$env}{keys %change_env} = values %change_env;
+          @{$new_env}{keys %change_env} = values %change_env;
+          push @got, @this_got;
+        } else {
+          return;
+        }
+      }
+      return ($new_env, @got);
+    };
+  }
+}
+
+sub _dupe_check {
+  my ($self, $type) = @_;
+  $self->_blam("Can't have more than one ${type} match in a specification")
+    if $self->{already_have}{$type};
+  $self->{already_have}{$type} = 1;
+}
+
+sub _parse_spec_section {
+  my ($self) = @_;
+  for ($_[1]) {
+
+    # GET POST PUT HEAD ...
+
+    /\G([A-Z]+)/gc and
+      return $self->_http_method_match($_, $1);
+
+    # /...
+
+    /\G(?=\/)/gc and
+      return $self->_url_path_match($_);
+
+    /\G\.(\w+)/gc and
+      return $self->_url_extension_match($_, $1);
+  }
+  return; # () will trigger the blam in our caller
+}
+
+sub _http_method_match {
+  my ($self, $str, $method) = @_;
+  $self->_dupe_check('method');
+  sub { shift->{REQUEST_METHOD} eq $method ? {} : () };
+}
+
+sub _url_path_match {
+  my ($self) = @_;
+  $self->_dupe_check('path');
+  for ($_[1]) {
+    my @path;
+    while (/\G\//gc) {
+      push @path, $self->_url_path_segment_match($_)
+        or $self->_blam("Couldn't parse path match segment");
+    }
+    my $re = '^()'.join('/','',@path).'$';
+    return sub {
+      if (my @cap = (shift->{PATH_INFO} =~ /$re/)) {
+        $cap[0] = {}; return @cap;
+      }
+      return ();
+    };
+  }
+  return;
+}
+
+sub _url_path_segment_match {
+  my ($self) = @_;
+  for ($_[1]) {
+    # trailing / -> require / on end of URL
+    /\G(?:(?=\s)|$)/gc and
+      return '$';
+    # word chars only -> exact path part match
+    /\G(\w+)/gc and
+      return "\Q$1";
+    # * -> capture path part
+    /\G\*/gc and
+      return '([^/]+)';
+  }
+  return ();
+}
+
+sub _url_extension_match {
+  my ($self, $str, $extension) = @_;
+  $self->_dupe_check('extension');
+  sub {
+    if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) {
+      ({ PATH_INFO => $tmp });
+    } else {
+      ();
+    }
+  };
+}
+
+1;

diff --git a/t/dispatch_parser.t b/t/dispatch_parser.t
new file mode 100644 (file)
index 0000000..ab6206e
--- /dev/null
+++ b/t/dispatch_parser.t
@@ -0,0 +1,89 @@
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More qw(no_plan);
+
+use Web::Simple::DispatchParser;
+
+my $dp = Web::Simple::DispatchParser->new;
+
+my $get = $dp->parse_dispatch_specification('GET');
+
+is_deeply(
+  [ $get->({ REQUEST_METHOD => 'GET' }) ],
+  [ {} ],
+  'GET matches'
+);
+
+is_deeply(
+  [ $get->({ REQUEST_METHOD => 'POST' }) ],
+  [],
+  'POST does not match'
+);
+
+ok(
+  !eval { $dp->parse_dispatch_specification('GET POST'); 1; },
+  "Don't yet allow two methods"
+);
+
+my $html = $dp->parse_dispatch_specification('.html');
+
+is_deeply(
+  [ $html->({ PATH_INFO => '/foo/bar.html' }) ],
+  [ { PATH_INFO => '/foo/bar' } ],
+  '.html matches'
+);
+
+is_deeply(
+  [ $html->({ PATH_INFO => '/foo/bar.xml' }) ],
+  [],
+  '.xml does not match .html'
+);
+
+my $slash = $dp->parse_dispatch_specification('/');
+
+is_deeply(
+  [ $slash->({ PATH_INFO => '/' }) ],
+  [ {} ],
+  '/ matches /'
+);
+
+is_deeply(
+  [ $slash->({ PATH_INFO => '/foo' }) ],
+  [ ],
+  '/foo does not match /'
+);
+
+my $post = $dp->parse_dispatch_specification('/post/*');
+
+is_deeply(
+  [ $post->({ PATH_INFO => '/post/one' }) ],
+  [ {}, 'one' ],
+  '/post/one parses out one'
+);
+
+is_deeply(
+  [ $post->({ PATH_INFO => '/post/one/' }) ],
+  [],
+  '/post/one/ does not match'
+);
+
+my $combi = $dp->parse_dispatch_specification('GET /post/*');
+
+is_deeply(
+  [ $combi->({ PATH_INFO => '/post/one', REQUEST_METHOD => 'GET' }) ],
+  [ {}, 'one' ],
+  '/post/one parses out one'
+);
+
+is_deeply(
+  [ $combi->({ PATH_INFO => '/post/one/', REQUEST_METHOD => 'GET' }) ],
+  [],
+  '/post/one/ does not match'
+);
+
+is_deeply(
+  [ $combi->({ PATH_INFO => '/post/one', REQUEST_METHOD => 'POST' }) ],
+  [],
+  'POST /post/one does not match'
+);