File Coverage

lib/CLI/Dispatch.pm
Criterion Covered Total %
statement 95 104 91.3
branch 28 36 77.7
condition 6 10 60.0
subroutine 19 21 90.4
pod 9 9 100.0
total 157 180 87.2


line stmt bran cond sub pod time code
1             package CLI::Dispatch;
2              
3 11     11   180963 use strict;
  11         20  
  11         268  
4 11     11   38 use warnings;
  11         15  
  11         212  
5 11     11   36 use Carp;
  11         13  
  11         472  
6 11     11   6903 use Getopt::Long ();
  11         82507  
  11         323  
7 11     11   4383 use String::CamelCase;
  11         3893  
  11         469  
8 11     11   3282 use Try::Tiny;
  11         7549  
  11         8274  
9              
10             our $VERSION = '0.21';
11              
12             # you may want to override these three methods.
13              
14 95     95 1 271 sub options {qw( help|h|? verbose|v debug logfilter=s )}
15              
16 9     9 1 36 sub default_command { 'help' }
17              
18             sub get_command {
19 81     81 1 98 my $self = shift;
20              
21 81   66     249 my $command = shift @ARGV || $self->default_command;
22 81         179 return $self->convert_command($command);
23             }
24              
25             sub convert_command {
26 108     108 1 163 my ($self, $command) = @_;
27              
28 108         267 $command = String::CamelCase::camelize( $command );
29 108         1211 $command =~ tr/a-zA-Z0-9_//cd;
30 108         176 return $command;
31             }
32              
33             # you usually don't need to care below.
34              
35             sub new {
36 95     95 1 183 my ($class, %opts) = @_;
37 95         207 bless \%opts, $class;
38             }
39              
40             sub get_options {
41 187     187 1 322 my ($self, @specs) = @_;
42              
43 187         878 my $parser = Getopt::Long::Parser->new(
44             config => [qw( bundling ignore_case pass_through )]
45             );
46              
47 187         11998 $parser->getoptions( \my %hash => @specs );
48              
49 187         38381 return %hash;
50             }
51              
52             sub load_command {
53 86     86 1 160 my ($self, $namespaces, $help) = @_;
54              
55 86         185 my $command = $self->get_command;
56              
57 86 100       257 if ( $help ) {
58 8         19 unshift @ARGV, $command;
59 8         12 $command = 'Help';
60             }
61              
62 86         172 my $instance = $self->_load_command($namespaces, $command);
63 83 100       334 return $instance if $instance;
64              
65             # fallback to help (maybe the command is just a pod)
66 6         16 unshift @ARGV, $command;
67 6         18 $instance = $self->_load_command($namespaces, 'Help');
68 6 50       25 return $instance if $instance;
69              
70             # this shouldn't happen
71 0         0 print STDERR "Help command is missing or broken.\n";
72 0         0 print STDERR "Prerequisite modules may not be installed.\n";
73 0         0 print STDERR "Please check your installation.\n";
74 0         0 exit;
75             }
76              
77             sub _load_command {
78 92     92   117 my ($self, $namespaces, $command) = @_;
79              
80 92         141 foreach my $namespace (@$namespaces) {
81 96         165 my $package = $namespace.'::'.$command;
82 96 100       867 return $package->new if $package->can('new');
83              
84 49         44 my $error;
85 49 100   49   3612 try { eval "require $package" or die }
86 49   50 20   257 catch { $error = $_ || 'Obscure error' };
  20         601  
87 49 100       4200 return $package->new unless $error;
88              
89 20         43 my $file = _package_file($package);
90 20 100       394 next if $error =~ /Can't locate $file/;
91 3         384 croak $error;
92             }
93              
94 13 100       39 if ($command eq 'Help') {
95 7         1035 require CLI::Dispatch::Help;
96 7         64 return CLI::Dispatch::Help->new;
97             }
98 6         11 return;
99             }
100              
101             sub _package_file {
102 20     20   38 my $package = shift;
103              
104 20         73 $package =~ s{::}{/}g;
105 20         33 $package .= '\.(?:pm|pod)';
106 20         31 $package;
107             }
108              
109             sub run {
110 86     86 1 126777 my ($self, @namespaces) = @_;
111              
112 86         107 my $class;
113 86 100       241 unless ($class = ref $self) {
114 78         108 $class = $self;
115 78         190 $self = $self->new;
116             }
117              
118 86 100       180 if (!grep { $_ ne $class } @namespaces) {
  69         186  
119 29         44 push @namespaces, $class;
120             }
121              
122 86         203 my %global = $self->get_options( $self->options );
123 86         323 my $command = $self->load_command( \@namespaces, $global{help} );
124 83         374 my %local = $self->get_options( $command->options );
125              
126 83         552 $command->set_options( %$self, %global, %local, _namespaces => \@namespaces );
127              
128 82 100 100     529 if ( $command->isa('CLI::Dispatch::Help') and @ARGV ) {
129 27         76 $ARGV[0] = $self->convert_command($ARGV[0]);
130             }
131              
132 82 100       334 $command->check if $command->can('check');
133              
134 79         248 $command->run(@ARGV);
135             }
136              
137             sub run_directly {
138 9     9 1 11 my ($self, $package) = @_;
139              
140 9 50       54 unless ($package->can('new')) {
141 0         0 my $error;
142 0 0   0   0 try { eval "require $package" or die }
143 0   0 0   0 catch { $error = $_ || 'Obscure error' };
  0         0  
144 0 0       0 croak $error if $error;
145             }
146              
147 9         12 my $class;
148 9 50       28 unless ($class = ref $self) {
149 9         11 $class = $self;
150 9         16 $self = $self->new;
151             }
152              
153 9         21 my %global = $self->get_options( $self->options );
154 9         29 my $command = $package->new;
155 9 100       17 if ($global{help}) {
156 1         376 require CLI::Dispatch::Help;
157 1         12 $command = CLI::Dispatch::Help->new;
158 1         5 unshift @ARGV, "+$package";
159             }
160 9         28 my %local = $self->get_options( $command->options );
161              
162 9         41 $command->set_options( %global, %local );
163              
164 9 50       33 $command->check if $command->can('check');
165              
166 9         24 $command->run(@ARGV);
167             }
168              
169             1;
170              
171             __END__