X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FWeb%2FDispatch%2FParser.pm;h=cee4e1b5dbdf1c9536c4d3db3bafc0ced78c4b49;hb=63753442ca17095647197c331d544744ff8d39c7;hp=a4c2640b27cc4825194c3055db8de801b47fba5a;hpb=e954644cda6c101ac4ccb3b5753c249aaf79d5c8;p=catagits%2FWeb-Simple.git

diff --git a/lib/Web/Dispatch/Parser.pm b/lib/Web/Dispatch/Parser.pm
index a4c2640..cee4e1b 100644
--- 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,20 +43,23 @@ sub parse {
 
 sub _parse_spec {
   my ($self, $spec, $nested) = @_;
+  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 (");
     }
@@ -83,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
@@ -115,6 +131,10 @@ sub _parse_spec_section {
     # %<param spec>
     /\G\%/gc and
       return $self->_parse_param_handler($_, 'body');
+
+    # *<param spec>
+    /\G\*/gc and
+      return $self->_parse_param_handler($_, 'uploads');
   }
   return; # () will trigger the blam in our caller
 }
@@ -122,26 +142,52 @@ 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) {
       /\G\.\.\./gc
         and do {
           $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 = '(|/.*)';
+          last PATH;
+        };
+      /\G\.\*/gc
+        and $keep_dot = 1;
+
+      last PATH if $keep_dot;
     }
-    if (@path && !$end) {
+    if (@path && !$end && !$keep_dot) {
       length and $_ .= '(?:\.\w+)?' for $path[-1];
     }
     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;
@@ -154,14 +200,29 @@ sub _url_path_segment_match {
     /\G(?:(?=[+|\)])|$)/gc and
       return '';
     # word chars only -> exact path part match
-    /\G([\w\-]+)/gc and
+    /
+        \G(
+            (?:             # start matching at a space followed by:
+                    [\w\-]  # word chars or dashes
+                |           # OR
+                    \.      # a period
+                    (?!\.)  # not followed by another period
+            )
+            +               # then grab as far as possible
+        )
+    /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 ();
 }
@@ -169,11 +230,9 @@ sub _url_path_segment_match {
 sub _parse_param_handler {
   my ($self, $spec, $type) = @_;
 
-  require Web::Simple::ParamParser;
-  my $unpacker = Web::Simple::ParamParser->can("get_unpacked_${type}_from");
-
   for ($_[1]) {
     my (@required, @single, %multi, $star, $multistar, %positional, $have_kw);
+    my %spec;
     my $pos_idx = 0;
     PARAM: { do {
 
@@ -191,76 +250,33 @@ sub _parse_param_handler {
 
         $self->_blam("* is always named; no need to supply :") if $is_kw;
 
-        $multi ? ($multistar = 1) : ($star = 1);
-
-        $have_kw = 1;
-
-        if ($star && $multistar) {
-          $self->_blam("Can't use * and \@* in the same parameter match");
+        if ($star) {
+          $self->_blam("Can only use one * or \@* in a parameter match");
         }
+
+        $spec{star} = { multi => $multi };
       } else {
 
         # @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;
 
         # check for = or ~ on the end
 
         /\G\=/gc
-          ? push(@required, $name)
+          ? push(@{$spec{required}||=[]}, $name)
           : (/\G\~/gc or $self->_blam('Expected = or ~ after parameter name'));
 
-        # record the key in the right category depending on the multi (@) flag
-
-        $multi ? ($multi{$name} = 1) : (push @single, $name);
-
         # record positional or keyword
 
-        $is_kw ? ($have_kw = 1) : ($positional{$name} = $pos_idx++);
+        push @{$spec{$is_kw ? 'named' : 'positional'}||=[]},
+          { name => $name, multi => $multi };
       }
     } while (/\G\&/gc) }
 
-    return sub {
-      my $raw = $unpacker->($_[0]);
-      foreach my $name (@required) {
-        return unless exists $raw->{$name};
-      }
-      my (%p, %done);
-      my @p = (undef) x $pos_idx;
-      foreach my $name (
-        @single,
-        ($star
-          ? (grep { !exists $multi{$_} } keys %$raw)
-          : ()
-        )
-      ) {
-        if (exists $raw->{$name}) {
-          if (exists $positional{$name}) {
-            $p[$positional{$name}] = $raw->{$name}->[-1];
-          } else {
-            $p{$name} = $raw->{$name}->[-1];
-          }
-        }
-        $done{$name} = 1;
-      }
-      foreach my $name (
-        keys %multi,
-        ($multistar
-          ? (grep { !exists $done{$_} && !exists $multi{$_} } keys %$raw)
-          : ()
-        )
-      ) {
-        if (exists $positional{$name}) {
-          $p[$positional{$name}] = $raw->{$name}||[];
-        } else {
-          $p{$name} = $raw->{$name}||[];
-        }
-      }
-      $p[$pos_idx] = \%p if $have_kw;
-      return ({}, @p);
-    };
+    return Web::Dispatch::Predicates->can("match_${type}")->(\%spec);
   }
 }