File Coverage

blib/lib/App/CLI/Command.pm
Criterion Covered Total %
statement 38 87 43.7
branch 4 24 16.7
condition 2 13 15.4
subroutine 11 16 68.8
pod 4 9 44.4
total 59 149 39.6


line stmt bran cond sub pod time code
1             package App::CLI::Command;
2 1     1   17 use strict;
  1         9  
  1         17  
3 1     1   18 use warnings;
  1         9  
  1         87  
4 1     1   38 use Locale::Maketext::Simple;
  1         12  
  1         30  
5 1     1   17 use Carp ();
  1         9  
  1         9  
6              
7             =head1 NAME
8            
9             App::CLI::Command - Base class for App::CLI commands
10            
11             =head1 SYNOPSIS
12            
13             package MyApp;
14             use base 'App::CLI';
15            
16             package main;
17            
18             MyApp->dispatch;
19            
20             package MyApp::Help;
21             use base 'App::CLI::Command';
22            
23             sub options {
24             ('verbose' => 'verbose');
25             }
26            
27             sub run {
28             my ($self, $arg) = @_;
29             }
30            
31             =head1 DESCRIPTION
32            
33            
34             =cut
35              
36 1     1   14 use constant subcommands => ();
  1         11  
  1         17  
37 1     1   16 use constant options => ();
  1         8  
  1         13  
38              
39             sub new {
40 0     0 0 0     my $class = shift;
41 0         0     my $self = bless {}, $class;
42 0         0     %$self = @_;
43 0         0     return $self;
44             }
45              
46             sub command_options {
47 5     5 0 59     ( (map { $_ => $_ } $_[0]->subcommands),
  5         73  
48                   $_[0]->options );
49             }
50              
51             sub run_command {
52 5     5 0 42     my $self = shift;
53 5         57     $self->run(@_);
54             }
55              
56             sub subcommand {
57 5     5 0 43     my $self = shift;
58 5         56     my @cmd = $self->subcommands;
59 5 50 33     372     @cmd = values %{{$self->options}} if @cmd && $cmd[0] eq '*';
  0         0  
60 5         45     for (grep {$self->{$_}} @cmd) {
  5         68  
61 1     1   18 no strict 'refs';
  1         10  
  1         16  
62 1 50       10 if (exists ${ref($self).'::'}{$_.'::'}) {
  1         20  
63 1         35 bless ($self, (ref($self)."::$_"));
64 1         12 last;
65             }
66                 }
67             }
68              
69             sub app {
70 5     5 0 76     my $self = shift;
71 5 50       51     die Carp::longmess "not a ref" unless ref $self;
72 5 50       85     $self->{app} = shift if @_;
73 5   50     63     return ref ($self->{app}) || $self->{app};
74             }
75              
76             =head3 brief_usage ($file)
77            
78             Display an one-line brief usage of the command object. Optionally, a file
79             could be given to extract the usage from the POD.
80            
81             =cut
82              
83             sub brief_usage {
84 0     0 1       my ($self, $file) = @_;
85 0 0 0           open my ($podfh), '<', ($file || $self->filename) or return;
86 0               local $/=undef;
87 0               my $buf = <$podfh>;
88 0               my $base = $self->app;
89 0 0             if($buf =~ /^=head1\s+NAME\s*\Q$base\E::(\w+ - .+)$/m) {
90 0                   print " ",loc(lc($1)),"\n";
91                 } else {
92 0   0               my $cmd = $file ||$self->filename;
93 0                   $cmd =~ s/^(?:.*)\/(.*?).pm$/$1/;
94 0                   print " ", lc($cmd), " - ",loc("undocumented")."\n";
95                 }
96 0               close $podfh;
97             }
98              
99             =head3 usage ($want_detail)
100            
101             Display usage. If C<$want_detail> is true, the C<DESCRIPTION>
102             section is displayed as well.
103            
104             =cut
105              
106             sub usage {
107 0     0 1       my ($self, $want_detail) = @_;
108 0               my $fname = $self->filename;
109 0               my($cmd) = $fname =~ m{\W(\w+)\.pm$};
110 0               require Pod::Simple::Text;
111 0               my $parser = Pod::Simple::Text->new;
112 0               my $buf;
113 0               $parser->output_string(\$buf);
114 0               $parser->parse_file($fname);
115              
116 0               my $base = $self->app;
117 0               $buf =~ s/\Q$base\E::(\w+)/\l$1/g;
118 0               $buf =~ s/^AUTHORS.*//sm;
119 0 0             $buf =~ s/^DESCRIPTION.*//sm unless $want_detail;
120 0               print $self->loc_text($buf);
121             }
122              
123             =head3 loc_text $text
124            
125             Localizes the body of (formatted) text in $text, and returns the
126             localized version.
127            
128             =cut
129              
130             sub loc_text {
131 0     0 1       my $self = shift;
132 0               my $buf = shift;
133              
134 0               my $out = "";
135 0               foreach my $line (split(/\n\n+/, $buf, -1)) {
136 0 0                 if (my @lines = $line =~ /^( {4}\s+.+\s*)$/mg) {
    0          
    0          
137 0                       foreach my $chunk (@lines) {
138 0 0                         $chunk =~ /^(\s*)(.+?)( *)(: .+?)?(\s*)$/ or next;
139 0                           my $spaces = $3;
140 0   0                       my $loc = $1 . loc($2 . ($4||'')) . $5;
141 0 0                         $loc =~ s/: /$spaces: / if $spaces;
142 0                           $out .= $loc . "\n";
143                         }
144 0                       $out .= "\n";
145                     }
146                     elsif ($line =~ /^(\s+)(\w+ - .*)$/) {
147 0                       $out .= $1 . loc($2) . "\n\n";
148                     }
149                     elsif (length $line) {
150 0                       $out .= loc($line) . "\n\n";
151                     }
152                 }
153 0               return $out;
154             }
155              
156             =head3 filename
157            
158             Return the filename for the command module.
159            
160             =cut
161              
162             sub filename {
163 0     0 1       my $self = shift;
164 0               my $fname = ref($self);
165 0               $fname =~ s{::[a-z]+}{}; # subcommand
166 0               $fname =~ s{::}{/}g;
167 0               $INC{"$fname.pm"}
168             }
169              
170             =head1 TODO
171            
172             More documentation
173            
174             =head1 SEE ALSO
175            
176             L<App::CLI>
177            
178             =head1 AUTHORS
179            
180             Chia-liang Kao E<lt>clkao@clkao.orgE<gt>
181            
182             =head1 COPYRIGHT
183            
184             Copyright 2005-2006 by Chia-liang Kao E<lt>clkao@clkao.orgE<gt>.
185            
186             This program is free software; you can redistribute it and/or modify it
187             under the same terms as Perl itself.
188            
189             See L<http://www.perl.com/perl/misc/Artistic.html>
190            
191             =cut
192              
193             1;
194