first draft of http methods, with a test case

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

diff --git a/lib/Web/Dispatch/Predicates.pm b/lib/Web/Dispatch/Predicates.pm
index 7008efe..4ff3a93 100644 (file)
--- a/lib/Web/Dispatch/Predicates.pm
+++ b/lib/Web/Dispatch/Predicates.pm
@@ -3,13 +3,18 @@ package Web::Dispatch::Predicates;
 use strictures 1;
 use base qw(Exporter);
 
-our @EXPORT = qw(match_and match_or match_method match_path match_path_strip);
+our @EXPORT = qw(
+  match_and match_or match_not match_method match_path match_path_strip
+  match_extension match_query match_body match_uploads
+);
+
+sub _matcher { bless shift, 'Web::Dispatch::Matcher' }
 
 sub match_and {
   my @match = @_;
-  sub {
+  _matcher(sub {
     my ($env) = @_;
-    my $my_env = { %$env };
+    my $my_env = { 'Web::Dispatch.original_env' => $env, %$env };
     my $new_env;
     my @got;
     foreach my $match (@match) {
@@ -23,43 +28,54 @@ sub match_and {
       }
     }
     return ($new_env, @got);
-  }
+  })
 }
 
 sub match_or {
   my @match = @_;
-  sub {
+  _matcher(sub {
     foreach my $try (@match) {
       if (my @ret = $try->(@_)) {
         return @ret;
       }
     }
     return;
-  }
+  })
+}
+
+sub match_not {
+  my ($match) = @_;
+  _matcher(sub {
+    if (my @discard = $match->($_[0])) {
+      ();
+    } else {
+      ({});
+    }
+  })
 }
 
 sub match_method {
   my ($method) = @_;
-  sub {
+  _matcher(sub {
     my ($env) = @_;
     $env->{REQUEST_METHOD} eq $method ? {} : ()
-  }
+  })
 }
 
 sub match_path {
   my ($re) = @_;
-  sub {
+  _matcher(sub {
     my ($env) = @_;
     if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
       $cap[0] = {}; return @cap;
     }
     return;
-  }
+  })
 }
 
 sub match_path_strip {
   my ($re) = @_;
-  sub {
+  _matcher(sub {
     my ($env) = @_;
     if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
       $cap[0] = {
@@ -69,7 +85,75 @@ sub match_path_strip {
       return @cap;
     }
     return;
+  })
+}
+
+sub match_extension {
+  my ($extension) = @_;
+  my $wild = (!$extension or $extension eq '*');
+  my $re = $wild
+             ? qr/\.(\w+)$/
+             : qr/\.(\Q${extension}\E)$/;
+  _matcher(sub {
+    if ($_[0]->{PATH_INFO} =~ $re) {
+      ($wild ? ({}, $1) : {});
+    } else {
+      ();
+    }
+   });
+}
+
+sub match_query {
+  _matcher(_param_matcher(query => $_[0]));
+}
+
+sub match_body {
+  _matcher(_param_matcher(body => $_[0]));
+}
+
+sub match_uploads {
+  _matcher(_param_matcher(uploads => $_[0]));
+}
+
+sub _param_matcher {
+  my ($type, $spec) = @_;
+  require Web::Dispatch::ParamParser;
+  my $unpack = Web::Dispatch::ParamParser->can("get_unpacked_${type}_from");
+  sub {
+    _extract_params($unpack->($_[0]), $spec)
+  };
+}
+
+sub _extract_params {
+  my ($raw, $spec) = @_;
+  foreach my $name (@{$spec->{required}||[]}) {
+    return unless exists $raw->{$name};
+  }
+  my @ret = (
+    {},
+    map {
+      $_->{multi} ? $raw->{$_->{name}}||[] : $raw->{$_->{name}}->[-1]
+    } @{$spec->{positional}||[]}
+  );
+  # separated since 'or' is short circuit
+  my ($named, $star) = ($spec->{named}, $spec->{star});
+  if ($named or $star) {
+    my %kw;
+    if ($star) {
+      @kw{keys %$raw} = (
+        $star->{multi}
+          ? values %$raw
+          : map $_->[-1], values %$raw
+      );
+    }
+    foreach my $n (@{$named||[]}) {
+      next if !$n->{multi} and !exists $raw->{$n->{name}};
+      $kw{$n->{name}} = 
+        $n->{multi} ? $raw->{$n->{name}}||[] : $raw->{$n->{name}}->[-1];
+    }
+    push @ret, \%kw;
   }
+  @ret;
 }
 
 1;