File Coverage

blib/lib/Catalyst/ActionRole/QueryMatching.pm

Criterion	Covered	Total	%
statement	33	36	91.6
branch	15	20	75.0
condition	1	4	25.0
subroutine	7	7	100.0
pod			n/a
total	56	67	83.5

package Catalyst::ActionRole::QueryMatching;

use Moose::Role;
use Moose::Util::TypeConstraints ();

requires 'match', 'match_captures', 'list_extra_info';

sub _query_attr { @{shift->attributes->{Query}||[]} }

has is_slurpy => (
  is=>'ro',
  init_arg=>undef,
  isa=>'Bool',
  required=>1,
  lazy=>1,
  builder=>'_build_is_slurpy');

  sub _build_is_slurpy {
    my $self = shift;
    my($query, @extra) = $self->_query_attr;
    return $query =~m/^.+,\.\.\.$/ ? 1:0;
  }

has query_constraints => (
  is=>'ro',
  init_arg=>undef,
  isa=>'ArrayRef|Ref',
  required=>1,
  lazy=>1,
  builder=>'_build_query_constraints');

  sub _build_query_constraints {
    my $self = shift;
    my ($constraint_proto, @extra) = $self->_query_attr;

    die "Action ${\$self->private_path} defines more than one 'Query' attribute" if scalar @extra;
    return +{} unless defined($constraint_proto);

    $constraint_proto =~s/^(.+),\.\.\.$/$1/; # slurpy is handled elsewhere

    # Query may be a Hash like Query(p=>Int,q=>Str) OR it may be a Ref like
    # Query(Tuple[p=>Int, slurpy HashRef]).  The only way to figure is to eval it
    # and look at what we have.
    my @signature = eval "package ${\$self->class}; $constraint_proto"
      or die "'$constraint_proto' is not valid Query Contraint at action ${\$self->private_path}, error '$@'";

    if(scalar(@signature) > 1) {
      # Do a dance to support old school stringy types
      # At this point we 'should' have a hash...
      my %pairs = @signature;
      foreach my $key(keys %pairs) {
        next if ref $pairs{$key};
        $pairs{$key} = Moose::Util::TypeConstraints::find_or_parse_type_constraint($pairs{$key}) ||
          die "'$pairs{$key}' is not a valid type constraint in Action ${\$self->private_path}";
      }
      return \%pairs;
    } else {
      # We have a 'reference type' constraint, like Dict[p=>Int,...]
      return $signature[0] if ref($signature[0]); # Is like Tiny::Type
      return Moose::Util::TypeConstraints::find_or_parse_type_constraint($signature[0]) ||
          die "'$signature[0]' is not a valid type constraint in Action ${\$self->private_path}";
    }
  }

around ['match','match_captures'] => sub {
    my ($orig, $self, $c, @args) = @_;
    my $tc = $self->query_constraints;
    if(ref $tc eq 'HASH') {
      # Do the key names match, unless slurpy?
      unless($self->is_slurpy) {
        return 0 unless $self->_compare_arrays([sort keys %$tc],[sort keys %{$c->req->query_parameters}]);
      }
      for my $key(keys %$tc) {
        $tc->{$key}->check($c->req->query_parameters->{$key}) || return 0;
      }
    } else {
      $tc->check($c->req->query_parameters) || return 0;
    }

    return $self->$orig($c, @args);
};

around 'list_extra_info' => sub {
  my ($orig, $self, @args) = @_;
  return {
    %{ $self->$orig(@args) },
  };
};

sub _compare_arrays {
  my ($self, $first, $second) = @_;
  no warnings;  # silence spurious -w undef complaints
  return 0 unless @$first == @$second;
  for (my $i = 0; $i < @$first; $i++) {
    return 0 if $first->[$i] ne $second->[$i];
  }
  return 1;
}

1;

=head1 NAME

Catalyst::ActionRole::QueryMatching - Match on GET parameters using type constraints

=head1 SYNOPSIS

    TBD

=head1 DESCRIPTION

    TBD

=head1 METHODS

This role defines the following methods

=head2 TBD

    TBD

=head1 AUTHORS

Catalyst Contributors, see Catalyst.pm

=head1 COPYRIGHT

This library is free software. You can redistribute it and/or modify it under
the same terms as Perl itself.

=cut