lib/Catalyst/ActionRole/QueryMatching.pm

   1 package Catalyst::ActionRole::QueryMatching;
   2
   3 use Moose::Role;
   4 use Moose::Util::TypeConstraints ();
   5 use Ref::Util ();
   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;
  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}]);
  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