1 package Catalyst::ActionRole::QueryMatching;
4 use Moose::Util::TypeConstraints ();
7 requires 'match', 'match_captures', 'list_extra_info';
9 sub _query_attr { @{shift->attributes->{Query}||[]} }
17 builder=>'_build_is_slurpy');
19 sub _build_is_slurpy {
21 my($query, @extra) = $self->_query_attr;
22 return $query =~m/^.+,\.\.\.$/ ? 1:0;
25 has query_constraints => (
31 builder=>'_build_query_constraints');
33 sub _build_query_constraints {
35 my ($constraint_proto, @extra) = $self->_query_attr;
37 die "Action ${\$self->private_path} defines more than one 'Query' attribute" if scalar @extra;
38 return +{} unless defined($constraint_proto);
40 $constraint_proto =~s/^(.+),\.\.\.$/$1/; # slurpy is handled elsewhere
42 # Query may be a Hash like Query(p=>Int,q=>Str) OR it may be a Ref like
43 # Query(Tuple[p=>Int, slurpy HashRef]). The only way to figure is to eval it
44 # and look at what we have.
45 my @signature = eval "package ${\$self->class}; $constraint_proto"
46 or die "'$constraint_proto' is not valid Query Contraint at action ${\$self->private_path}, error '$@'";
48 if(scalar(@signature) > 1) {
49 # Do a dance to support old school stringy types
50 # At this point we 'should' have a hash...
51 my %pairs = @signature;
52 foreach my $key(keys %pairs) {
53 next if ref $pairs{$key};
54 $pairs{$key} = Moose::Util::TypeConstraints::find_or_parse_type_constraint($pairs{$key}) ||
55 die "'$pairs{$key}' is not a valid type constraint in Action ${\$self->private_path}";
59 # We have a 'reference type' constraint, like Dict[p=>Int,...]
60 return $signature[0] if ref($signature[0]); # Is like Tiny::Type
61 return Moose::Util::TypeConstraints::find_or_parse_type_constraint($signature[0]) ||
62 die "'$signature[0]' is not a valid type constraint in Action ${\$self->private_path}";
66 around ['match','match_captures'] => sub {
67 my ($orig, $self, $c, @args) = @_;
68 my $tc = $self->query_constraints;
69 if(Ref::Util::is_plain_hashref($tc)) {
70 # Do the key names match, unless slurpy?
71 unless($self->is_slurpy) {
72 return 0 unless $self->_compare_arrays([sort keys %$tc],[sort keys %{$c->req->query_parameters}]);
74 for my $key(keys %$tc) {
75 $tc->{$key}->check($c->req->query_parameters->{$key}) || return 0;
78 $tc->check($c->req->query_parameters) || return 0;
81 return $self->$orig($c, @args);
84 around 'list_extra_info' => sub {
85 my ($orig, $self, @args) = @_;
87 %{ $self->$orig(@args) },
92 my ($self, $first, $second) = @_;
93 no warnings; # silence spurious -w undef complaints
94 return 0 unless @$first == @$second;
95 for (my $i = 0; $i < @$first; $i++) {
96 return 0 if $first->[$i] ne $second->[$i];
105 Catalyst::ActionRole::QueryMatching - Match on GET parameters using type constraints
117 This role defines the following methods
125 Catalyst Contributors, see Catalyst.pm
129 This library is free software. You can redistribute it and/or modify it under
130 the same terms as Perl itself.