[Bps-public-commit] r16582 - in Prophet/trunk: . lib/Prophet/CLI lib/Prophet/CLI/Command
sartak at bestpractical.com
sartak at bestpractical.com
Tue Oct 28 17:12:55 EDT 2008
Author: sartak
Date: Tue Oct 28 17:12:54 2008
New Revision: 16582
Added:
Prophet/trunk/lib/Prophet/CLI/Parameters.pm
Removed:
Prophet/trunk/lib/Prophet/CLI/Command/NotFound.pm
Modified:
Prophet/trunk/ (props changed)
Prophet/trunk/lib/Prophet/CLI.pm
Prophet/trunk/lib/Prophet/CLI/Dispatcher.pm
Log:
Merge class-dispatch branch to trunk
Modified: Prophet/trunk/lib/Prophet/CLI.pm
==============================================================================
--- Prophet/trunk/lib/Prophet/CLI.pm (original)
+++ Prophet/trunk/lib/Prophet/CLI.pm Tue Oct 28 17:12:54 2008
@@ -57,78 +57,14 @@
=cut
-=head2 dispatcher -> Class
+=head2 dispatcher_class -> Class
Returns the dispatcher used to dispatch command lines. You'll want to override
this in your subclass.
=cut
-sub dispatcher { "Prophet::CLI::Dispatcher" }
-
-=head2 _get_cmd_obj
-
-Attempts to determine a command object based on aliases and the currently
-set commands, arguments, and properties. Returns the class on success;
-dies on failure.
-
-This routine will use a C<CLI::Command::Shell> class if no arguments are
-specified.
-
-This routine will use a C<CLI::Command::NotFound> class as a last resort, so
-failure should occur rarely if ever.
-
-=cut
-
-sub _get_cmd_obj {
- my $self = shift;
-
- my $command = join ' ', @{ $self->context->primary_commands };
-
- # yeah this kind of sucks but there's no sane way to tell
- my $class;
- my %dispatcher_args = (
- cli => $self,
- context => $self->context,
- got_command => sub { $class = shift },
- dispatching_on => $self->context->primary_commands,
- );
-
- $self->dispatcher->run($command, %dispatcher_args);
- die "I don't know how to parse '$command'. Are you sure that's a valid command?\n" unless $class;
-
- my %constructor_args = (
- cli => $self,
- context => $self->context,
- commands => $self->context->primary_commands,
- type => $self->context->type,
- );
-
- # undef causes type constraint violations
- for my $key (keys %constructor_args) {
- delete $constructor_args{$key}
- if !defined($constructor_args{$key});
- }
-
- $constructor_args{uuid} = $self->context->uuid
- if $self->context->has_uuid;
-
- return $class->new(%constructor_args);
-}
-
-sub _try_to_load_cmd_class {
- my $self = shift;
- my $class = shift;
- Prophet::App->try_to_require($class);
- return $class if $class->isa('Prophet::CLI::Command');
-
- warn "Invalid class $class - not a subclass of Prophet::CLI::Command."
- if $class !~ /::$/ # don't warn about "Prophet::CLI::Command::" (which happens on "./bin/sd")
- && Prophet::App->already_required($class);
-
- return undef;
-}
-
+sub dispatcher_class { "Prophet::CLI::Dispatcher" }
=head2 run_one_command
@@ -150,11 +86,17 @@
# really, we shouldn't be doing this stuff from the command dispatcher
- $self->context(Prophet::CLIContext->new( app_handle => $self->app_handle));
- $self->context->setup_from_args(@args);
- if ( my $cmd_obj = $self->_get_cmd_obj() ) {
- $cmd_obj->run();
- }
+ $self->context(Prophet::CLIContext->new(app_handle => $self->app_handle));
+ $self->context->setup_from_args(@args);
+
+ my $dispatcher = $self->dispatcher_class->new(cli => $self);
+
+ my $command = join ' ', @{ $self->context->primary_commands };
+ my $dispatch = $dispatcher->dispatch($command);
+
+ die "The command you ran, '$command', could not be found. Perhaps running '$0 help' would help?\n" unless $dispatch->has_matches;
+
+ $dispatch->run($dispatcher);
}
=head2 invoke outhandle, ARGV_COMPATIBLE_ARRAY
Modified: Prophet/trunk/lib/Prophet/CLI/Dispatcher.pm
==============================================================================
--- Prophet/trunk/lib/Prophet/CLI/Dispatcher.pm (original)
+++ Prophet/trunk/lib/Prophet/CLI/Dispatcher.pm Tue Oct 28 17:12:54 2008
@@ -1,70 +1,91 @@
package Prophet::CLI::Dispatcher;
-use strict;
-use warnings;
use Path::Dispatcher::Declarative -base;
+use Moose;
+with 'Prophet::CLI::Parameters';
# "ticket display $ID" -> "ticket display --id=$ID"
-on qr{ (.*) \s+ ( \d+ | [A-Z0-9]{36} ) $ }x => sub {
- my %args = @_;
- $args{cli}->set_arg(id => $2);
- run($1, %args);
+on qr{^ (.*) \s+ ( \d+ | [A-Z0-9]{36} ) $ }x => sub {
+ my $self = shift;
+ $self->context->set_arg(id => $2);
+ run($1, $self, @_);
};
-on qr{^(\w+)} => sub {
- my %args = @_;
+on [ ['create', 'new'] ] => run_command("Create");
+on [ ['show', 'display'] ] => run_command("Show");
+on [ ['update', 'edit'] ] => run_command("Update");
+on [ ['delete', 'del', 'rm'] ] => run_command("Delete");
+on [ ['search', 'list', 'ls' ] ] => run_command("Search");
+
+on merge => run_command("Merge");
+on pull => run_command("Pull");
+on publish => run_command("Publish");
+on server => run_command("Server");
+on config => run_command("Config");
+on settings => run_command("Settings");
+on log => run_command("Log");
+on shell => run_command("Shell");
- my $cmd = __PACKAGE__->resolve_builtin_aliases($1);
+on export => sub {
+ my $self = shift;
+ $self->cli->handle->export_to(path => $self->context->arg('path'));
+};
- my @possible_classes = (
- ("Prophet::CLI::Command::" . ucfirst lc $cmd),
- "Prophet::CLI::Command::NotFound",
- );
+on push => sub {
+ my $self = shift;
- my $cli = $args{cli};
+ die "Please specify a --to.\n" if !$self->context->has_arg('to');
- for my $class (@possible_classes) {
- if ($cli->_try_to_load_cmd_class($class)) {
- return $args{got_command}->($class);
- }
- }
+ $self->context->set_arg(from => $self->cli->app_handle->default_replica_type.":file://".$self->cli->handle->fs_root);
+ $self->context->set_arg(db_uuid => $self->cli->handle->db_uuid);
+ run('merge', $self, @_);
};
-on qr{^\s*$} => sub {
- run(__PACKAGE__->default_command, @_);
+on history => sub {
+ my $self = shift;
+ $self->context->require_uuid;
+ my $record = $self->context->_load_record;
+ $self->record($record);
+ print $record->history_as_string;
};
-my %CMD_MAP = (
- ls => 'search',
- new => 'create',
- edit => 'update',
- rm => 'delete',
- del => 'delete',
- list => 'search',
- display => 'show',
-);
-
-sub resolve_builtin_aliases {
- my $self = shift;
- my @cmds = @_;
+sub run_command {
+ my $name = shift;
- if (my $replacement = $CMD_MAP{ lc $cmds[-1] }) {
- $cmds[-1] = $replacement;
- }
+ return sub {
+ my $self = shift;
- @cmds = map { ucfirst lc } @cmds;
+ my %constructor_args = (
+ cli => $self->cli,
+ context => $self->context,
+ commands => $self->context->primary_commands,
+ type => $self->context->type,
+ uuid => $self->context->uuid,
+ );
+
+ # undef causes type constraint violations
+ for my $key (keys %constructor_args) {
+ delete $constructor_args{$key}
+ if !defined($constructor_args{$key});
+ }
- return wantarray ? @cmds : $cmds[-1];
+ my @classes = $self->class_names($name);
+ for my $class (@classes) {
+ Prophet::App->try_to_require($class) or next;
+ $class->new(%constructor_args)->run;
+ last;
+ }
+ };
}
-=head2 default_command
-
-Returns the "default" command for use when no arguments were specified on the
-command line. In Prophet, it's "shell" but your subclass can change that.
-
-=cut
+sub class_names {
+ my $self = shift;
+ my $command = shift;
+ return "Prophet::CLI::Command::$command";
+}
-sub default_command { "shell" }
+__PACKAGE__->meta->make_immutable;
+no Moose;
1;
Added: Prophet/trunk/lib/Prophet/CLI/Parameters.pm
==============================================================================
--- (empty file)
+++ Prophet/trunk/lib/Prophet/CLI/Parameters.pm Tue Oct 28 17:12:54 2008
@@ -0,0 +1,24 @@
+#!/usr/bin/env perl
+package Prophet::CLI::Parameters;
+use Moose::Role;
+
+has cli => (
+ is => 'rw',
+ isa => 'Prophet::CLI',
+ required => 1,
+);
+
+has context => (
+ is => 'rw',
+ isa => 'Prophet::CLIContext',
+ lazy => 1,
+ default => sub {
+ my $self = shift;
+ $self->cli->context;
+ },
+);
+
+no Moose::Role;
+
+1;
+
More information about the Bps-public-commit
mailing list