From: John Napiorkowski Date: Tue, 31 Mar 2015 01:22:11 +0000 (-0500) Subject: first pass X-Git-Tag: 5.90089_002~15 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=25ca36c2fb3547600772a73c722a30b469ad632f first pass --- diff --git a/lib/Catalyst/ActionRole/QueryMatching.pm b/lib/Catalyst/ActionRole/QueryMatching.pm new file mode 100644 index 0000000..955258b --- /dev/null +++ b/lib/Catalyst/ActionRole/QueryMatching.pm @@ -0,0 +1,131 @@ +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 diff --git a/lib/Catalyst/Controller.pm b/lib/Catalyst/Controller.pm index 9b8b037..87f6df0 100644 --- a/lib/Catalyst/Controller.pm +++ b/lib/Catalyst/Controller.pm @@ -374,6 +374,9 @@ sub gather_default_action_roles { push @roles, 'Catalyst::ActionRole::Scheme' if $args{attributes}->{Scheme}; + + push @roles, 'Catalyst::ActionRole::QueryMatching' + if $args{attributes}->{Query}; return @roles; } diff --git a/t/query_constraints.t b/t/query_constraints.t index 0eba004..81e3e1d 100644 --- a/t/query_constraints.t +++ b/t/query_constraints.t @@ -41,7 +41,8 @@ BEGIN { use Moose; use MooseX::MethodAttributes; - use MyApp::Types qw/Tuple Int Str StrMatch ArrayRef Enum UserId Heart/; + use Types::Standard 'slurpy'; + use MyApp::Types qw/Dict Tuple Int StrMatch HashRef ArrayRef Enum UserId Heart/; extends 'Catalyst::Controller'; @@ -51,6 +52,23 @@ BEGIN { $c->res->body("page ${\$c->req->query_parameters->{page}}, user ${\$c->req->query_parameters->{user}[1]}"); } + sub user_slurps :Local Args(1) + Query(page=>Int,user=>Tuple[Enum['a','b'],Int],...) { + my ($self, $c, $int) = @_; + $c->res->body("page ${\$c->req->query_parameters->{page}}, user ${\$c->req->query_parameters->{user}[1]}"); + } + + sub string_types :Local Query(q=>'Str',age=>'Int') { pop->res->body('string_type') } + + sub as_ref :Local Query(Dict[age=>Int,sex=>Enum['f','m','o'], slurpy HashRef[Int]]) { pop->res->body('as_ref') } + + sub utf8 :Local Query(utf8=>Heart) { pop->res->body("heart") } + + sub chain :Chained(/) CaptureArgs(0) Query(age=>Int,...) { } + + sub big :Chained(chain) PathPart('') Args(0) Query(size=>Int,...) { pop->res->body('big') } + sub small :Chained(chain) PathPart('') Args(0) Query(size=>UserId,...) { pop->res->body('small') } + sub default :Default { my ($self, $c, $int) = @_; $c->res->body('default'); @@ -71,4 +89,89 @@ use Catalyst::Test 'MyApp'; is $res->content, 'page 10, user 100'; } +{ + my $res = request '/user/1?page=10&user=d&user=100'; + is $res->content, 'default'; +} + +{ + my $res = request '/user/1?page=string&user=a&user=100'; + is $res->content, 'default'; +} + +{ + my $res = request '/user/1?page=10&user=a&user=100&foo=bar'; + is $res->content, 'default'; +} + +{ + my $res = request '/user/1?page=10&user=a&user=100&user=bar'; + is $res->content, 'default'; +} + +{ + my $res = request '/user_slurps/1?page=10&user=a&user=100&foo=bar'; + is $res->content, 'page 10, user 100'; +} + +{ + my $res = request '/string_types?q=sssss&age=10'; + is $res->content, 'string_type'; +} + +{ + my $res = request '/string_types?w=sssss&age=10'; + is $res->content, 'default'; +} + +{ + my $res = request '/string_types?q=sssss&age=string'; + is $res->content, 'default'; +} + +{ + my $res = request '/as_ref?q=sssss&age=string'; + is $res->content, 'default'; +} + +{ + my $res = request '/as_ref?age=10&sex=o&foo=bar&baz=bot'; + is $res->content, 'default'; +} + +{ + my $res = request '/as_ref?age=10&sex=o&foo=122&baz=300'; + is $res->content, 'as_ref'; +} + +{ + my $res = request '/utf8?utf8=♥'; + is $res->content, 'heart'; +} + +{ + my $res = request '/chain?age=string&size=2'; + is $res->content, 'default'; +} + +{ + my $res = request '/chain?age=string&size=string'; + is $res->content, 'default'; +} + +{ + my $res = request '/chain?age=50&size=string'; + is $res->content, 'default'; +} + +{ + my $res = request '/chain?age=10&size=100'; + is $res->content, 'big'; +} + +{ + my $res = request '/chain?age=10&size=2'; + is $res->content, 'small'; +} + done_testing;