fixed url path segment match regex so that trailing slashes in /path/info/ + query...

[catagits/Web-Simple.git] / lib / Web / Simple / DispatchParser.pm

diff --git a/lib/Web/Simple/DispatchParser.pm b/lib/Web/Simple/DispatchParser.pm
index 1be1cf2..b580a91 100644 (file)
--- a/lib/Web/Simple/DispatchParser.pm
+++ b/lib/Web/Simple/DispatchParser.pm
@@ -3,6 +3,17 @@ package Web::Simple::DispatchParser;
 use strict;
 use warnings FATAL => 'all';
 
+sub DEBUG () { 0 }
+
+BEGIN {
+  if ($ENV{WEB_SIMPLE_DISPATCHPARSER_DEBUG}) {
+    no warnings 'redefine';
+    *DEBUG = sub () { 1 }
+  }
+}
+
+sub diag { if (DEBUG) { warn $_[0] } }
+
 sub new { bless({}, ref($_[0])||$_[0]) }
 
 sub _blam {
@@ -125,6 +136,10 @@ sub _parse_spec_section {
     # ?<param spec>
     /\G\?/gc and
       return $self->_parse_param_handler($_, 'query');
+
+    # %<param spec>
+    /\G\%/gc and
+      return $self->_parse_param_handler($_, 'body');
   }
   return; # () will trigger the blam in our caller
 }
@@ -172,7 +187,7 @@ sub _url_path_segment_match {
   my ($self) = @_;
   for ($_[1]) {
     # trailing / -> require / on end of URL
-    /\G(?:(?=\s)|$)/gc and
+    /\G(?:(?=[+|\)])|$)/gc and
       return '$';
     # word chars only -> exact path part match
     /\G(\w+)/gc and
@@ -215,26 +230,35 @@ sub _parse_param_handler {
   my $unpacker = Web::Simple::ParamParser->can("get_unpacked_${type}_from");
 
   for ($_[1]) {
-    my (@required, @single, %multi, $star, $multistar) = @_;
+    my (@required, @single, %multi, $star, $multistar, %positional, $have_kw);
+    my $pos_idx = 0;
     PARAM: { do {
 
-      # per param flag
+      # ?:foo or ?@:foo
 
-      my $multi = 0;
+      my $is_kw = /\G\:/gc;
 
       # ?@foo or ?@*
 
-      /\G\@/gc and $multi = 1;
+      my $multi = /\G\@/gc;
 
       # @* or *
 
-      if (/\G\*/) {
+      if (/\G\*/gc) {
+
+        $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");
+        }
       } else {
 
         # @foo= or foo= or @foo~ or foo~
-        
+
         /\G(\w+)/gc or $self->_blam('Expected parameter name');
 
         my $name = $1;
@@ -247,7 +271,11 @@ sub _parse_param_handler {
 
         # record the key in the right category depending on the multi (@) flag
 
-        $multi ? (push @single, $name) : ($multi{$name} = 1);
+        $multi ? ($multi{$name} = 1) : (push @single, $name);
+
+        # record positional or keyword
+
+        $is_kw ? ($have_kw = 1) : ($positional{$name} = $pos_idx++);
       }
     } while (/\G\&/gc) }
 
@@ -256,7 +284,8 @@ sub _parse_param_handler {
       foreach my $name (@required) {
         return unless exists $raw->{$name};
       }
-      my %p;
+      my (%p, %done);
+      my @p = (undef) x $pos_idx;
       foreach my $name (
         @single,
         ($star
@@ -264,18 +293,30 @@ sub _parse_param_handler {
           : ()
         )
       ) {
-        $p{$name} = $raw->{$name}->[-1] if exists $raw->{$name};
+        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 $p{$_} } keys %$raw)
+          ? (grep { !exists $done{$_} && !exists $multi{$_} } keys %$raw)
           : ()
         )
       ) {
-        $p{$name} = $raw->{$name}||[];
+        if (exists $positional{$name}) {
+          $p[$positional{$name}] = $raw->{$name}||[];
+        } else {
+          $p{$name} = $raw->{$name}||[];
+        }
       }
-      return ({}, \%p);
+      $p[$pos_idx] = \%p if $have_kw;
+      return ({}, @p);
     };
   }
 }