[Bps-public-commit] Path-Dispatcher branch, master, updated. a8e0cb12bcebd2d459f8173ee375bee3614f22c5
sartak at bestpractical.com
sartak at bestpractical.com
Fri Mar 6 19:38:59 EST 2009
The branch, master has been updated
via a8e0cb12bcebd2d459f8173ee375bee3614f22c5 (commit)
via 395937a42e1445b5f6a615483ddd83e0e5c461f7 (commit)
from 20a9758ab9949e4bcc93f78b0e6dce855163558b (commit)
Summary of changes:
lib/Path/Dispatcher.pm | 4 +
lib/Path/Dispatcher/Declarative.pm | 10 ++-
lib/Path/Dispatcher/Rule.pm | 1 +
lib/Path/Dispatcher/Rule/Chain.pm | 23 +++++
lib/Path/Dispatcher/Rule/Under.pm | 12 +++-
t/020-chain.t | 169 ++++++++++++++++++++++++++++++++++++
6 files changed, 217 insertions(+), 2 deletions(-)
create mode 100644 lib/Path/Dispatcher/Rule/Chain.pm
create mode 100644 t/020-chain.t
- Log -----------------------------------------------------------------
commit 395937a42e1445b5f6a615483ddd83e0e5c461f7
Author: robertkrimen <robertkrimen at gmail.com>
Date: Tue Feb 24 23:46:25 2009 -0800
Added rudimentary chaining support in the form of a new rule and a new
declaration
Modified ::Under to handle chaining
diff --git a/lib/Path/Dispatcher.pm b/lib/Path/Dispatcher.pm
index 448a710..7b59b1c 100644
--- a/lib/Path/Dispatcher.pm
+++ b/lib/Path/Dispatcher.pm
@@ -53,6 +53,10 @@ sub dispatch_rule {
my %args = @_;
my @matches = $args{rule}->match($args{path});
+
+ # Support ::Chain here? Probably not. As ::Chain doesn't make sense unless it is within an ::Under
+# return if $matches[-1]->rule->isa('Path::Dispatcher::Rule::Chain');
+
$args{dispatch}->add_matches(@matches);
return @matches;
diff --git a/lib/Path/Dispatcher/Declarative.pm b/lib/Path/Dispatcher/Declarative.pm
index 3b3c625..a8a3dd5 100644
--- a/lib/Path/Dispatcher/Declarative.pm
+++ b/lib/Path/Dispatcher/Declarative.pm
@@ -107,6 +107,14 @@ sub build_sugar {
);
$into->_add_rule($rule);
},
+ chain => sub (&) {
+ my $block = shift;
+ my $rule = Path::Dispatcher::Rule::Chain->new(
+ stage => 'on',
+ block => $block,
+ );
+ $into->_add_rule($rule);
+ },
under => sub {
my ($matcher, $rules) = @_;
@@ -340,7 +348,7 @@ next rule via C<next_rule>
The only argument is a coderef that processes normally (like L<on>).
-NOTE: You *can* avoid running a following rule by using C<abort_rule>.
+NOTE: You *can* avoid running a following rule by using C<last_rule>.
An example:
diff --git a/lib/Path/Dispatcher/Rule.pm b/lib/Path/Dispatcher/Rule.pm
index b449d66..2f23a30 100644
--- a/lib/Path/Dispatcher/Rule.pm
+++ b/lib/Path/Dispatcher/Rule.pm
@@ -124,6 +124,7 @@ no Any::Moose;
# don't require others to load our subclasses explicitly
require Path::Dispatcher::Rule::Always;
+require Path::Dispatcher::Rule::Chain;
require Path::Dispatcher::Rule::CodeRef;
require Path::Dispatcher::Rule::Dispatch;
require Path::Dispatcher::Rule::Empty;
diff --git a/lib/Path/Dispatcher/Rule/Chain.pm b/lib/Path/Dispatcher/Rule/Chain.pm
new file mode 100644
index 0000000..762ebcb
--- /dev/null
+++ b/lib/Path/Dispatcher/Rule/Chain.pm
@@ -0,0 +1,29 @@
+package Path::Dispatcher::Rule::Chain;
+use Any::Moose;
+extends 'Path::Dispatcher::Rule';
+
+sub BUILD {
+ my $self = shift;
+
+ if ($self->has_block) {
+ my $block = $self->block;
+ $self->block(sub {
+ $block->(@_);
+ die "Path::Dispatcher next rule\n"; # FIXME From Path::Dispatcher::Declarative... maybe this should go in a common place?
+ });
+ }
+}
+
+sub _match {
+ my $self = shift;
+ my $path = shift;
+ return (1, $path->path);
+}
+
+sub readable_attributes { 'chain' }
+
+__PACKAGE__->meta->make_immutable;
+no Any::Moose;
+
+1;
+
diff --git a/lib/Path/Dispatcher/Rule/Under.pm b/lib/Path/Dispatcher/Rule/Under.pm
index c1ebd38..a7dcd4e 100644
--- a/lib/Path/Dispatcher/Rule/Under.pm
+++ b/lib/Path/Dispatcher/Rule/Under.pm
@@ -24,7 +24,17 @@ sub match {
my $new_path = $path->clone_path($prefix_match->leftover);
- return grep { defined } map { $_->match($new_path) } $self->rules;
+ # Pop off @matches until we have a last rule that is not ::Chain
+ #
+ # A better technique than isa might be to use the concept of 'endpoint', 'midpoint', or 'anypoint' rules and
+ # add a method to ::Rule that lets evaluate whether any rule is of the right kind (i.e. ->is_endpoint)
+ #
+ # Because the checking for ::Chain endpointedness is here, this means that outside of an ::Under, ::Chain behaves like
+ # an ::Always (one that will always trigger next_rule if it's block is ran)
+ #
+ return unless my @matches = grep { defined } map { $_->match($new_path) } $self->rules;
+ pop @matches while @matches && $matches[-1]->rule->isa('Path::Dispatcher::Rule::Chain');
+ return @matches;
}
sub readable_attributes { shift->predicate->readable_attributes }
diff --git a/t/020-chain.t b/t/020-chain.t
new file mode 100644
index 0000000..d8f1a1a
--- /dev/null
+++ b/t/020-chain.t
@@ -0,0 +1,169 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+#use Test::More tests => 15;
+use Test::More; plan qw/no_plan/;
+use Path::Dispatcher;
+
+my $predicate = Path::Dispatcher::Rule::Tokens->new(
+ tokens => ['ticket'],
+ prefix => 1,
+);
+
+my $chain = Path::Dispatcher::Rule::Chain->new(
+);
+
+my $create = Path::Dispatcher::Rule::Tokens->new(
+ tokens => ['create'],
+);
+
+my $update = Path::Dispatcher::Rule::Tokens->new(
+ tokens => ['update'],
+ prefix => 1,
+);
+
+my $under_always = Path::Dispatcher::Rule::Under->new(
+ predicate => $predicate,
+ rules => [Path::Dispatcher::Rule::Always->new, $create, $update],
+);
+
+my $under_chain = Path::Dispatcher::Rule::Under->new(
+ predicate => $predicate,
+ rules => [$chain, $create, $update],
+);
+
+my %tests = (
+ "ticket" => {
+ fail => 1,
+ catchall => 1,
+ always => 1,
+ },
+ "ticket create" => {},
+ "ticket update" => {},
+ " ticket update " => {
+ name => "whitespace doesn't matter for token-based rules",
+ },
+ "ticket update foo" => {
+ name => "'ticket update' rule is prefix",
+ },
+
+ "ticket create foo" => {
+ fail => 1,
+ catchall => 1,
+ always => 1,
+ name => "did not match 'ticket create foo' because it's not a suffix",
+ },
+ "comment create" => {
+ fail => 1,
+ name => "did not match 'comment create' because the prefix is ticket",
+ },
+ "ticket delete" => {
+ fail => 1,
+ catchall => 1,
+ always => 1,
+ name => "did not match 'ticket delete' because delete is not a suffix",
+ },
+);
+
+sub run_tests {
+ my $under = shift;
+ my $is_always = shift;
+
+ for my $path (keys %tests) {
+ my $data = $tests{$path};
+ my $name = $data->{name} || $path;
+
+ my $match = $under->match(Path::Dispatcher::Path->new($path));
+ $match = !$match if $data->{fail} && !($is_always && $data->{always}); # Always always matches
+ ok($match, $name);
+ }
+
+ my $catchall = Path::Dispatcher::Rule::Regex->new(
+ regex => qr/()/,
+ );
+
+ $under->add_rule($catchall);
+
+ for my $path (keys %tests) {
+ my $data = $tests{$path};
+ my $name = $data->{name} || $path;
+
+ my $match = $under->match(Path::Dispatcher::Path->new($path));
+ $match = !$match if $data->{fail} && !$data->{catchall};
+ ok($match, $name);
+ }
+}
+
+run_tests $under_chain, 0;
+run_tests $under_always, 1;
+
+my @result;
+
+do {
+ package ChainDispatch;
+ use Path::Dispatcher::Declarative -base;
+
+ under 'ticket' => sub {
+ chain {
+ push @result, "(ticket chain)";
+ };
+ on 'create' => sub { push @result, "ticket create" };
+ chain {
+ push @result, "(ticket chain just for update)";
+
+ };
+ on 'update' => sub { push @result, "ticket update" };
+ };
+
+ under 'blog' => sub {
+ chain {
+ push @result, "(blog chain)";
+
+ };
+ under 'post' => sub {
+ chain {
+ push @result, "(after post)";
+
+ };
+ on 'create' => sub { push @result, "create blog post" };
+ on 'delete' => sub { push @result, "delete blog post" };
+ };
+ chain {
+ push @result, "(before comment)";
+
+ };
+ under 'comment' => sub {
+ on 'create' => sub { push @result, "create blog comment" };
+ on 'delete' => sub { push @result, "delete blog comment" };
+ chain {
+ push @result, "(never included)";
+
+ };
+ };
+ };
+};
+
+ChainDispatch->run('ticket create');
+is_deeply([splice @result], ['(ticket chain)', 'ticket create']);
+
+ChainDispatch->run('ticket update');
+is_deeply([splice @result], ['(ticket chain)', '(ticket chain just for update)', 'ticket update']);
+
+ChainDispatch->run('ticket foo');
+is_deeply([splice @result], []);
+
+ChainDispatch->run('blog');
+is_deeply([splice @result], []);
+
+ChainDispatch->run('blog post');
+is_deeply([splice @result], []);
+
+ChainDispatch->run('blog post create');
+is_deeply([splice @result], ['(blog chain)', '(after post)', 'create blog post']);
+
+ChainDispatch->run('blog comment');
+is_deeply([splice @result], []);
+
+ChainDispatch->run('blog comment create');
+is_deeply([splice @result], ['(blog chain)', '(before comment)', 'create blog comment']);
+
commit a8e0cb12bcebd2d459f8173ee375bee3614f22c5
Author: Shawn M Moore <sartak at gmail.com>
Date: Fri Mar 6 19:38:50 2009 -0500
Make Chain a subclass of Always
diff --git a/lib/Path/Dispatcher/Rule/Chain.pm b/lib/Path/Dispatcher/Rule/Chain.pm
index 762ebcb..f0b311e 100644
--- a/lib/Path/Dispatcher/Rule/Chain.pm
+++ b/lib/Path/Dispatcher/Rule/Chain.pm
@@ -1,6 +1,6 @@
package Path::Dispatcher::Rule::Chain;
use Any::Moose;
-extends 'Path::Dispatcher::Rule';
+extends 'Path::Dispatcher::Rule::Always';
sub BUILD {
my $self = shift;
@@ -14,12 +14,6 @@ sub BUILD {
}
}
-sub _match {
- my $self = shift;
- my $path = shift;
- return (1, $path->path);
-}
-
sub readable_attributes { 'chain' }
__PACKAGE__->meta->make_immutable;
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list