Commit | Line | Data |
25ca36c2 |
1 | package Catalyst::ActionRole::QueryMatching; |
2 | |
3 | use Moose::Role; |
4 | use Moose::Util::TypeConstraints (); |
dd4530ec |
5 | use Ref::Util (); |
25ca36c2 |
6 | |
7 | requires 'match', 'match_captures', 'list_extra_info'; |
8 | |
9 | sub _query_attr { @{shift->attributes->{Query}||[]} } |
10 | |
11 | has is_slurpy => ( |
12 | is=>'ro', |
13 | init_arg=>undef, |
14 | isa=>'Bool', |
15 | required=>1, |
16 | lazy=>1, |
17 | builder=>'_build_is_slurpy'); |
18 | |
19 | sub _build_is_slurpy { |
20 | my $self = shift; |
21 | my($query, @extra) = $self->_query_attr; |
22 | return $query =~m/^.+,\.\.\.$/ ? 1:0; |
23 | } |
24 | |
25 | has query_constraints => ( |
26 | is=>'ro', |
27 | init_arg=>undef, |
28 | isa=>'ArrayRef|Ref', |
29 | required=>1, |
30 | lazy=>1, |
31 | builder=>'_build_query_constraints'); |
32 | |
33 | sub _build_query_constraints { |
34 | my $self = shift; |
35 | my ($constraint_proto, @extra) = $self->_query_attr; |
36 | |
37 | die "Action ${\$self->private_path} defines more than one 'Query' attribute" if scalar @extra; |
38 | return +{} unless defined($constraint_proto); |
39 | |
40 | $constraint_proto =~s/^(.+),\.\.\.$/$1/; # slurpy is handled elsewhere |
41 | |
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 '$@'"; |
47 | |
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}"; |
56 | } |
57 | return \%pairs; |
58 | } else { |
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}"; |
63 | } |
64 | } |
65 | |
66 | around ['match','match_captures'] => sub { |
67 | my ($orig, $self, $c, @args) = @_; |
68 | my $tc = $self->query_constraints; |
dd4530ec |
69 | if(Ref::Util::is_plain_hashref($tc)) { |
25ca36c2 |
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}]); |
73 | } |
74 | for my $key(keys %$tc) { |
75 | $tc->{$key}->check($c->req->query_parameters->{$key}) || return 0; |
76 | } |
77 | } else { |
78 | $tc->check($c->req->query_parameters) || return 0; |
79 | } |
80 | |
81 | return $self->$orig($c, @args); |
82 | }; |
83 | |
84 | around 'list_extra_info' => sub { |
85 | my ($orig, $self, @args) = @_; |
86 | return { |
87 | %{ $self->$orig(@args) }, |
88 | }; |
89 | }; |
90 | |
91 | sub _compare_arrays { |
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]; |
97 | } |
98 | return 1; |
99 | } |
100 | |
101 | 1; |
102 | |
103 | =head1 NAME |
104 | |
105 | Catalyst::ActionRole::QueryMatching - Match on GET parameters using type constraints |
106 | |
107 | =head1 SYNOPSIS |
108 | |
109 | TBD |
110 | |
111 | =head1 DESCRIPTION |
112 | |
113 | TBD |
114 | |
115 | =head1 METHODS |
116 | |
117 | This role defines the following methods |
118 | |
119 | =head2 TBD |
120 | |
121 | TBD |
122 | |
123 | =head1 AUTHORS |
124 | |
125 | Catalyst Contributors, see Catalyst.pm |
126 | |
127 | =head1 COPYRIGHT |
128 | |
129 | This library is free software. You can redistribute it and/or modify it under |
130 | the same terms as Perl itself. |
131 | |
132 | =cut |