handle ) as last character of composite spec

[catagits/Web-Simple.git] / lib / Web / Dispatch / Parser.pm

diff --git a/lib/Web/Dispatch/Parser.pm b/lib/Web/Dispatch/Parser.pm
index d77d418..cee4e1b 100644 (file)
--- a/lib/Web/Dispatch/Parser.pm
+++ b/lib/Web/Dispatch/Parser.pm
@@ -19,6 +19,14 @@ has _cache => (
 
 sub diag { if (DEBUG) { warn $_[0] } }
 
+sub _wtf {
+  my ($self, $error) = @_;
+  my $hat = (' ' x (pos||0)).'^';
+  warn "Warning parsing dispatch specification: ${error}\n
+${_}
+${hat} here\n";
+}
+
 sub _blam {
   my ($self, $error) = @_;
   my $hat = (' ' x (pos||0)).'^';
@@ -35,21 +43,23 @@ sub parse {
 
 sub _parse_spec {
   my ($self, $spec, $nested) = @_;
-  return sub { {} } unless length($spec);
+  return match_true() unless length($spec);
   for ($_[1]) {
     my @match;
+    my $close;
     PARSE: { do {
       push @match, $self->_parse_spec_section($_)
         or $self->_blam("Unable to work out what the next section is");
       if (/\G\)/gc) {
         $self->_blam("Found closing ) with no opening (") unless $nested;
+        $close = 1;
         last PARSE;
       }
       last PARSE if (pos == length);
       $match[-1] = $self->_parse_spec_combinator($_, $match[-1])
         or $self->_blam('No valid combinator - expected + or |');
     } until (pos == length) }; # accept trailing whitespace
-    if ($nested and pos == length) {
+    if (!$close and $nested and pos == length) {
       pos = $nested - 1;
       $self->_blam("No closing ) found for opening (");
     }
@@ -84,6 +94,11 @@ sub _parse_spec_section {
   my ($self) = @_;
   for ($_[1]) {
 
+    # ~
+
+    /\G~/gc and
+      return match_path('^$');
+
     # GET POST PUT HEAD ...
 
     /\G([A-Z]+)/gc and
@@ -127,7 +142,7 @@ sub _parse_spec_section {
 sub _url_path_match {
   my ($self) = @_;
   for ($_[1]) {
-    my @path;
+    my (@path, @names, $seen_nameless);
     my $end = '';
     my $keep_dot;
     PATH: while (/\G\//gc) {
@@ -136,18 +151,33 @@ sub _url_path_match {
           $end = '(/.*)';
           last PATH;
         };
-      push @path, $self->_url_path_segment_match($_)
+
+      my ($segment) = $self->_url_path_segment_match($_)
         or $self->_blam("Couldn't parse path match segment");
+
+      if (ref($segment)) {
+        ($segment, $keep_dot, my $name) = @$segment;
+        if (defined($name)) {
+          $self->_blam("Can't mix positional and named captures in path match")
+            if $seen_nameless;
+          push @names, $name;
+        } else {
+          $self->_blam("Can't mix positional and named captures in path match")
+            if @names;
+          $seen_nameless = 1;
+        }
+      }
+      push @path, $segment;
+
       /\G\.\.\./gc
         and do {
-          $end = '(.*)';
+          $end = '(|/.*)';
           last PATH;
         };
       /\G\.\*/gc
-        and do {
-          $keep_dot = 1;
-          last PATH;
-        };
+        and $keep_dot = 1;
+
+      last PATH if $keep_dot;
     }
     if (@path && !$end && !$keep_dot) {
       length and $_ .= '(?:\.\w+)?' for $path[-1];
@@ -155,9 +185,9 @@ sub _url_path_match {
     my $re = '^('.join('/','',@path).')'.$end.'$';
     $re = qr/$re/;
     if ($end) {
-      return match_path_strip($re);
+      return match_path_strip($re, @names ? \@names : ());
     } else {
-      return match_path($re);
+      return match_path($re, @names ? \@names : ());
     }
   }
   return;
@@ -183,11 +213,16 @@ sub _url_path_segment_match {
     /gcx and
       return "\Q$1";
     # ** -> capture unlimited path parts
-    /\G\*\*/gc and
-      return '(.*?[^/])';
+    /\G\*\*(?:(\.\*)?\:(\w+))?/gc and
+      return [ '(.*?[^/])', $1, $2 ];
     # * -> capture path part
-    /\G\*/gc and
-      return '([^/]+?)';
+    # *:name -> capture named path part
+    /\G\*(?:(\.\*)?\:(\w+))?/gc and
+      return [ '([^/]+?)', $1, $2 ];
+
+    # :name -> capture named path part
+    /\G\:(\w+)/gc and
+      return [ '([^/]+?)', 0, $1 ];
   }
   return ();
 }
@@ -224,7 +259,7 @@ sub _parse_param_handler {
 
         # @foo= or foo= or @foo~ or foo~
 
-        /\G(\w+)/gc or $self->_blam('Expected parameter name');
+        /\G([\w.]*)/gc or $self->_blam('Expected parameter name');
 
         my $name = $1;