File Coverage

blib/lib/Prophet/CLI/Dispatcher.pm
Criterion Covered Total %
statement 1 3 33.3
branch n/a
condition n/a
subroutine 1 1 100.0
pod n/a
total 2 4 50.0


line stmt bran cond sub pod time code
1             package Prophet::CLI::Dispatcher;
2 39     39   40451 use Path::Dispatcher::Declarative -base;
  0            
  0            
3             use Any::Moose;
4             extends 'Path::Dispatcher::Declarative', any_moose('Object');
5              
6             require Prophet::CLIContext;
7              
8             with 'Prophet::CLI::Parameters';
9              
10             our @PREFIXES = qw(Prophet::CLI::Command);
11             sub add_command_prefix { unshift @PREFIXES, @_ }
12              
13             on '' => sub {
14             my $self = shift;
15             if ($self->context->has_arg('version')) { run_command("Version")->($self) }
16             elsif( $self->context->has_arg('help') ){ run_command("Help")->($self) }
17             else { next_rule }
18             };
19              
20             # publish foo@bar.com:www/baz => publish --to foo@bar.com:www/baz
21             on qr{^(publish|push) (\S+)$} => sub {
22             my $self = shift;
23             $self->context->set_arg(to => $2);
24             run($1, $self);
25             };
26              
27             # clone http://fsck.com/~jesse/sd-bugs => clone --from http://fsck.com/~jesse/sd-bugs
28             on qr{^(clone|pull) (\S+)$} => sub {
29             my $self = shift;
30             $self->context->set_arg(from => $2);
31             run($1, $self);
32             };
33              
34             # log range => log --range range
35             on qr{log\s+([0-9LATEST.~]+)} => sub {
36             my $self = shift;
37             $self->context->set_arg(range => $1);
38             run('log', $self);
39             };
40              
41             under settings => sub {
42             my $self = shift;
43             on edit => sub {
44             my $self = shift;
45             $self->context->set_arg( 'edit' );
46             run('settings', $self);
47             };
48             on show => sub {
49             my $self = shift;
50             $self->context->set_arg( 'show' );
51             run('settings', $self);
52             };
53             on set => sub {
54             my $self = shift;
55             $self->context->set_arg( 'set' );
56             run('settings', $self);
57             };
58             };
59              
60             on [ qr/^(update|edit|show|display|delete|del|rm|history)$/,
61             qr/^$Prophet::CLIContext::ID_REGEX$/i ] => sub {
62             my $self = shift;
63             $self->context->set_id_from_primary_commands;
64             run($1, $self, @_);
65             };
66              
67             on [ [ 'update', 'edit' ] ] => run_command("Update");
68             on [ [ 'show', 'display' ] ] => run_command("Show");
69             on [ [ 'delete', 'del', 'rm' ] ] => run_command("Delete");
70             on history => run_command("History");
71              
72             on [ ['create', 'new'] ] => run_command("Create");
73             on [ ['search', 'list', 'ls' ] ] => run_command("Search");
74             on [ ['aliases', 'alias'] ] => run_command('Aliases');
75              
76             on version => run_command("Version");
77             on init => run_command("Init");
78             on clone => run_command("Clone");
79             on merge => run_command("Merge");
80             on mirror => run_command('Mirror');
81             on pull => run_command("Pull");
82             on publish => run_command("Publish");
83             on server => run_command("Server");
84             on config => run_command("Config");
85             on settings => run_command("Settings");
86             on log => run_command("Log");
87             on shell => run_command("Shell");
88             on export => run_command('Export');
89             on info => run_command('Info');
90             on push => run_command('Push');
91              
92             on qr/^(alias(?:es)?|config)?\s+(.*)/ => sub {
93             my ( $self ) = @_;
94             my $cmd = $1;
95             my $arg = $2;
96              
97             my $class = $cmd =~ /^alias/ ? 'Aliases' : 'Config';
98              
99             # Load command class so we can run
100             # its arg-parsing sub (the syntax is complex)
101             my @classes = $self->class_names($class);
102             for my $class (@classes) {
103             Prophet::App->try_to_require($class) or next;
104             my $cmd_obj = $class->new(
105             context => $self->context,
106             cli => $self->cli,
107             );
108             $cmd_obj->parse_cli_arg($cmd, $arg);
109             return run( $cmd, $self, @_ );
110             }
111              
112             # Something is wrong with the app layout...
113             die "Could not find '$class' command class";
114             };
115              
116             sub run_command {
117             my $name = shift;
118             return sub {
119             my $self = shift;
120             my %constructor_args = (
121             cli => $self->cli,
122             context => $self->context,
123             commands => $self->context->primary_commands,
124             type => $self->context->type,
125             uuid => $self->context->uuid,
126             );
127              
128             # undef causes type constraint violations
129             for my $key (keys %constructor_args) {
130             delete $constructor_args{$key}
131             if !defined($constructor_args{$key});
132             }
133              
134             my @classes = $self->class_names($name);
135             for my $class (@classes) {
136             Prophet::App->try_to_require($class) or next;
137             $class->new(%constructor_args)->run;
138             return;
139             }
140              
141             die "Invalid command command class suffix '$name'";
142             };
143             }
144              
145             sub class_names {
146             my $self = shift;
147             my $command = shift;
148             return map { $_."::".$command } @PREFIXES;
149              
150             }
151              
152             __PACKAGE__->meta->make_immutable;
153             no Any::Moose;
154              
155             1;
156