Commit | Line | Data |
25ca36c2 |
1 | package Catalyst::ActionRole::QueryMatching; |
2 | |
3 | use Moose::Role; |
4 | use Moose::Util::TypeConstraints (); |
5 | |
6 | requires 'match', 'match_captures', 'list_extra_info'; |
7 | |
8 | sub _query_attr { @{shift->attributes->{Query}||[]} } |
9 | |
10 | has is_slurpy => ( |
11 | is=>'ro', |
12 | init_arg=>undef, |
13 | isa=>'Bool', |
14 | required=>1, |
15 | lazy=>1, |
16 | builder=>'_build_is_slurpy'); |
17 | |
18 | sub _build_is_slurpy { |
19 | my $self = shift; |
20 | my($query, @extra) = $self->_query_attr; |
21 | return $query =~m/^.+,\.\.\.$/ ? 1:0; |
22 | } |
23 | |
24 | has query_constraints => ( |
25 | is=>'ro', |
26 | init_arg=>undef, |
27 | isa=>'ArrayRef|Ref', |
28 | required=>1, |
29 | lazy=>1, |
30 | builder=>'_build_query_constraints'); |
31 | |
32 | sub _build_query_constraints { |
33 | my $self = shift; |
34 | my ($constraint_proto, @extra) = $self->_query_attr; |
88e5a8b0 |
35 | |
25ca36c2 |
36 | die "Action ${\$self->private_path} defines more than one 'Query' attribute" if scalar @extra; |
37 | return +{} unless defined($constraint_proto); |
38 | |
39 | $constraint_proto =~s/^(.+),\.\.\.$/$1/; # slurpy is handled elsewhere |
88e5a8b0 |
40 | |
25ca36c2 |
41 | # Query may be a Hash like Query(p=>Int,q=>Str) OR it may be a Ref like |
42 | # Query(Tuple[p=>Int, slurpy HashRef]). The only way to figure is to eval it |
43 | # and look at what we have. |
44 | my @signature = eval "package ${\$self->class}; $constraint_proto" |
45 | or die "'$constraint_proto' is not valid Query Contraint at action ${\$self->private_path}, error '$@'"; |
46 | |
47 | if(scalar(@signature) > 1) { |
48 | # Do a dance to support old school stringy types |
49 | # At this point we 'should' have a hash... |
50 | my %pairs = @signature; |
51 | foreach my $key(keys %pairs) { |
52 | next if ref $pairs{$key}; |
53 | $pairs{$key} = Moose::Util::TypeConstraints::find_or_parse_type_constraint($pairs{$key}) || |
54 | die "'$pairs{$key}' is not a valid type constraint in Action ${\$self->private_path}"; |
55 | } |
56 | return \%pairs; |
57 | } else { |
58 | # We have a 'reference type' constraint, like Dict[p=>Int,...] |
59 | return $signature[0] if ref($signature[0]); # Is like Tiny::Type |
60 | return Moose::Util::TypeConstraints::find_or_parse_type_constraint($signature[0]) || |
61 | die "'$signature[0]' is not a valid type constraint in Action ${\$self->private_path}"; |
62 | } |
63 | } |
64 | |
65 | around ['match','match_captures'] => sub { |
66 | my ($orig, $self, $c, @args) = @_; |
67 | my $tc = $self->query_constraints; |
68 | if(ref $tc eq 'HASH') { |
69 | # Do the key names match, unless slurpy? |
70 | unless($self->is_slurpy) { |
71 | return 0 unless $self->_compare_arrays([sort keys %$tc],[sort keys %{$c->req->query_parameters}]); |
72 | } |
73 | for my $key(keys %$tc) { |
74 | $tc->{$key}->check($c->req->query_parameters->{$key}) || return 0; |
75 | } |
76 | } else { |
77 | $tc->check($c->req->query_parameters) || return 0; |
78 | } |
79 | |
80 | return $self->$orig($c, @args); |
81 | }; |
82 | |
83 | around 'list_extra_info' => sub { |
84 | my ($orig, $self, @args) = @_; |
85 | return { |
88e5a8b0 |
86 | %{ $self->$orig(@args) }, |
25ca36c2 |
87 | }; |
88 | }; |
89 | |
90 | sub _compare_arrays { |
91 | my ($self, $first, $second) = @_; |
92 | no warnings; # silence spurious -w undef complaints |
93 | return 0 unless @$first == @$second; |
94 | for (my $i = 0; $i < @$first; $i++) { |
95 | return 0 if $first->[$i] ne $second->[$i]; |
96 | } |
97 | return 1; |
98 | } |
99 | |
100 | 1; |
101 | |
102 | =head1 NAME |
103 | |
104 | Catalyst::ActionRole::QueryMatching - Match on GET parameters using type constraints |
105 | |
106 | =head1 SYNOPSIS |
107 | |
108 | TBD |
109 | |
110 | =head1 DESCRIPTION |
111 | |
112 | TBD |
113 | |
114 | =head1 METHODS |
115 | |
116 | This role defines the following methods |
117 | |
118 | =head2 TBD |
119 | |
120 | TBD |
121 | |
122 | =head1 AUTHORS |
123 | |
124 | Catalyst Contributors, see Catalyst.pm |
125 | |
126 | =head1 COPYRIGHT |
127 | |
128 | This library is free software. You can redistribute it and/or modify it under |
129 | the same terms as Perl itself. |
130 | |
131 | =cut |