[Bps-public-commit] path-dispatcher-declarative branch, master, updated. 3daed04d5bd3c9c4774bb15c1e9fde20a765bb36
sartak at bestpractical.com
sartak at bestpractical.com
Tue Mar 16 09:21:05 EDT 2010
The branch, master has been updated
via 3daed04d5bd3c9c4774bb15c1e9fde20a765bb36 (commit)
from 66a88e6f1d6b5ec1bb127c7ddc5370615f9d3d0d (commit)
Summary of changes:
lib/Path/Dispatcher/Declarative.pm | 197 +++++++++++++++++++++
lib/Path/Dispatcher/Declarative/Builder.pm | 260 ++++++++++++++++++++++++++++
t/016-more-under.t | 52 ++++++
t/020-chain.t | 162 +++++++++++++++++
t/021-declarative-defaults.t | 25 +++
t/100-declarative.t | 83 +++++++++
t/101-subclass.t | 42 +++++
t/102-abort.t | 58 ++++++
t/103-input.t | 57 ++++++
t/104-config.t | 31 ++++
t/105-empty.t | 22 +++
t/106-metadata.t | 52 ++++++
t/200-under-next_rule.t | 32 ++++
t/300-complete-simple.t | 53 ++++++
t/301-complete-complex.t | 73 ++++++++
t/302-complete-delimiter.t | 57 ++++++
t/303-complete-alternation.t | 59 +++++++
t/304-complete-enum.t | 59 +++++++
t/800-cb-slash-path-delimiter.t | 32 ++++
t/801-cb-chaining.t | 34 ++++
20 files changed, 1440 insertions(+), 0 deletions(-)
create mode 100644 lib/Path/Dispatcher/Declarative.pm
create mode 100644 lib/Path/Dispatcher/Declarative/Builder.pm
create mode 100644 t/016-more-under.t
create mode 100644 t/020-chain.t
create mode 100644 t/021-declarative-defaults.t
create mode 100644 t/100-declarative.t
create mode 100644 t/101-subclass.t
create mode 100644 t/102-abort.t
create mode 100644 t/103-input.t
create mode 100644 t/104-config.t
create mode 100644 t/105-empty.t
create mode 100644 t/106-metadata.t
create mode 100644 t/200-under-next_rule.t
create mode 100644 t/300-complete-simple.t
create mode 100644 t/301-complete-complex.t
create mode 100644 t/302-complete-delimiter.t
create mode 100644 t/303-complete-alternation.t
create mode 100644 t/304-complete-enum.t
create mode 100644 t/800-cb-slash-path-delimiter.t
create mode 100644 t/801-cb-chaining.t
- Log -----------------------------------------------------------------
commit 3daed04d5bd3c9c4774bb15c1e9fde20a765bb36
Author: Shawn M Moore <sartak at gmail.com>
Date: Tue Mar 16 09:19:33 2010 -0400
Path::Dispatcher::Declarative, factored out from Path::Dispatcher
diff --git a/lib/Path/Dispatcher/Declarative.pm b/lib/Path/Dispatcher/Declarative.pm
new file mode 100644
index 0000000..7bcfe7c
--- /dev/null
+++ b/lib/Path/Dispatcher/Declarative.pm
@@ -0,0 +1,197 @@
+package Path::Dispatcher::Declarative;
+use strict;
+use warnings;
+use Path::Dispatcher;
+use Path::Dispatcher::Declarative::Builder;
+use Sub::Exporter;
+
+use constant dispatcher_class => 'Path::Dispatcher';
+use constant builder_class => 'Path::Dispatcher::Declarative::Builder';
+
+our $CALLER; # Sub::Exporter doesn't make this available
+
+my $exporter = Sub::Exporter::build_exporter({
+ into_level => 1,
+ groups => {
+ default => \&build_sugar,
+ },
+});
+
+sub import {
+ my $self = shift;
+ my $pkg = caller;
+
+ my @args = grep { !/^-base$/i } @_;
+
+ # just loading the class..
+ return if @args == @_;
+
+ do {
+ no strict 'refs';
+ push @{ $pkg . '::ISA' }, $self;
+ };
+
+ local $CALLER = $pkg;
+
+ $exporter->($self, @args);
+}
+
+sub build_sugar {
+ my ($class, $group, $arg) = @_;
+
+ my $into = $CALLER;
+
+ $class->populate_defaults($arg);
+
+ my $dispatcher = $class->dispatcher_class->new(name => $into);
+
+ my $builder = $class->builder_class->new(
+ dispatcher => $dispatcher,
+ %$arg,
+ );
+
+ return {
+ dispatcher => sub { $builder->dispatcher },
+ rewrite => sub { $builder->rewrite(@_) },
+ on => sub { $builder->on(@_) },
+ under => sub { $builder->under(@_) },
+ redispatch_to => sub { $builder->redispatch_to(@_) },
+ enum => sub { $builder->enum(@_) },
+ next_rule => sub { $builder->next_rule(@_) },
+ last_rule => sub { $builder->last_rule(@_) },
+ complete => sub { $builder->complete(@_) },
+
+ then => sub (&) { $builder->then(@_) },
+ chain => sub (&) { $builder->chain(@_) },
+
+ # NOTE on shift if $into: if caller is $into, then this function is
+ # being used as sugar otherwise, it's probably a method call, so
+ # discard the invocant
+ dispatch => sub { shift if caller ne $into; $builder->dispatch(@_) },
+ run => sub { shift if caller ne $into; $builder->run(@_) },
+ };
+}
+
+sub populate_defaults {
+ my $class = shift;
+ my $arg = shift;
+
+ for my $option ('token_delimiter', 'case_sensitive_tokens') {
+ next if exists $arg->{$option};
+ next unless $class->can($option);
+
+ my $default = $class->$option;
+ next unless defined $default; # use the builder's default
+
+ $arg->{$option} = $class->$option;
+ }
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Path::Dispatcher::Declarative - sugary dispatcher
+
+=head1 SYNOPSIS
+
+ package MyApp::Dispatcher;
+ use Path::Dispatcher::Declarative -base;
+
+ on score => sub { show_score() };
+
+ on ['wield', qr/^\w+$/] => sub { wield_weapon($2) };
+
+ rewrite qr/^inv/ => "display inventory";
+
+ under display => sub {
+ on inventory => sub { show_inventory() };
+ on score => sub { show_score() };
+ };
+
+ package Interpreter;
+ MyApp::Dispatcher->run($input);
+
+=head1 DESCRIPTION
+
+L<Jifty::Dispatcher> rocks!
+
+=head1 KEYWORDS
+
+=head2 dispatcher -> Dispatcher
+
+Returns the L<Path::Dispatcher> object for this class; the object that the
+sugar is modifying. This is useful for adding custom rules through the regular
+API, and inspection.
+
+=head2 dispatch path -> Dispatch
+
+Invokes the dispatcher on the given path and returns a
+L<Path::Dispatcher::Dispatch> object. Acts as a keyword within the same
+package; otherwise as a method (since these declarative dispatchers are
+supposed to be used by other packages).
+
+=head2 run path, args
+
+Performs a dispatch then invokes the L<Path::Dispatcher::Dispatch/run> method
+on it.
+
+=head2 on path => sub {}
+
+Adds a rule to the dispatcher for the given path. The path may be:
+
+=over 4
+
+=item a string
+
+This is taken to mean a single token; creates an
+L<Path::Dispatcher::Rule::Tokens> rule.
+
+=item an array reference
+
+This is creates a L<Path::Dispatcher::Rule::Tokens> rule.
+
+=item a regular expression
+
+This is creates a L<Path::Dispatcher::Rule::Regex> rule.
+
+=item a code reference
+
+This is creates a L<Path::Dispatcher::Rule::CodeRef> rule.
+
+=back
+
+=head2 under path => sub {}
+
+Creates a L<Path::Dispatcher::Rule::Under> rule. The contents of the coderef
+should be nothing other L</on> and C<under> calls.
+
+=head2 then sub { }
+
+Creates a L<Path::Dispatcher::Rule::Always> rule that will continue on to the
+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<last_rule>.
+
+An example:
+
+ under show => sub {
+ then {
+ print "Displaying ";
+ };
+ on inventory => sub {
+ print "inventory:\n";
+ ...
+ };
+ on score => sub {
+ print "score:\n";
+ ...
+ };
+
+=cut
+
diff --git a/lib/Path/Dispatcher/Declarative/Builder.pm b/lib/Path/Dispatcher/Declarative/Builder.pm
new file mode 100644
index 0000000..a89bd65
--- /dev/null
+++ b/lib/Path/Dispatcher/Declarative/Builder.pm
@@ -0,0 +1,260 @@
+package Path::Dispatcher::Declarative::Builder;
+use Any::Moose;
+
+our $OUTERMOST_DISPATCHER;
+our $UNDER_RULE;
+
+has dispatcher => (
+ is => 'ro',
+ isa => 'Path::Dispatcher',
+ lazy => 1,
+ default => sub { return Path::Dispatcher->new },
+);
+
+has case_sensitive_tokens => (
+ is => 'rw',
+ isa => 'Bool',
+ default => 1,
+);
+
+has token_delimiter => (
+ is => 'rw',
+ isa => 'Str',
+ default => ' ',
+);
+
+sub next_rule () {
+ die "Path::Dispatcher next rule\n";
+}
+
+sub last_rule () {
+ die "Path::Dispatcher abort\n";
+}
+
+sub dispatch {
+ my $self = shift;
+
+ local $OUTERMOST_DISPATCHER = $self->dispatcher
+ if !$OUTERMOST_DISPATCHER;
+
+ $OUTERMOST_DISPATCHER->dispatch(@_);
+}
+
+sub run {
+ my $self = shift;
+
+ local $OUTERMOST_DISPATCHER = $self->dispatcher
+ if !$OUTERMOST_DISPATCHER;
+
+ $OUTERMOST_DISPATCHER->run(@_);
+}
+
+sub complete {
+ my $self = shift;
+ my $dispatcher = shift;
+
+ local $OUTERMOST_DISPATCHER = $self->dispatcher
+ if !$OUTERMOST_DISPATCHER;
+
+ $OUTERMOST_DISPATCHER->complete(@_);
+}
+
+sub rewrite {
+ my $self = shift;
+ my ($from, $to) = @_;
+ my $rewrite = sub {
+ local $OUTERMOST_DISPATCHER = $self->dispatcher
+ if !$OUTERMOST_DISPATCHER;
+ my $path = ref($to) eq 'CODE' ? $to->() : $to;
+ $OUTERMOST_DISPATCHER->run($path, @_);
+ };
+ $self->_add_rule($from, $rewrite);
+}
+
+sub on {
+ my $self = shift;
+ $self->_add_rule(@_);
+}
+
+sub enum {
+ my $self = shift;
+ Path::Dispatcher::Rule::Enum->new(
+ enum => [@_],
+ );
+}
+
+sub then {
+ my $self = shift;
+ my $block = shift;
+ my $rule = Path::Dispatcher::Rule::Always->new(
+ block => sub {
+ $block->(@_);
+ next_rule;
+ },
+ );
+ $self->_add_rule($rule);
+}
+
+sub chain {
+ my $self = shift;
+ my $block = shift;
+ my $rule = Path::Dispatcher::Rule::Chain->new(
+ block => $block,
+ );
+ $self->_add_rule($rule);
+}
+
+sub under {
+ my $self = shift;
+ my ($matcher, $rules) = @_;
+
+ my $predicate = $self->_create_rule($matcher);
+ $predicate->prefix(1);
+
+ my $under = Path::Dispatcher::Rule::Under->new(
+ predicate => $predicate,
+ );
+
+ $self->_add_rule($under, @_);
+
+ do {
+ local $UNDER_RULE = $under;
+ $rules->();
+ };
+}
+
+sub redispatch_to {
+ my $self = shift;
+ my $dispatcher = shift;
+
+ # assume it's a declarative dispatcher
+ if (!ref($dispatcher)) {
+ $dispatcher = $dispatcher->dispatcher;
+ }
+
+ my $redispatch = Path::Dispatcher::Rule::Dispatch->new(
+ dispatcher => $dispatcher,
+ );
+
+ $self->_add_rule($redispatch);
+}
+
+sub rule_creators {
+ return {
+ ARRAY => sub {
+ my ($self, $tokens, $block) = @_;
+
+ Path::Dispatcher::Rule::Tokens->new(
+ tokens => $tokens,
+ delimiter => $self->token_delimiter,
+ case_sensitive => $self->case_sensitive_tokens,
+ $block ? (block => $block) : (),
+ ),
+ },
+ HASH => sub {
+ my ($self, $metadata_matchers, $block) = @_;
+
+ if (keys %$metadata_matchers == 1) {
+ my ($field) = keys %$metadata_matchers;
+ my ($value) = values %$metadata_matchers;
+ my $matcher = $self->_create_rule($value);
+
+ return Path::Dispatcher::Rule::Metadata->new(
+ field => $field,
+ matcher => $matcher,
+ $block ? (block => $block) : (),
+ );
+ }
+
+ die "Doesn't support multiple metadata rules yet";
+ },
+ CODE => sub {
+ my ($self, $matcher, $block) = @_;
+ Path::Dispatcher::Rule::CodeRef->new(
+ matcher => $matcher,
+ $block ? (block => $block) : (),
+ ),
+ },
+ Regexp => sub {
+ my ($self, $regex, $block) = @_;
+ Path::Dispatcher::Rule::Regex->new(
+ regex => $regex,
+ $block ? (block => $block) : (),
+ ),
+ },
+ empty => sub {
+ my ($self, $undef, $block) = @_;
+ Path::Dispatcher::Rule::Empty->new(
+ $block ? (block => $block) : (),
+ ),
+ },
+ };
+}
+
+sub _create_rule {
+ my ($self, $matcher, $block) = @_;
+
+ my $rule_creator;
+
+ if ($matcher eq '') {
+ $rule_creator = $self->rule_creators->{empty};
+ }
+ elsif (!ref($matcher)) {
+ $rule_creator = $self->rule_creators->{ARRAY};
+ $matcher = [$matcher];
+ }
+ else {
+ $rule_creator = $self->rule_creators->{ ref $matcher };
+ }
+
+ $rule_creator or die "I don't know how to create a rule for type $matcher";
+
+ return $rule_creator->($self, $matcher, $block);
+}
+
+sub _add_rule {
+ my $self = shift;
+ my $rule;
+
+ if (blessed($_[0]) && $_[0]->isa('Path::Dispatcher::Rule')) {
+ $rule = shift;
+ }
+ else {
+ my ($matcher, $block) = splice @_, 0, 2;
+ $rule = $self->_create_rule($matcher, $block);
+ }
+
+ # FIXME: broken since move from ::Declarative
+ # XXX: caller level should be closer to $Test::Builder::Level
+# my (undef, $file, $line) = caller(1);
+ my (undef, $file, $line) = caller(2);
+ my $rule_name = "$file:$line";
+
+ if (!defined(wantarray)) {
+ if ($UNDER_RULE) {
+ $UNDER_RULE->add_rule($rule);
+
+ my $full_name = $UNDER_RULE->has_name
+ ? "(" . $UNDER_RULE->name . " - rule $rule_name)"
+ : "(anonymous Under - rule $rule_name)";
+
+ $rule->name($full_name) unless $rule->has_name;
+ }
+ else {
+ $self->dispatcher->add_rule($rule);
+ $rule->name("(" . $self->dispatcher->name . " - rule $rule_name)")
+ unless $rule->has_name;
+ }
+ }
+ else {
+ $rule->name($rule_name)
+ unless $rule->has_name;
+ return $rule, @_;
+ }
+}
+
+__PACKAGE__->meta->make_immutable;
+no Any::Moose;
+
+1;
+
diff --git a/t/016-more-under.t b/t/016-more-under.t
new file mode 100644
index 0000000..04763be
--- /dev/null
+++ b/t/016-more-under.t
@@ -0,0 +1,52 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 8;
+
+my @calls;
+
+do {
+ package Under::Where;
+ use Path::Dispatcher::Declarative -base;
+
+ under 'ticket' => sub {
+ on 'create' => sub { push @calls, "ticket create" };
+ on 'update' => sub { push @calls, "ticket update" };
+ };
+
+ under 'blog' => sub {
+ under 'post' => sub {
+ on 'create' => sub { push @calls, "create blog post" };
+ on 'delete' => sub { push @calls, "delete blog post" };
+ };
+ under 'comment' => sub {
+ on 'create' => sub { push @calls, "create blog comment" };
+ on 'delete' => sub { push @calls, "delete blog comment" };
+ };
+ };
+};
+
+Under::Where->run('ticket create');
+is_deeply([splice @calls], ['ticket create']);
+
+Under::Where->run('ticket update');
+is_deeply([splice @calls], ['ticket update']);
+
+Under::Where->run('ticket foo');
+is_deeply([splice @calls], []);
+
+Under::Where->run('blog');
+is_deeply([splice @calls], []);
+
+Under::Where->run('blog post');
+is_deeply([splice @calls], []);
+
+Under::Where->run('blog post create');
+is_deeply([splice @calls], ['create blog post']);
+
+Under::Where->run('blog comment');
+is_deeply([splice @calls], []);
+
+Under::Where->run('blog comment create');
+is_deeply([splice @calls], ['create blog comment']);
+
diff --git a/t/020-chain.t b/t/020-chain.t
new file mode 100644
index 0000000..6cdb7a7
--- /dev/null
+++ b/t/020-chain.t
@@ -0,0 +1,162 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 40;
+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']);
+
diff --git a/t/021-declarative-defaults.t b/t/021-declarative-defaults.t
new file mode 100644
index 0000000..2422f63
--- /dev/null
+++ b/t/021-declarative-defaults.t
@@ -0,0 +1,25 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+my @calls;
+do {
+ package Web::Dispatcher;
+ use base 'Path::Dispatcher::Declarative';
+
+ use constant token_delimiter => '/';
+
+
+ package My::Other::Dispatcher;
+ # we can't use a package in the same file :/
+ BEGIN { Web::Dispatcher->import('-base') };
+
+ on ['foo', 'bar'] => sub {
+ push @calls, '/foo/bar';
+ };
+};
+
+My::Other::Dispatcher->run('/foo/bar');
+is_deeply([splice @calls], ['/foo/bar']);
+
diff --git a/t/100-declarative.t b/t/100-declarative.t
new file mode 100644
index 0000000..f7868a1
--- /dev/null
+++ b/t/100-declarative.t
@@ -0,0 +1,83 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 11;
+
+my @calls;
+
+do {
+ package MyApp::Dispatcher;
+ use Path::Dispatcher::Declarative -base;
+
+ on qr/(b)(ar)(.*)/ => sub {
+ push @calls, [$1, $2, $3];
+ };
+
+ on ['token', 'matching'] => sub {
+ push @calls, [$1, $2];
+ };
+
+ rewrite quux => 'bar';
+ rewrite qr/^quux-(.*)/ => sub { "bar:$1" };
+
+ on alpha => sub {
+ push @calls, "alpha"
+ };
+
+ under alpha => sub {
+ then {
+ push @calls, "alpha (chain) ";
+ };
+ on one => sub {
+ push @calls, "one";
+ };
+
+ then {
+ push @calls, "(before two or three) ";
+ };
+ on two => sub {
+ push @calls, "two";
+ };
+ on three => sub {
+ push @calls, "three";
+ };
+ };
+};
+
+ok(MyApp::Dispatcher->isa('Path::Dispatcher::Declarative'), "use Path::Dispatcher::Declarative sets up ISA");
+
+can_ok('MyApp::Dispatcher' => qw/dispatcher dispatch run/);
+MyApp::Dispatcher->run('foobarbaz');
+is_deeply([splice @calls], [
+ [ 'b', 'ar', 'baz' ],
+]);
+
+MyApp::Dispatcher->run('quux');
+is_deeply([splice @calls], [
+ [ 'b', 'ar', '' ],
+]);
+
+MyApp::Dispatcher->run('quux-hello');
+is_deeply([splice @calls], [
+ [ 'b', 'ar', ':hello' ],
+]);
+
+MyApp::Dispatcher->run('token matching');
+is_deeply([splice @calls], [
+ [ 'token', 'matching' ],
+]);
+
+MyApp::Dispatcher->run('Token Matching');
+is_deeply([splice @calls], [], "token matching is by default case sensitive");
+
+MyApp::Dispatcher->run('alpha');
+is_deeply([splice @calls], ['alpha']);
+
+MyApp::Dispatcher->run('alpha one');
+is_deeply([splice @calls], ['alpha (chain) ', 'one']);
+
+MyApp::Dispatcher->run('alpha two');
+is_deeply([splice @calls], ['alpha (chain) ', '(before two or three) ', 'two']);
+
+MyApp::Dispatcher->run('alpha three');
+is_deeply([splice @calls], ['alpha (chain) ', '(before two or three) ', 'three']);
diff --git a/t/101-subclass.t b/t/101-subclass.t
new file mode 100644
index 0000000..1af982f
--- /dev/null
+++ b/t/101-subclass.t
@@ -0,0 +1,42 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+my @calls;
+
+do {
+ package MyFramework::Dispatcher;
+ use Path::Dispatcher::Declarative -base;
+
+ on 'quit' => sub { push @calls, 'framework: quit' };
+
+ package MyApp::Dispatcher;
+ # this hack is here because "use" expects there to be a file for the module
+ BEGIN { MyFramework::Dispatcher->import("-base") }
+
+ on qr/.*/ => sub {
+ push @calls, 'app: first .*';
+ next_rule;
+ };
+
+ redispatch_to('MyFramework::Dispatcher');
+
+ on qr/.*/ => sub {
+ push @calls, 'app: second .*';
+ next_rule;
+ };
+};
+
+MyApp::Dispatcher->run("quit");
+is_deeply([splice @calls], [
+ 'app: first .*',
+ 'framework: quit',
+]);
+
+MyApp::Dispatcher->run("other");
+is_deeply([splice @calls], [
+ 'app: first .*',
+ 'app: second .*',
+]);
+
diff --git a/t/102-abort.t b/t/102-abort.t
new file mode 100644
index 0000000..6674973
--- /dev/null
+++ b/t/102-abort.t
@@ -0,0 +1,58 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+my @calls;
+
+do {
+ package MyFramework::Dispatcher;
+ use Path::Dispatcher::Declarative -base;
+ on qr/abort/ => sub {
+ push @calls, 'framework on abort';
+ };
+
+ on qr/next rule/ => sub {
+ push @calls, 'framework before next_rule';
+ next_rule;
+ push @calls, 'framework after next_rule';
+ };
+
+ on qr/next rule/ => sub {
+ push @calls, 'framework before next_rule 2';
+ next_rule;
+ push @calls, 'framework after next_rule 2';
+ };
+
+ package MyApp::Dispatcher;
+ # this hack is here because "use" expects there to be a file for the module
+ BEGIN { MyFramework::Dispatcher->import("-base") }
+
+ on qr/next rule/ => sub {
+ push @calls, 'app before next_rule';
+ next_rule;
+ push @calls, 'app after next_rule';
+ };
+
+ on qr/next rule/ => sub {
+ push @calls, 'app before next_rule 2';
+ next_rule;
+ push @calls, 'app after next_rule 2';
+ };
+
+ redispatch_to('MyFramework::Dispatcher');
+};
+
+MyApp::Dispatcher->run('abort');
+is_deeply([splice @calls], [
+ 'framework on abort',
+]);
+
+MyApp::Dispatcher->run('next rule');
+is_deeply([splice @calls], [
+ 'app before next_rule',
+ 'app before next_rule 2',
+ 'framework before next_rule',
+ 'framework before next_rule 2',
+]);
+
diff --git a/t/103-input.t b/t/103-input.t
new file mode 100644
index 0000000..16329c9
--- /dev/null
+++ b/t/103-input.t
@@ -0,0 +1,57 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+my @calls;
+
+do {
+ package MyFramework::Dispatcher;
+ use Path::Dispatcher::Declarative -base;
+
+ on qr/a(rg)s/ => sub {
+ push @calls, {
+ from => "framework",
+ args => [@_],
+ it => $_,
+ one => $1,
+ two => $2,
+ };
+ };
+
+ package MyApp::Dispatcher;
+ # this hack is here because "use" expects there to be a file for the module
+ BEGIN { MyFramework::Dispatcher->import("-base") }
+
+ on qr/ar(g)s/ => sub {
+ push @calls, {
+ from => "app",
+ args => [@_],
+ it => $_,
+ one => $1,
+ two => $2,
+ };
+ next_rule;
+ };
+
+ redispatch_to(MyFramework::Dispatcher->dispatcher);
+};
+
+MyApp::Dispatcher->run('args', 1..3);
+is_deeply([splice @calls], [
+ {
+ from => 'app',
+ one => 'g',
+ two => undef,
+ it => 'args',
+ args => [1, 2, 3],
+ },
+ {
+ from => 'framework',
+ one => 'rg',
+ two => undef,
+ it => 'args',
+ args => [1, 2, 3],
+ },
+]);
+
diff --git a/t/104-config.t b/t/104-config.t
new file mode 100644
index 0000000..e72e57b
--- /dev/null
+++ b/t/104-config.t
@@ -0,0 +1,31 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 5;
+
+my @calls;
+
+do {
+ package RESTy::Dispatcher;
+ use Path::Dispatcher::Declarative -base, -default => {
+ token_delimiter => '/',
+ case_sensitive_tokens => 0,
+ };
+
+ on ['=', 'model', 'Comment'] => sub { push @calls, $3 };
+};
+
+ok(RESTy::Dispatcher->isa('Path::Dispatcher::Declarative'), "use Path::Dispatcher::Declarative sets up ISA");
+
+RESTy::Dispatcher->run('= model Comment');
+is_deeply([splice @calls], []);
+
+RESTy::Dispatcher->run('/=/model/Comment');
+is_deeply([splice @calls], ["Comment"]);
+
+RESTy::Dispatcher->run('/=/model/comment');
+is_deeply([splice @calls], ["comment"]);
+
+RESTy::Dispatcher->run('///=///model///COMMENT///');
+is_deeply([splice @calls], ["COMMENT"]);
+
diff --git a/t/105-empty.t b/t/105-empty.t
new file mode 100644
index 0000000..00b7840
--- /dev/null
+++ b/t/105-empty.t
@@ -0,0 +1,22 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+my @calls;
+
+do {
+ package MyApp::Dispatcher;
+ use Path::Dispatcher::Declarative -base;
+
+ on '' => sub {
+ push @calls, "empty: $_";
+ };
+};
+
+MyApp::Dispatcher->run("foo");
+is_deeply([splice @calls], []);
+
+MyApp::Dispatcher->run("");
+is_deeply([splice @calls], ["empty: "]);
+
diff --git a/t/106-metadata.t b/t/106-metadata.t
new file mode 100644
index 0000000..b8d4c5e
--- /dev/null
+++ b/t/106-metadata.t
@@ -0,0 +1,52 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+my @calls;
+
+do {
+ package MyApp::Dispatcher;
+ use Path::Dispatcher::Declarative -base;
+
+ on { method => 'GET' } => sub {
+ push @calls, "method: GET, path: $_";
+ };
+};
+
+my $path = Path::Dispatcher::Path->new(
+ path => "/REST/Ticket/1.yml",
+ metadata => {
+ method => "GET",
+ query_parameters => {
+ owner => 'Sartak',
+ status => 'closed',
+ },
+ },
+);
+
+MyApp::Dispatcher->run($path);
+is_deeply([splice @calls], ["method: GET, path: /REST/Ticket/1.yml"]);
+
+do {
+ package MyApp::Other::Dispatcher;
+ use Path::Dispatcher::Declarative -base;
+
+ on {
+ query_parameters => {
+ owner => qr/^\w+$/,
+ },
+ } => sub {
+ push @calls, "query_parameters/owner/regex";
+ };
+};
+
+TODO: {
+ local $TODO = "metadata can't be a deep data structure";
+
+ eval {
+ MyApp::Other::Dispatcher->run($path);
+ };
+ is_deeply([splice @calls], ["query_parameters/owner/regex"]);
+};
+
diff --git a/t/200-under-next_rule.t b/t/200-under-next_rule.t
new file mode 100644
index 0000000..67e1fc1
--- /dev/null
+++ b/t/200-under-next_rule.t
@@ -0,0 +1,32 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+my @calls;
+
+do {
+ package MyApp::Dispatcher;
+ use Path::Dispatcher::Declarative -base;
+
+ under first => sub {
+ on qr/./ => sub {
+ push @calls, "[$_] first -> regex";
+ next_rule;
+ };
+
+ on second => sub {
+ push @calls, "[$_] first -> string, via next_rule";
+ };
+ };
+};
+
+TODO: {
+ local $TODO = "under doesn't pass its matched fragment as part of the path";
+ MyApp::Dispatcher->run("first second");
+ is_deeply([splice @calls], [
+ "[first second] first -> regex",
+ "[first second] first -> string, via next_rule",
+ ]);
+}
+
diff --git a/t/300-complete-simple.t b/t/300-complete-simple.t
new file mode 100644
index 0000000..fa5479e
--- /dev/null
+++ b/t/300-complete-simple.t
@@ -0,0 +1,53 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 16;
+use Path::Dispatcher;
+
+my $complete = Path::Dispatcher::Rule::Eq->new(string => "complete");
+is_deeply([$complete->complete(Path::Dispatcher::Path->new('x'))], []);
+is_deeply([$complete->complete(Path::Dispatcher::Path->new('completexxx'))], []);
+is_deeply([$complete->complete(Path::Dispatcher::Path->new('cxxx'))], []);
+
+is_deeply([$complete->complete(Path::Dispatcher::Path->new('c'))], ['complete']);
+is_deeply([$complete->complete(Path::Dispatcher::Path->new('compl'))], ['complete']);
+is_deeply([$complete->complete(Path::Dispatcher::Path->new('complete'))], ['complete']);
+
+do {
+ package MyApp::Dispatcher;
+ use Path::Dispatcher::Declarative -base;
+
+ on foo => sub { die "do not call blocks!" };
+ on bar => sub { die "do not call blocks!" };
+ on baz => sub { die "do not call blocks!" };
+};
+
+my $dispatcher = MyApp::Dispatcher->dispatcher;
+sub complete_ok {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $path = shift;
+ my @expected = @_;
+
+ my @got = $dispatcher->complete($path);
+
+ my $message = @expected == 0 ? "no completions"
+ : @expected == 1 ? "one completion"
+ : @expected . " completions";
+ $message .= " for path '$path'";
+
+ is_deeply(\@got, \@expected, $message);
+}
+
+complete_ok('x');
+complete_ok('foooo');
+complete_ok('baq');
+
+complete_ok(f => 'foo');
+complete_ok(fo => 'foo');
+complete_ok('foo');
+
+complete_ok('b' => 'bar', 'baz');
+complete_ok('ba' => 'bar', 'baz');
+complete_ok('bar');
+complete_ok('baz');
+
diff --git a/t/301-complete-complex.t b/t/301-complete-complex.t
new file mode 100644
index 0000000..f57b02e
--- /dev/null
+++ b/t/301-complete-complex.t
@@ -0,0 +1,73 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 16;
+
+do {
+ package MyApp::Dispatcher;
+ use Path::Dispatcher::Declarative -base;
+
+ on qr/(b)(ar)(.*)/ => sub { die "do not call blocks!" };
+ on ['token', 'matching'] => sub { die "do not call blocks!" };
+
+ rewrite quux => 'bar';
+ rewrite qr/^quux-(.*)/ => sub { "bar:$1" };
+
+ on alpha => sub { die "do not call blocks!" };
+
+ under alpha => sub {
+ then { die "do not call blocks!" };
+ on one => sub { die "do not call blocks!" };
+ then { die "do not call blocks!" };
+ on two => sub { die "do not call blocks!" };
+ on three => sub { die "do not call blocks!" };
+ };
+
+ under beta => sub {
+ on a => sub { die "do not call blocks!" };
+ on b => sub { die "do not call blocks!" };
+ };
+};
+
+my $dispatcher = MyApp::Dispatcher->dispatcher;
+
+sub complete_ok {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $path = shift;
+ my @expected = @_;
+
+ my @got = $dispatcher->complete($path);
+
+ my $message = @expected == 0 ? "no completions"
+ : @expected == 1 ? "one completion"
+ : @expected . " completions";
+ $message .= " for path '$path'";
+
+ is_deeply(\@got, \@expected, $message);
+}
+
+complete_ok('x');
+
+complete_ok(q => 'quux');
+
+complete_ok(a => 'alpha');
+complete_ok(alpha => 'alpha one', 'alpha two', 'alpha three');
+
+complete_ok(t => 'token');
+complete_ok(token => 'token matching');
+complete_ok('token m' => 'token matching');
+complete_ok('token matchin' => 'token matching');
+complete_ok('token matching');
+
+complete_ok(bet => 'beta');
+complete_ok(beta => 'beta a', 'beta b');
+complete_ok('beta a');
+complete_ok('beta b');
+complete_ok('beta c');
+
+TODO: {
+ local $TODO = "cannot complete regex rules (yet!)";
+ complete_ok(quux => 'quux-');
+ complete_ok(b => 'bar', 'beta');
+};
+
diff --git a/t/302-complete-delimiter.t b/t/302-complete-delimiter.t
new file mode 100644
index 0000000..3f9f46a
--- /dev/null
+++ b/t/302-complete-delimiter.t
@@ -0,0 +1,57 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 18;
+
+do {
+ package MyApp::Dispatcher;
+ use Path::Dispatcher::Declarative -base, -default => {
+ token_delimiter => '/',
+ };
+
+ on ['token', 'matching'] => sub { die "do not call blocks!" };
+
+ under alpha => sub {
+ on one => sub { die "do not call blocks!" };
+ on two => sub { die "do not call blocks!" };
+ on three => sub { die "do not call blocks!" };
+ };
+};
+
+my $dispatcher = MyApp::Dispatcher->dispatcher;
+
+sub complete_ok {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $path = shift;
+ my @expected = @_;
+
+ my @got = $dispatcher->complete($path);
+
+ my $message = @expected == 0 ? "no completions"
+ : @expected == 1 ? "one completion"
+ : @expected . " completions";
+ $message .= " for path '$path'";
+
+ is_deeply(\@got, \@expected, $message);
+}
+
+complete_ok(t => 'token');
+complete_ok(toke => 'token');
+complete_ok('token' => 'token/matching');
+complete_ok('token/' => 'token/matching');
+complete_ok('token/m' => 'token/matching');
+complete_ok('token/matchin' => 'token/matching');
+complete_ok('token/matching');
+complete_ok('token/x');
+complete_ok('token/mx');
+
+complete_ok(a => 'alpha');
+complete_ok(alph => 'alpha');
+complete_ok(alpha => 'alpha/one', 'alpha/two', 'alpha/three');
+complete_ok('alpha/' => 'alpha/one', 'alpha/two', 'alpha/three');
+complete_ok('alpha/o' => 'alpha/one');
+complete_ok('alpha/t' => 'alpha/two', 'alpha/three');
+complete_ok('alpha/tw' => 'alpha/two');
+complete_ok('alpha/th' => 'alpha/three');
+complete_ok('alpha/x');
+
diff --git a/t/303-complete-alternation.t b/t/303-complete-alternation.t
new file mode 100644
index 0000000..e05f56f
--- /dev/null
+++ b/t/303-complete-alternation.t
@@ -0,0 +1,59 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 20;
+
+do {
+ package MyApp::Dispatcher;
+ use Path::Dispatcher::Declarative -base;
+
+ under gate => sub {
+ on [ ['foo', 'bar', 'baz'] ] => sub { die };
+ on quux => sub { die };
+ };
+};
+
+my $dispatcher = MyApp::Dispatcher->dispatcher;
+
+sub complete_ok {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $path = shift;
+ my @expected = @_;
+
+ my @got = $dispatcher->complete($path);
+
+ my $message = @expected == 0 ? "no completions"
+ : @expected == 1 ? "one completion"
+ : @expected . " completions";
+ $message .= " for path '$path'";
+
+ is_deeply(\@got, \@expected, $message);
+}
+
+complete_ok('z');
+complete_ok('gate z');
+complete_ok('zig ');
+complete_ok('zig f');
+complete_ok('zig fo');
+complete_ok('zig foo');
+
+complete_ok(g => 'gate');
+complete_ok(ga => 'gate');
+complete_ok(gat => 'gate');
+
+complete_ok(gate => 'gate foo', 'gate bar', 'gate baz', 'gate quux');
+complete_ok('gate ' => 'gate foo', 'gate bar', 'gate baz', 'gate quux');
+
+complete_ok('gate f' => 'gate foo');
+
+complete_ok('gate b' => 'gate bar', 'gate baz');
+complete_ok('gate ba' => 'gate bar', 'gate baz');
+
+complete_ok('gate q' => 'gate quux');
+complete_ok('gate quu' => 'gate quux');
+
+complete_ok('gate foo');
+complete_ok('gate bar');
+complete_ok('gate baz');
+complete_ok('gate quux');
+
diff --git a/t/304-complete-enum.t b/t/304-complete-enum.t
new file mode 100644
index 0000000..dddbf2e
--- /dev/null
+++ b/t/304-complete-enum.t
@@ -0,0 +1,59 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 20;
+
+do {
+ package MyApp::Dispatcher;
+ use Path::Dispatcher::Declarative -base;
+
+ under gate => sub {
+ on enum('foo', 'bar', 'baz') => sub { die };
+ on quux => sub { die };
+ };
+};
+
+my $dispatcher = MyApp::Dispatcher->dispatcher;
+
+sub complete_ok {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $path = shift;
+ my @expected = @_;
+
+ my @got = $dispatcher->complete($path);
+
+ my $message = @expected == 0 ? "no completions"
+ : @expected == 1 ? "one completion"
+ : @expected . " completions";
+ $message .= " for path '$path'";
+
+ is_deeply(\@got, \@expected, $message);
+}
+
+complete_ok('z');
+complete_ok('gate z');
+complete_ok('zig ');
+complete_ok('zig f');
+complete_ok('zig fo');
+complete_ok('zig foo');
+
+complete_ok(g => 'gate');
+complete_ok(ga => 'gate');
+complete_ok(gat => 'gate');
+
+complete_ok(gate => 'gate foo', 'gate bar', 'gate baz', 'gate quux');
+complete_ok('gate ' => 'gate foo', 'gate bar', 'gate baz', 'gate quux');
+
+complete_ok('gate f' => 'gate foo');
+
+complete_ok('gate b' => 'gate bar', 'gate baz');
+complete_ok('gate ba' => 'gate bar', 'gate baz');
+
+complete_ok('gate q' => 'gate quux');
+complete_ok('gate quu' => 'gate quux');
+
+complete_ok('gate foo');
+complete_ok('gate bar');
+complete_ok('gate baz');
+complete_ok('gate quux');
+
diff --git a/t/800-cb-slash-path-delimiter.t b/t/800-cb-slash-path-delimiter.t
new file mode 100644
index 0000000..f91f35b
--- /dev/null
+++ b/t/800-cb-slash-path-delimiter.t
@@ -0,0 +1,32 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 3;
+
+my @result;
+
+do {
+ package MyDispatcher;
+ use Path::Dispatcher::Declarative -base, -default => {
+ token_delimiter => '/',
+ };
+
+ under show => sub {
+ on inventory => sub {
+ push @result, "inventory";
+ };
+ on score => sub {
+ push @result, "score";
+ };
+ };
+};
+
+MyDispatcher->run('show/inventory');
+is_deeply([splice @result], ['inventory']);
+
+MyDispatcher->run('show/score');
+is_deeply([splice @result], ['score']);
+
+MyDispatcher->run('show inventory');
+is_deeply([splice @result], []);
+
diff --git a/t/801-cb-chaining.t b/t/801-cb-chaining.t
new file mode 100644
index 0000000..415c0df
--- /dev/null
+++ b/t/801-cb-chaining.t
@@ -0,0 +1,34 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 3;
+
+my @result;
+
+do {
+ package MyDispatcher;
+ use Path::Dispatcher::Declarative -base;
+
+ under show => sub {
+ then {
+ push @result, "Displaying";
+ };
+ on inventory => sub {
+ push @result, "inventory";
+ };
+ on score => sub {
+ push @result, "score";
+ };
+ };
+};
+
+MyDispatcher->run('show inventory');
+is_deeply([splice @result], ['Displaying', 'inventory']);
+
+MyDispatcher->run('show score');
+is_deeply([splice @result], ['Displaying', 'score']);
+
+MyDispatcher->run('show');
+is_deeply([splice @result], ['Displaying']); # This is kinda weird
+
+
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list