lib/Catalyst/ActionRole/QueryMatching.pm

   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;
  35
  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
  40
  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 {
  86     %{ $self->$orig(@args) },
  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