first cut of query/body parsing, no body support, no tests

diff --git a/lib/Web/Simple.pm b/lib/Web/Simple.pm
index fe1722e..01f6369 100644 (file)
--- a/lib/Web/Simple.pm
+++ b/lib/Web/Simple.pm
@@ -431,6 +431,50 @@ Additionally,
 will match any extension and supplies the stripped extension as a match
 argument.
 
+=head3 Query and body parameter matches
+
+Query and body parameters can be match via
+
+  sub (?<param spec>) { # match URI query
+  sub (%<param spec>) { # match body params
+
+The body is only matched if the content type is
+application/x-www-form-urlencoded (note this means that Web::Simple does
+not yet handle uploads; this will be addressed in a later release).
+
+The param spec is elements of one of the following forms -
+
+  param~        # optional parameter
+  param=        # required parameter
+  @param~       # optional multiple parameter
+  @param=       # required multiple parameter
+  *             # include all other parameters
+  @*            # include all other parameters as multiple
+
+separated by the & character.
+
+So, to match a page parameter with an optional order_by parameter one
+would write:
+
+  sub (?page=&order_by~) {
+
+Parameters selected are turned into a hashref; in the case of singular
+parameters then if multiple values are found the last one is used. In the
+case of multiple parameters an arrayref of all values (or an empty arrayref
+for a missing optional) is used. The resulting hashref is provided as a
+match argument. So we might write something like:
+
+  sub (?page=&order_by~) {
+    my ($self, $p) = @_;
+    return unless $p->{page} =~ /^\d+$/;
+    $p->{order_by} ||= 'id';
+    response_filter {
+      $_[1]->search_rs({}, $p);
+    }
+  }
+
+to implement paging and ordering against a L<DBIx::Class::ResultSet> object.
+
 =head3 Combining matches
 
 Matches may be combined with the + character - e.g.

diff --git a/lib/Web/Simple/DispatchParser.pm b/lib/Web/Simple/DispatchParser.pm
index 1882c98..1be1cf2 100644 (file)
--- a/lib/Web/Simple/DispatchParser.pm
+++ b/lib/Web/Simple/DispatchParser.pm
@@ -58,6 +58,35 @@ sub _parse_spec {
   }
 }
 
+sub _parse_spec_combinator {
+  my ($self, $spec, $match) = @_;
+  for ($_[1]) {
+
+    /\G\+/gc and
+      return $match;
+
+    /\G\|/gc and
+      return do {
+        my @match = $match;
+        PARSE: { do {
+          push @match, $self->_parse_spec_section($_)
+            or $self->_blam("Unable to work out what the next section is");
+          last PARSE if (pos == length);
+          last PARSE unless /\G\|/gc; # give up when next thing isn't |
+        } until (pos == length) }; # accept trailing whitespace
+        return sub {
+          foreach my $try (@match) {
+            if (my @ret = $try->(@_)) {
+              return @ret;
+            }
+          }
+          return;
+        };
+      };
+  }
+  return;
+}
+
 sub _parse_spec_section {
   my ($self) = @_;
   for ($_[1]) {
@@ -92,37 +121,12 @@ sub _parse_spec_section {
           return;
         };
       };
-  }
-  return; # () will trigger the blam in our caller
-}
 
-sub _parse_spec_combinator {
-  my ($self, $spec, $match) = @_;
-  for ($_[1]) {
-
-    /\G\+/gc and
-      return $match;
-
-    /\G\|/gc and
-      return do {
-        my @match = $match;
-        PARSE: { do {
-          push @match, $self->_parse_spec_section($_)
-            or $self->_blam("Unable to work out what the next section is");
-          last PARSE if (pos == length);
-          last PARSE unless /\G\|/gc; # give up when next thing isn't |
-        } until (pos == length) }; # accept trailing whitespace
-        return sub {
-          foreach my $try (@match) {
-            if (my @ret = $try->(@_)) {
-              return @ret;
-            }
-          }
-          return;
-        };
-      };
+    # ?<param spec>
+    /\G\?/gc and
+      return $self->_parse_param_handler($_, 'query');
   }
-  return;
+  return; # () will trigger the blam in our caller
 }
 
 sub _http_method_match {
@@ -204,4 +208,76 @@ sub _url_extension_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) = @_;
+    PARAM: { do {
+
+      # per param flag
+
+      my $multi = 0;
+
+      # ?@foo or ?@*
+
+      /\G\@/gc and $multi = 1;
+
+      # @* or *
+
+      if (/\G\*/) {
+
+        $multi ? ($multistar = 1) : ($star = 1);
+      } else {
+
+        # @foo= or foo= or @foo~ or foo~
+        
+        /\G(\w+)/gc or $self->_blam('Expected parameter name');
+
+        my $name = $1;
+
+        # check for = or ~ on the end
+
+        /\G\=/gc
+          ? push(@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 ? (push @single, $name) : ($multi{$name} = 1);
+      }
+    } while (/\G\&/gc) }
+
+    return sub {
+      my $raw = $unpacker->($_[0]);
+      foreach my $name (@required) {
+        return unless exists $raw->{$name};
+      }
+      my %p;
+      foreach my $name (
+        @single,
+        ($star
+          ? (grep { !exists $multi{$_} } keys %$raw)
+          : ()
+        )
+      ) {
+        $p{$name} = $raw->{$name}->[-1] if exists $raw->{$name};
+      }
+      foreach my $name (
+        keys %multi,
+        ($multistar
+          ? (grep { !exists $p{$_} } keys %$raw)
+          : ()
+        )
+      ) {
+        $p{$name} = $raw->{$name}||[];
+      }
+      return ({}, \%p);
+    };
+  }
+}
+
 1;