first pass

diff --git a/lib/Catalyst/ActionRole/QueryMatching.pm b/lib/Catalyst/ActionRole/QueryMatching.pm
new file mode 100644 (file)
index 0000000..955258b
--- /dev/null
+++ b/lib/Catalyst/ActionRole/QueryMatching.pm
@@ -0,0 +1,131 @@
+package Catalyst::ActionRole::QueryMatching;
+
+use Moose::Role;
+use Moose::Util::TypeConstraints ();
+
+requires 'match', 'match_captures', 'list_extra_info';
+
+sub _query_attr { @{shift->attributes->{Query}||[]} }
+
+has is_slurpy => (
+  is=>'ro',
+  init_arg=>undef,
+  isa=>'Bool',
+  required=>1,
+  lazy=>1,
+  builder=>'_build_is_slurpy');
+
+  sub _build_is_slurpy {
+    my $self = shift;
+    my($query, @extra) = $self->_query_attr;
+    return $query =~m/^.+,\.\.\.$/ ? 1:0;
+  }
+
+has query_constraints => (
+  is=>'ro',
+  init_arg=>undef,
+  isa=>'ArrayRef|Ref',
+  required=>1,
+  lazy=>1,
+  builder=>'_build_query_constraints');
+
+  sub _build_query_constraints {
+    my $self = shift;
+    my ($constraint_proto, @extra) = $self->_query_attr;
+    
+    die "Action ${\$self->private_path} defines more than one 'Query' attribute" if scalar @extra;
+    return +{} unless defined($constraint_proto);
+
+    $constraint_proto =~s/^(.+),\.\.\.$/$1/; # slurpy is handled elsewhere
+    
+    # Query may be a Hash like Query(p=>Int,q=>Str) OR it may be a Ref like
+    # Query(Tuple[p=>Int, slurpy HashRef]).  The only way to figure is to eval it
+    # and look at what we have.
+    my @signature = eval "package ${\$self->class}; $constraint_proto"
+      or die "'$constraint_proto' is not valid Query Contraint at action ${\$self->private_path}, error '$@'";
+
+    if(scalar(@signature) > 1) {
+      # Do a dance to support old school stringy types
+      # At this point we 'should' have a hash...
+      my %pairs = @signature;
+      foreach my $key(keys %pairs) {
+        next if ref $pairs{$key};
+        $pairs{$key} = Moose::Util::TypeConstraints::find_or_parse_type_constraint($pairs{$key}) ||
+          die "'$pairs{$key}' is not a valid type constraint in Action ${\$self->private_path}";
+      }
+      return \%pairs;
+    } else {
+      # We have a 'reference type' constraint, like Dict[p=>Int,...]
+      return $signature[0] if ref($signature[0]); # Is like Tiny::Type
+      return Moose::Util::TypeConstraints::find_or_parse_type_constraint($signature[0]) ||
+          die "'$signature[0]' is not a valid type constraint in Action ${\$self->private_path}";
+    }
+  }
+
+around ['match','match_captures'] => sub {
+    my ($orig, $self, $c, @args) = @_;
+    my $tc = $self->query_constraints;
+    if(ref $tc eq 'HASH') {
+      # Do the key names match, unless slurpy?
+      unless($self->is_slurpy) {
+        return 0 unless $self->_compare_arrays([sort keys %$tc],[sort keys %{$c->req->query_parameters}]);
+      }
+      for my $key(keys %$tc) {
+        $tc->{$key}->check($c->req->query_parameters->{$key}) || return 0;
+      }
+    } else {
+      $tc->check($c->req->query_parameters) || return 0;
+    }
+
+    return $self->$orig($c, @args);
+};
+
+around 'list_extra_info' => sub {
+  my ($orig, $self, @args) = @_;
+  return {
+    %{ $self->$orig(@args) }, 
+  };
+};
+
+sub _compare_arrays {
+  my ($self, $first, $second) = @_;
+  no warnings;  # silence spurious -w undef complaints
+  return 0 unless @$first == @$second;
+  for (my $i = 0; $i < @$first; $i++) {
+    return 0 if $first->[$i] ne $second->[$i];
+  }
+  return 1;
+}
+
+1;
+
+=head1 NAME
+
+Catalyst::ActionRole::QueryMatching - Match on GET parameters using type constraints
+
+=head1 SYNOPSIS
+
+    TBD
+
+=head1 DESCRIPTION
+
+    TBD
+
+=head1 METHODS
+
+This role defines the following methods
+
+=head2 TBD
+
+    TBD
+
+=head1 AUTHORS
+
+Catalyst Contributors, see Catalyst.pm
+
+=head1 COPYRIGHT
+
+This library is free software. You can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut

diff --git a/lib/Catalyst/Controller.pm b/lib/Catalyst/Controller.pm
index 9b8b037..87f6df0 100644 (file)
--- a/lib/Catalyst/Controller.pm
+++ b/lib/Catalyst/Controller.pm
@@ -374,6 +374,9 @@ sub gather_default_action_roles {
 
   push @roles, 'Catalyst::ActionRole::Scheme'
     if $args{attributes}->{Scheme};
+
+  push @roles, 'Catalyst::ActionRole::QueryMatching'
+    if $args{attributes}->{Query};
     return @roles;
 }
 

diff --git a/t/query_constraints.t b/t/query_constraints.t
index 0eba004..81e3e1d 100644 (file)
--- a/t/query_constraints.t
+++ b/t/query_constraints.t
@@ -41,7 +41,8 @@ BEGIN {
 
   use Moose;
   use MooseX::MethodAttributes;
-  use MyApp::Types qw/Tuple Int Str StrMatch ArrayRef Enum UserId  Heart/;
+  use Types::Standard 'slurpy';
+  use MyApp::Types qw/Dict Tuple Int StrMatch HashRef ArrayRef Enum UserId  Heart/;
 
   extends 'Catalyst::Controller';
 
@@ -51,6 +52,23 @@ BEGIN {
     $c->res->body("page ${\$c->req->query_parameters->{page}}, user ${\$c->req->query_parameters->{user}[1]}");
   }
 
+  sub user_slurps :Local Args(1)
+   Query(page=>Int,user=>Tuple[Enum['a','b'],Int],...) {
+    my ($self, $c, $int) = @_;
+    $c->res->body("page ${\$c->req->query_parameters->{page}}, user ${\$c->req->query_parameters->{user}[1]}");
+  }
+
+  sub string_types :Local Query(q=>'Str',age=>'Int') { pop->res->body('string_type') }
+ 
+  sub as_ref :Local Query(Dict[age=>Int,sex=>Enum['f','m','o'], slurpy HashRef[Int]]) { pop->res->body('as_ref') }
+
+  sub utf8 :Local Query(utf8=>Heart) { pop->res->body("heart") }
+
+  sub chain :Chained(/) CaptureArgs(0) Query(age=>Int,...) { }
+
+    sub big :Chained(chain) PathPart('') Args(0) Query(size=>Int,...) { pop->res->body('big') }
+    sub small :Chained(chain) PathPart('') Args(0) Query(size=>UserId,...) { pop->res->body('small') }
+  
   sub default :Default {
     my ($self, $c, $int) = @_;
     $c->res->body('default');
@@ -71,4 +89,89 @@ use Catalyst::Test 'MyApp';
   is $res->content, 'page 10, user 100';
 }
 
+{
+  my $res = request '/user/1?page=10&user=d&user=100';
+  is $res->content, 'default';
+}
+
+{
+  my $res = request '/user/1?page=string&user=a&user=100';
+  is $res->content, 'default';
+}
+
+{
+  my $res = request '/user/1?page=10&user=a&user=100&foo=bar';
+  is $res->content, 'default';
+}
+
+{
+  my $res = request '/user/1?page=10&user=a&user=100&user=bar';
+  is $res->content, 'default';
+}
+
+{
+  my $res = request '/user_slurps/1?page=10&user=a&user=100&foo=bar';
+  is $res->content, 'page 10, user 100';
+}
+
+{
+  my $res = request '/string_types?q=sssss&age=10';
+  is $res->content, 'string_type';
+}
+
+{
+  my $res = request '/string_types?w=sssss&age=10';
+  is $res->content, 'default';
+}
+
+{
+  my $res = request '/string_types?q=sssss&age=string';
+  is $res->content, 'default';
+}
+
+{
+  my $res = request '/as_ref?q=sssss&age=string';
+  is $res->content, 'default';
+}
+
+{
+  my $res = request '/as_ref?age=10&sex=o&foo=bar&baz=bot';
+  is $res->content, 'default';
+}
+
+{
+  my $res = request '/as_ref?age=10&sex=o&foo=122&baz=300';
+  is $res->content, 'as_ref';
+}
+
+{
+  my $res = request '/utf8?utf8=♥';
+  is $res->content, 'heart';
+}
+
+{
+  my $res = request '/chain?age=string&size=2';
+  is $res->content, 'default';
+}
+
+{
+  my $res = request '/chain?age=string&size=string';
+  is $res->content, 'default';
+}
+
+{
+  my $res = request '/chain?age=50&size=string';
+  is $res->content, 'default';
+}
+
+{
+  my $res = request '/chain?age=10&size=100';
+  is $res->content, 'big';
+}
+
+{
+  my $res = request '/chain?age=10&size=2';
+  is $res->content, 'small';
+}
+
 done_testing;