r49646 - in /branches/upstream/libpath-dispatcher-perl/current: ./ lib/Path/ lib/Path/Dispatcher/ lib/Path/Dispatcher/Rule/ t/

christine at users.alioth.debian.org christine at users.alioth.debian.org
Thu Dec 31 21:30:12 UTC 2009


Author: christine
Date: Thu Dec 31 21:30:02 2009
New Revision: 49646

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=49646
Log:
[svn-upgrade] Integrating new upstream version, libpath-dispatcher-perl (0.14)

Added:
    branches/upstream/libpath-dispatcher-perl/current/t/300-complete-simple.t
    branches/upstream/libpath-dispatcher-perl/current/t/301-complete-complex.t
    branches/upstream/libpath-dispatcher-perl/current/t/302-complete-delimiter.t
    branches/upstream/libpath-dispatcher-perl/current/t/303-complete-alternation.t
Removed:
    branches/upstream/libpath-dispatcher-perl/current/META.yml
    branches/upstream/libpath-dispatcher-perl/current/SIGNATURE
Modified:
    branches/upstream/libpath-dispatcher-perl/current/Changes
    branches/upstream/libpath-dispatcher-perl/current/MANIFEST
    branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher.pm
    branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Builder.pm
    branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Cookbook.pod
    branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Declarative.pm
    branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Match.pm
    branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule.pm
    branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule/Eq.pm
    branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule/Tokens.pm
    branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule/Under.pm
    branches/upstream/libpath-dispatcher-perl/current/t/020-chain.t
    branches/upstream/libpath-dispatcher-perl/current/t/100-declarative.t

Modified: branches/upstream/libpath-dispatcher-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpath-dispatcher-perl/current/Changes?rev=49646&op=diff
==============================================================================
--- branches/upstream/libpath-dispatcher-perl/current/Changes (original)
+++ branches/upstream/libpath-dispatcher-perl/current/Changes Thu Dec 31 21:30:02 2009
@@ -1,4 +1,6 @@
 Revision history for Path-Dispatcher
+
+0.14
 
 0.13 Sun Aug 9 13:38:19 2009
         Add unshift_rule to classes that do Role::Rules

Modified: branches/upstream/libpath-dispatcher-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpath-dispatcher-perl/current/MANIFEST?rev=49646&op=diff
==============================================================================
--- branches/upstream/libpath-dispatcher-perl/current/MANIFEST (original)
+++ branches/upstream/libpath-dispatcher-perl/current/MANIFEST Thu Dec 31 21:30:02 2009
@@ -29,8 +29,6 @@
 lib/Path/Dispatcher/Rule/Under.pm
 Makefile.PL
 MANIFEST			This list of files
-META.yml
-SIGNATURE
 t/000-compile.t
 t/001-api.t
 t/002-rule.t
@@ -61,6 +59,10 @@
 t/105-empty.t
 t/106-metadata.t
 t/200-under-next_rule.t
+t/300-complete-simple.t
+t/301-complete-complex.t
+t/302-complete-delimiter.t
+t/303-complete-alternation.t
 t/800-cb-slash-path-delimiter.t
 t/801-cb-chaining.t
 t/900-use-path-dispatcher.t

Modified: branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher.pm?rev=49646&op=diff
==============================================================================
--- branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher.pm (original)
+++ branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher.pm Thu Dec 31 21:30:02 2009
@@ -2,7 +2,7 @@
 use Any::Moose;
 use 5.008001;
 
-our $VERSION = '0.13';
+our $VERSION = '0.14';
 
 use Path::Dispatcher::Rule;
 use Path::Dispatcher::Dispatch;
@@ -55,9 +55,6 @@
 
     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;
@@ -70,6 +67,21 @@
     my $dispatch = $self->dispatch($path);
 
     return $dispatch->run(@_);
+}
+
+sub complete {
+    my $self = shift;
+    my $path = shift;
+
+    # Automatically box paths
+    unless (blessed($path) && $path->isa('Path::Dispatcher::Path')) {
+        $path = $self->path_class->new(
+            path => $path,
+        );
+    }
+
+    my %seen;
+    return grep { !$seen{$_}++ } map { $_->complete($path) } $self->rules;
 }
 
 # We don't export anything, so if they request something, then try to error
@@ -120,15 +132,16 @@
 
 =head1 DESCRIPTION
 
-We really like L<Jifty::Dispatcher> and wanted to use it for the command line.
+We really like L<Jifty::Dispatcher> and wanted to use it for L<Prophet>'s
+command line.
 
 The basic operation is that of dispatch. Dispatch takes a path and a list of
 rules, and it returns a list of matches. From there you can "run" the rules
 that matched. These phases are distinct so that, if you need to, you can
 inspect which rules were matched without ever running their codeblocks.
 
-Most consumers would want to use L<Path::Dispatcher::Declarative> which gives
-you some sugar, inspired by L<Jifty::Dispatcher>.
+You want to use L<Path::Dispatcher::Declarative> which gives you some sugar
+inspired by L<Jifty::Dispatcher>.
 
 =head1 ATTRIBUTES
 
@@ -161,6 +174,20 @@
 The args are passed down directly into each rule codeblock. No other args are
 given to the codeblock.
 
+=head2 complete path -> strings
+
+Given a path, consult each rule for possible completions for the path. This is
+intended for tab completion. You can use it with L<Term::ReadLine> like so:
+
+    $term->Attribs->{completion_function} = sub {
+        my ($last_word, $line, $start) = @_;
+        my @matches = map { s/^.* //; $_ } $dispatcher->complete($line);
+        return @matches;
+    };
+
+This API is experimental and subject to change. In particular I think I want to
+return an object that resembles L<Path::Dispatcher::Dispatch>.
+
 =head1 AUTHOR
 
 Shawn M Moore, C<< <sartak at bestpractical.com> >>
@@ -185,6 +212,8 @@
 
 =item L<Path::Router>
 
+=item L<http://github.com/bestpractical/path-dispatcher-debugger> - Not quite ready for release
+
 =back
 
 =head1 COPYRIGHT & LICENSE

Modified: branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Builder.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Builder.pm?rev=49646&op=diff
==============================================================================
--- branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Builder.pm (original)
+++ branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Builder.pm Thu Dec 31 21:30:02 2009
@@ -47,6 +47,16 @@
         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 {

Modified: branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Cookbook.pod
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Cookbook.pod?rev=49646&op=diff
==============================================================================
--- branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Cookbook.pod (original)
+++ branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Cookbook.pod Thu Dec 31 21:30:02 2009
@@ -21,10 +21,10 @@
 
     package Web::Dispatcher;
     use base 'Path::Dispatcher::Declarative';
-    
+
     use constant token_delimiter => '/';
-    
-    
+
+
     package My::Other::Dispatcher;
     use Web::Dispatcher -base;
 

Modified: branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Declarative.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Declarative.pm?rev=49646&op=diff
==============================================================================
--- branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Declarative.pm (original)
+++ branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Declarative.pm Thu Dec 31 21:30:02 2009
@@ -58,6 +58,7 @@
         redispatch_to => sub { $builder->redispatch_to(@_) },
         next_rule     => sub { $builder->next_rule(@_) },
         last_rule     => sub { $builder->last_rule(@_) },
+        complete      => sub { $builder->complete(@_) },
 
         then  => sub (&) { $builder->then(@_) },
         chain => sub (&) { $builder->chain(@_) },
@@ -100,7 +101,7 @@
     use Path::Dispatcher::Declarative -base;
 
     on score => sub { show_score() };
-    
+
     on ['wield', qr/^\w+$/] => sub { wield_weapon($2) };
 
     rewrite qr/^inv/ => "display inventory";

Modified: branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Match.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Match.pm?rev=49646&op=diff
==============================================================================
--- branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Match.pm (original)
+++ branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Match.pm Thu Dec 31 21:30:02 2009
@@ -59,7 +59,7 @@
     my $str = join '', map { defined($_) ? $_         : ""             } @_;
 
     # we need to check length because Perl's annoying gotcha of the empty regex
-    # actually being an alias for whatever the previously used regex was 
+    # actually being an alias for whatever the previously used regex was
     # (useful last decade when qr// hadn't been invented)
     # we need to do the match anyway, because we have to clear the number vars
     ($str, $re) = ("x", "x") if length($str) == 0;

Modified: branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule.pm?rev=49646&op=diff
==============================================================================
--- branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule.pm (original)
+++ branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule.pm Thu Dec 31 21:30:02 2009
@@ -27,7 +27,14 @@
     my $self = shift;
     my $path = shift;
 
-    my ($result, $leftover) = $self->_match($path);
+    my ($result, $leftover);
+
+    if ($self->prefix) {
+        ($result, $leftover) = $self->_prefix_match($path);
+    }
+    else {
+        ($result, $leftover) = $self->_match($path);
+    }
 
     if (!$result) {
         $self->trace(leftover => $leftover, match => undef, path => $path)
@@ -58,6 +65,15 @@
     $self->trace(match => $match) if $ENV{'PATH_DISPATCHER_TRACE'};
 
     return $match;
+}
+
+sub complete {
+    return (); # no completions
+}
+
+sub _prefix_match {
+    my $self = shift;
+    return $self->_match(@_);
 }
 
 sub run {

Modified: branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule/Eq.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule/Eq.pm?rev=49646&op=diff
==============================================================================
--- branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule/Eq.pm (original)
+++ branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule/Eq.pm Thu Dec 31 21:30:02 2009
@@ -12,12 +12,26 @@
     my $self = shift;
     my $path = shift;
 
-    return $path->path eq $self->string unless $self->prefix;
+    return $path->path eq $self->string;
+}
+
+sub _prefix_match {
+    my $self = shift;
+    my $path = shift;
 
     my $truncated = substr($path->path, 0, length($self->string));
     return 0 unless $truncated eq $self->string;
 
     return (1, substr($path->path, length($self->string)));
+}
+
+sub complete {
+    my $self = shift;
+    my $path = shift->path;
+    my $completed = $self->string;
+
+    return unless substr($completed, 0, length($path)) eq $path;
+    return $completed;
 }
 
 sub readable_attributes { q{"} . shift->string . q{"} }

Modified: branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule/Tokens.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule/Tokens.pm?rev=49646&op=diff
==============================================================================
--- branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule/Tokens.pm (original)
+++ branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule/Tokens.pm Thu Dec 31 21:30:02 2009
@@ -21,43 +21,80 @@
     default => 1,
 );
 
+sub _match_as_far_as_possible {
+    my $self = shift;
+    my $path = shift;
+
+    my @got      = $self->tokenize($path->path);
+    my @expected = $self->tokens;
+    my @matched;
+
+    while (@got && @expected) {
+        my $expected = $expected[0];
+        my $got      = $got[0];
+
+        last unless $self->_match_token($got, $expected);
+
+        push @matched, $got;
+        shift @expected;
+        shift @got;
+    }
+
+    return (\@matched, \@got, \@expected);
+}
+
 sub _match {
     my $self = shift;
     my $path = shift;
 
-    my @tokens = $self->tokenize($path->path);
-    my @matched;
-
-    for my $expected ($self->tokens) {
-        unless (@tokens) {
-            $self->trace(no_tokens => 1, on_token => $expected, path => $path)
-                if $ENV{'PATH_DISPATCHER_TRACE'};
-            return;
-        }
-
-        my $got = shift @tokens;
-
-        unless ($self->_match_token($got, $expected)) {
-            $self->trace(
-                no_match  => 1,
-                got_token => $got,
-                on_token  => $expected,
-                path      => $path,
-            ) if $ENV{'PATH_DISPATCHER_TRACE'};
-            return;
-        }
-
-        push @matched, $got;
-    }
-
-    if (@tokens && !$self->prefix) {
-        $self->trace(tokens_left => \@tokens, path => $path)
-            if $ENV{'PATH_DISPATCHER_TRACE'};
-        return;
-    }
-
-    my $leftover = $self->untokenize(@tokens);
-    return \@matched, $leftover;
+    my ($matched, $got, $expected) = $self->_match_as_far_as_possible($path);
+
+    return if @$expected; # didn't provide everything necessary
+    return if @$got && !$self->prefix; # had tokens left over
+
+    my $leftover = $self->untokenize(@$got);
+    return $matched, $leftover;
+}
+
+sub complete {
+    my $self = shift;
+    my $path = shift;
+
+    my ($matched, $got, $expected) = $self->_match_as_far_as_possible($path);
+    return if @$got > 1; # had tokens leftover
+    return if !@$expected; # consumed all tokens
+
+    my $next = shift @$expected;
+    my $part = @$got ? shift @$got : '';
+    my @completions;
+
+    for my $completion (ref($next) eq 'ARRAY' ? @$next : $next) {
+        next if ref($completion);
+
+        next unless substr($completion, 0, length($part)) eq $part;
+        push @completions, $self->untokenize(@$matched, $completion);
+    }
+
+    return @completions;
+}
+
+sub _each_token {
+    my $self     = shift;
+    my $got      = shift;
+    my $expected = shift;
+    my $callback = shift;
+
+    if (ref($expected) eq 'ARRAY') {
+        for my $alternative (@$expected) {
+            $self->_each_token($got, $alternative, $callback);
+        }
+    }
+    elsif (!ref($expected) || ref($expected) eq 'Regexp') {
+        $callback->($got, $expected);
+    }
+    else {
+        die "Unexpected token '$expected'"; # the irony is not lost on me :)
+    }
 }
 
 sub _match_token {
@@ -65,21 +102,19 @@
     my $got      = shift;
     my $expected = shift;
 
-    if (!ref($expected)) {
-        ($got, $expected) = (lc $got, lc $expected) if !$self->case_sensitive;
-        return $got eq $expected;
-    }
-    elsif (ref($expected) eq 'ARRAY') {
-        for my $alternative (@$expected) {
-            return 1 if $self->_match_token($got, $alternative);
-        }
-    }
-    elsif (ref($expected) eq 'Regexp') {
-        return $got =~ $expected;
-    }
-    else {
-        die "Unexpected token '$expected'"; # the irony is not lost on me :)
-    }
+    my $matched = 0;
+    $self->_each_token($got, $expected, sub {
+        my ($g, $e) = @_;
+        if (!ref($e)) {
+            ($g, $e) = (lc $g, lc $e) if !$self->case_sensitive;
+            $matched ||= $g eq $e;
+        }
+        elsif (ref($e) eq 'Regexp') {
+            $matched ||= $g =~ $e;
+        }
+    });
+
+    return $matched;
 }
 
 sub tokenize {
@@ -91,7 +126,10 @@
 sub untokenize {
     my $self   = shift;
     my @tokens = @_;
-    return join $self->delimiter, @tokens;
+    return join $self->delimiter,
+           grep { length }
+           map { split $self->delimiter, $_ }
+           @tokens;
 }
 
 sub readable_attributes {

Modified: branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule/Under.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule/Under.pm?rev=49646&op=diff
==============================================================================
--- branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule/Under.pm (original)
+++ branches/upstream/libpath-dispatcher-perl/current/lib/Path/Dispatcher/Rule/Under.pm Thu Dec 31 21:30:02 2009
@@ -33,8 +33,31 @@
     # 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'); 
+    pop @matches while @matches && $matches[-1]->rule->isa('Path::Dispatcher::Rule::Chain');
     return @matches;
+}
+
+sub complete {
+    my $self = shift;
+    my $path = shift;
+
+    my $predicate = $self->predicate;
+
+    my $prefix_match = $predicate->match($path)
+        or return $predicate->complete($path);
+
+    my $new_path = $path->clone_path($prefix_match->leftover);
+
+    my $prefix = substr($path->path, 0, length($path->path) - length($new_path->path));
+
+    my @completions = map { $_->complete($new_path) } $self->rules;
+
+    if ($predicate->can('untokenize')) {
+        return map { $predicate->untokenize($prefix, $_) } @completions;
+    }
+    else {
+        return map { "$prefix$_" } @completions;
+    }
 }
 
 sub readable_attributes { shift->predicate->readable_attributes }

Modified: branches/upstream/libpath-dispatcher-perl/current/t/020-chain.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpath-dispatcher-perl/current/t/020-chain.t?rev=49646&op=diff
==============================================================================
--- branches/upstream/libpath-dispatcher-perl/current/t/020-chain.t (original)
+++ branches/upstream/libpath-dispatcher-perl/current/t/020-chain.t Thu Dec 31 21:30:02 2009
@@ -108,7 +108,6 @@
         on 'create' => sub { push @result, "ticket create" };
         chain {
             push @result, "(ticket chain just for update)";
-    
         };
         on 'update' => sub { push @result, "ticket update" };
     };
@@ -116,26 +115,22 @@
     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)";
-        
             };
         };
     };

Modified: branches/upstream/libpath-dispatcher-perl/current/t/100-declarative.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpath-dispatcher-perl/current/t/100-declarative.t?rev=49646&op=diff
==============================================================================
--- branches/upstream/libpath-dispatcher-perl/current/t/100-declarative.t (original)
+++ branches/upstream/libpath-dispatcher-perl/current/t/100-declarative.t Thu Dec 31 21:30:02 2009
@@ -26,7 +26,7 @@
 
     under alpha => sub {
         then {
-            push @calls, "alpha (chain) "; 
+            push @calls, "alpha (chain) ";
         };
         on one => sub {
             push @calls, "one";

Added: branches/upstream/libpath-dispatcher-perl/current/t/300-complete-simple.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpath-dispatcher-perl/current/t/300-complete-simple.t?rev=49646&op=file
==============================================================================
--- branches/upstream/libpath-dispatcher-perl/current/t/300-complete-simple.t (added)
+++ branches/upstream/libpath-dispatcher-perl/current/t/300-complete-simple.t Thu Dec 31 21:30:02 2009
@@ -1,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');
+

Added: branches/upstream/libpath-dispatcher-perl/current/t/301-complete-complex.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpath-dispatcher-perl/current/t/301-complete-complex.t?rev=49646&op=file
==============================================================================
--- branches/upstream/libpath-dispatcher-perl/current/t/301-complete-complex.t (added)
+++ branches/upstream/libpath-dispatcher-perl/current/t/301-complete-complex.t Thu Dec 31 21:30:02 2009
@@ -1,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');
+};
+

Added: branches/upstream/libpath-dispatcher-perl/current/t/302-complete-delimiter.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpath-dispatcher-perl/current/t/302-complete-delimiter.t?rev=49646&op=file
==============================================================================
--- branches/upstream/libpath-dispatcher-perl/current/t/302-complete-delimiter.t (added)
+++ branches/upstream/libpath-dispatcher-perl/current/t/302-complete-delimiter.t Thu Dec 31 21:30:02 2009
@@ -1,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');
+

Added: branches/upstream/libpath-dispatcher-perl/current/t/303-complete-alternation.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpath-dispatcher-perl/current/t/303-complete-alternation.t?rev=49646&op=file
==============================================================================
--- branches/upstream/libpath-dispatcher-perl/current/t/303-complete-alternation.t (added)
+++ branches/upstream/libpath-dispatcher-perl/current/t/303-complete-alternation.t Thu Dec 31 21:30:02 2009
@@ -1,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');
+




More information about the Pkg-perl-cvs-commits mailing list