[Bps-public-commit] r14822 - in Prophet/branches/dispatcher: lib/Prophet lib/Prophet/CLI

[sartak at bestpractical.com]

Author: sartak
Date: Tue Aug  5 19:31:31 2008
New Revision: 14822

Modified:
   Prophet/branches/dispatcher/   (props changed)
   Prophet/branches/dispatcher/Makefile.PL
   Prophet/branches/dispatcher/lib/Prophet/CLI.pm
   Prophet/branches/dispatcher/lib/Prophet/CLI/Dispatcher.pm

Log:
 r54137 at gorgoroth:  sartak | 2008-08-05 19:31:26 -0400
 More dispatcher code


Modified: Prophet/branches/dispatcher/Makefile.PL
==============================================================================
--- Prophet/branches/dispatcher/Makefile.PL	(original)
+++ Prophet/branches/dispatcher/Makefile.PL	Tue Aug  5 19:31:31 2008
@@ -24,7 +24,7 @@
 requires('MooseX::AttributeHelpers' => '0.12');
 requires('MooseX::ClassAttribute' => '0.04');
 requires('XML::Atom::SimpleFeed');
-requires('Path::Dispatcher');
+requires('Path::Dispatcher'); # Path::Dispatcher::Declarative
 
 features(
     'Web server' => [

Modified: Prophet/branches/dispatcher/lib/Prophet/CLI.pm
==============================================================================
--- Prophet/branches/dispatcher/lib/Prophet/CLI.pm	(original)
+++ Prophet/branches/dispatcher/lib/Prophet/CLI.pm	Tue Aug  5 19:31:31 2008
@@ -7,6 +7,7 @@
 use Prophet::Collection;
 use Prophet::Replica;
 use Prophet::CLI::Command;
+use Prophet::CLI::Dispatcher;
 
 use List::Util 'first';
 
@@ -121,46 +122,17 @@
 sub _get_cmd_obj {
     my $self = shift;
 
-    my $aliases  = $self->app_handle->config->aliases;
-    my $tmp      = $self->primary_commands;
-    if (@$tmp && $aliases->{$tmp->[0]}) {
-        @ARGV = split ' ', $aliases->{$tmp->[0]};
-        return $self->run_one_command;
-    }
-    my @commands = map { exists $CMD_MAP{$_} ? $CMD_MAP{$_} : $_ } @{ $tmp };
-
-    my @possible_classes;
-
-    my @to_try = @commands;
-
-    while (@to_try) {
-
-        # App::SD::CLI::Command::Ticket::Comment::List
-        my $cmd = $self->app_class . "::CLI::Command::" . join('::', map { ucfirst lc $_ } @to_try);
-
-        push @possible_classes, $cmd;
-        shift @to_try;
-        # throw away that top-level "Ticket" option
-    }
-
-    my @extreme_fallback_commands;
-
-    # App::SD::CLI::Command::List
-    # Prophet::CLI::Command::List
-    for my $main ($self->app_class, 'Prophet') {
-        push @extreme_fallback_commands, $main . "::CLI::Command::" . ucfirst(lc $commands[-1]);
-    }
+    my $command = join ' ', @{ $self->primary_commands };
 
-    # App::SD::CLI::Command::NotFound
-    # Prophet::CLI::Command::NotFound
-    for my $main ($self->app_class, 'Prophet') {
-        push @extreme_fallback_commands, $main . "::CLI::Command::NotFound";
-    }
+    # yeah this kind of sucks but there's no sane way to tell 
+    my $class;
+    my %dispatcher_args = (
+        got_command => sub { $class = shift },
+    );
 
-    my $class = first { $self->_try_to_load_cmd_class($_) }
-                @possible_classes, @extreme_fallback_commands;
+    Prophet::CLI::Dispatcher->run($command, $self, %dispatcher_args);
 
-    die "I don't know how to parse '" . join( " ", @{ $self->primary_commands } ) . "'. Are you sure that's a valid command?" unless ($class);
+    die "I don't know how to parse '$command'. Are you sure that's a valid command?" unless $class;
 
     my %constructor_args = (
         cli      => $self,

Modified: Prophet/branches/dispatcher/lib/Prophet/CLI/Dispatcher.pm
==============================================================================
--- Prophet/branches/dispatcher/lib/Prophet/CLI/Dispatcher.pm	(original)
+++ Prophet/branches/dispatcher/lib/Prophet/CLI/Dispatcher.pm	Tue Aug  5 19:31:31 2008
@@ -1,12 +1,21 @@
 package Prophet::CLI::Dispatcher;
 use strict;
 use warnings;
-use Path::Dispatcher -base;
+use Path::Dispatcher::Declarative -base;
 
-on qr{(.*)\s+(\d+)$} => sub {
+# "ticket display $ID" -> "ticket display --id=$ID"
+on qr{ (.*) \s+ ( \d+ | [A-Z0-9]{36} ) $ }x => sub {
     my $cli = shift;
-    $cli->set_arg(id => $1);
-    run($1, $args, @_);
+    $cli->set_arg(id => $2);
+    run($1, $cli, @_);
+};
+
+on qr{(.*)} => sub {
+    my $cli = shift;
+    my %args = @_;
+
+    my $class = join '::', split ' ', $1;
+    $args{got_command}->($class);
 };
 
 1;