From: John Napiorkowski Date: Mon, 14 Nov 2011 14:49:48 +0000 (-0500) Subject: predicates are objects X-Git-Tag: v0.011~7 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FWeb-Simple.git;a=commitdiff_plain;h=481da1e202d4de54f3bf692e11ba912833ccc276 predicates are objects changes after mst code review --- diff --git a/.gitignore b/.gitignore index 28d8729..9cf2c22 100644 --- a/.gitignore +++ b/.gitignore @@ -6,4 +6,4 @@ MANIFEST MANIFEST.bak pm_to_blib blib - +*\.DS_Store diff --git a/lib/Web/Dispatch.pm b/lib/Web/Dispatch.pm index ef437da..9ed3912 100644 --- a/lib/Web/Dispatch.pm +++ b/lib/Web/Dispatch.pm @@ -73,10 +73,13 @@ sub _have_result { elsif (ref($first) eq 'HASH' and $first->{+MAGIC_MIDDLEWARE_KEY}) { return $self->_redispatch_with_middleware($first, $match, $env); } - elsif (blessed($first) && !$first->can('to_app')) { + elsif ( + blessed($first) && + not($first->can('to_app')) && + not($first->isa('Web::Dispatch::Matcher')) + ) { return $first; } - return; } @@ -105,7 +108,9 @@ sub _to_try { # sub () {} becomes a dispatcher # sub {} is a PSGI app and can be returned as is # '' => sub {} becomes a dispatcher + # $obj isa WD:Predicates::Proxy => sub { ... } - become a dispatcher # $obj w/to_app method is a Plack::App-like thing - call it to get a PSGI app + # if (ref($try) eq 'CODE') { if (defined(my $proto = prototype($try))) { @@ -115,6 +120,15 @@ sub _to_try { } } elsif (!ref($try) and ref($more->[0]) eq 'CODE') { $self->_construct_node(match => $try, run => shift(@$more))->to_app; + } elsif ( + (blessed($try) && $try->isa('Web::Dispatch::Matcher')) + and (ref($more->[0]) eq 'CODE') + ) { + $self->node_class->new({ + %{$self->node_args}, + match => $try, + run => shift(@$more) + })->to_app; } elsif (blessed($try) && $try->can('to_app')) { $try->to_app; } else { diff --git a/lib/Web/Dispatch/Predicates.pm b/lib/Web/Dispatch/Predicates.pm index dae4a80..a23244d 100644 --- a/lib/Web/Dispatch/Predicates.pm +++ b/lib/Web/Dispatch/Predicates.pm @@ -8,9 +8,11 @@ our @EXPORT = qw( match_extension match_query match_body match_uploads ); +sub _generate_proxy { bless shift, 'Web::Dispatch::Matcher' } + sub match_and { my @match = @_; - sub { + _generate_proxy(sub { my ($env) = @_; my $my_env = { 'Web::Dispatch.original_env' => $env, %$env }; my $new_env; @@ -26,54 +28,54 @@ sub match_and { } } return ($new_env, @got); - } + }) } sub match_or { my @match = @_; - sub { + _generate_proxy(sub { foreach my $try (@match) { if (my @ret = $try->(@_)) { return @ret; } } return; - } + }) } sub match_not { my ($match) = @_; - sub { + _generate_proxy(sub { if (my @discard = $match->($_[0])) { (); } else { ({}); } - } + }) } sub match_method { my ($method) = @_; - sub { + _generate_proxy(sub { my ($env) = @_; $env->{REQUEST_METHOD} eq $method ? {} : () - } + }) } sub match_path { my ($re) = @_; - sub { + _generate_proxy(sub { my ($env) = @_; if (my @cap = ($env->{PATH_INFO} =~ /$re/)) { $cap[0] = {}; return @cap; } return; - } + }) } sub match_path_strip { my ($re) = @_; - sub { + _generate_proxy(sub { my ($env) = @_; if (my @cap = ($env->{PATH_INFO} =~ /$re/)) { $cap[0] = { @@ -83,7 +85,7 @@ sub match_path_strip { return @cap; } return; - } + }) } sub match_extension { @@ -92,25 +94,25 @@ sub match_extension { my $re = $wild ? qr/\.(\w+)$/ : qr/\.(\Q${extension}\E)$/; - sub { + _generate_proxy(sub { if ($_[0]->{PATH_INFO} =~ $re) { ($wild ? ({}, $1) : {}); } else { (); } - }; + }); } sub match_query { - _param_matcher(query => $_[0]); + _generate_proxy(_param_matcher(query => $_[0])); } sub match_body { - _param_matcher(body => $_[0]); + _generate_proxy(_param_matcher(body => $_[0])); } sub match_uploads { - _param_matcher(uploads => $_[0]); + _generate_proxy(_param_matcher(uploads => $_[0])); } sub _param_matcher { diff --git a/t/proxy-predicates.t b/t/proxy-predicates.t new file mode 100644 index 0000000..b073220 --- /dev/null +++ b/t/proxy-predicates.t @@ -0,0 +1,154 @@ +use strict; +use warnings FATAL => 'all'; + +use Data::Dumper::Concise; +use Test::More 'no_plan'; +use Plack::Test; + +{ + use Web::Simple 't::Web::Simple::SubDispatchArgs'; + package t::Web::Simple::SubDispatchArgs; + use Web::Dispatch::Predicates; + + has 'attr' => (is=>'ro'); + + sub dispatch_request { + my $self = shift; + match_path(qr/(?^:^(\/)$)/), sub { + $self->show_landing(@_); + }, + match_path_strip(qr/(?^:^()(\/.*)$)/) => sub { + match_and + ( + match_method('GET'), + match_path(qr/(?^:^(\/user(?:\.\w+)?)$)/) + ) => sub { + $self->show_users(@_); + }, + match_path(qr/(?^:^(\/user\/([^\/]+?)(?:\.\w+)?)$)/), sub { + match_method('GET') => sub { + $self->show_user(@_); + }, + match_and + ( + match_method('POST'), + match_body + ({ + named => [ + { + multi => "", + name => "id" + }, + { + multi => 1, + name => "roles" + } + ], + required => ["id"] + }) + ) => sub { + $self->process_post(@_); + } + }, + } + }; + + sub show_landing { + my ($self, @args) = @_; + local $self->{_dispatcher}; + local $args[-1]->{'Web::Dispatch.original_env'}; + return [ + 200, ['Content-Type' => 'application/perl' ], + [::Dumper \@args], + ]; + } + sub show_users { + my ($self, @args) = @_; + local $self->{_dispatcher}; + local $args[-1]->{'Web::Dispatch.original_env'}; + return [ + 200, ['Content-Type' => 'application/perl' ], + [::Dumper \@args], + ]; + } + sub show_user { + my ($self, @args) = @_; + local $self->{_dispatcher}; + local $args[-1]->{'Web::Dispatch.original_env'}; + return [ + 200, ['Content-Type' => 'application/perl' ], + [::Dumper \@args], + ]; + } + sub process_post { + my ($self, @args) = @_; + local $self->{_dispatcher}; + local $args[-1]->{'Web::Dispatch.original_env'}; + return [ + 200, ['Content-Type' => 'application/perl' ], + [::Dumper \@args], + ]; + } +} + +ok my $app = t::Web::Simple::SubDispatchArgs->new, + 'made app'; + +sub run_request { $app->run_test_request(@_); } + +ok my $get_landing = run_request(GET => 'http://localhost/' ), + 'got landing'; + +cmp_ok $get_landing->code, '==', 200, + '200 on GET'; + +no strict 'refs'; + +{ + my ($self, $env, @noextra) = @{eval($get_landing->content)||[]}; + die $@ if $@; + is scalar(@noextra), 0, 'No extra stuff'; + is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; + is ref($env), 'HASH', 'Got hashref'; +} + +ok my $get_users = run_request(GET => 'http://localhost/user'), + 'got user'; + +cmp_ok $get_users->code, '==', 200, + '200 on GET'; + +{ + my ($self, $env, @noextra) = @{eval $get_users->content}; + is scalar(@noextra), 0, 'No extra stuff'; + is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; + is ref($env), 'HASH', 'Got hashref'; +} + +ok my $get_user = run_request(GET => 'http://localhost/user/42'), + 'got user'; + +cmp_ok $get_user->code, '==', 200, + '200 on GET'; + +{ + my ($self, $env, @noextra) = @{eval $get_user->content}; + is scalar(@noextra), 0, 'No extra stuff'; + is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; + is ref($env), 'HASH', 'Got hashref'; +} + +ok my $post_user = run_request(POST => 'http://localhost/user/42', [id => '99'] ), + 'post user'; + +cmp_ok $post_user->code, '==', 200, + '200 on POST'; + +{ + my ($self, $params, $env, @noextra) = @{eval $post_user->content}; + is scalar(@noextra), 0, 'No extra stuff'; + is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object'; + is ref($params), 'HASH', 'Got POST hashref'; + is $params->{id}, 99, 'got expected value for id'; + is ref($env), 'HASH', 'Got hashref'; +}