[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