File Coverage

blib/lib/Catmandu/Cmd.pm
Criterion Covered Total %
statement 54 72 75.0
branch 9 16 56.2
condition 1 2 50.0
subroutine 13 16 81.2
pod 7 7 100.0
total 84 113 74.3


line stmt bran cond sub pod time code
1              
2             use Catmandu::Sane;
3 14     14   109557  
  14         30  
  14         85  
4             our $VERSION = '1.2019';
5              
6             use parent qw(App::Cmd::Command);
7 14     14   88 use Catmandu::Util qw(is_array_ref pod_section);
  14         34  
  14         87  
8 14     14   34629 use Catmandu::Fix;
  14         26  
  14         762  
9 14     14   7468 use Encode qw(decode);
  14         829  
  14         567  
10 14     14   8173 use Log::Any ();
  14         178810  
  14         1219  
11 14     14   856 use namespace::clean;
  14         91  
  14         321  
12 14     14   78  
  14         23  
  14         100  
13             Log::Any->get_logger(category => ref($_[0]));
14             }
15 0     0 1 0  
16             # Internal required by App::Cmd;
17             my ($self, $app, @args) = @_;
18              
19             # not always available
20 39     39 1 45787 eval {
21             require I18N::Langinfo;
22             I18N::Langinfo->import(qw(langinfo CODESET));
23 39         79 my $codeset = langinfo(CODESET());
24 39         6423 @args = map {decode $codeset, $_} @args;
25 39         11401 };
26 39         239 $self->SUPER::prepare($app, @args);
27 39         105 }
  134         7021  
28              
29 39         4211 # Internal required by App::Cmd
30             my ($class, $cli) = @_;
31             (
32             ['help|h|?', "print this usage screen"],
33             $cli->global_opt_spec, $class->command_opt_spec($cli),
34 39     39 1 1382 );
35             }
36 39         193  
37             # Internal required by App::Cmd
38             my ($self, $opts, $args) = @_;
39              
40             if ($opts->{version}) {
41             print $Catmandu::VERSION;
42             exit;
43 34     34 1 637 }
44             if ($opts->{help}) {
45 34 50       231 print $self->usage->text;
46 0         0 exit;
47 0         0 }
48              
49 34 50       109 $self->command($opts, $args);
50 0         0 }
51 0         0  
52             # show examples, if available in POD
53             my $class = ref shift;
54 34         169  
55             my $s = pod_section($class, "name");
56             $s =~ s/.*\s+-\s+//;
57             $s = ucfirst($s);
58             $s .= "\n";
59 0     0 1 0  
60             for (pod_section($class, "examples")) {
61 0         0 $s .= "Examples:\n\n$_";
62 0         0 }
63 0         0  
64 0         0 "$s\nOptions:";
65             }
66 0         0  
67 0         0 # These should be implemented by the Catmandu::Cmd's
68              
69             # helpers
70 0         0 my ($self, $args, %opts) = @_;
71              
72             $opts{separator} //= 'to';
73              
74       5 1   my $a = my $lft_args = [];
75       0 1   my $o = my $lft_opts = {};
76             my $rgt_args = [];
77             my $rgt_opts = {};
78              
79 32     32   118 for (my $i = 0; $i < @$args; $i++) {
80             my $arg = $args->[$i];
81 32   50     240 if ($arg eq $opts{separator}) {
82             $a = $rgt_args;
83 32         68 $o = $rgt_opts;
84 32         73 }
85 32         51 elsif ($arg =~ s/^-+//) {
86 32         49 $arg =~ s/-/_/g;
87             if (exists $o->{$arg}) {
88 32         161 if (is_array_ref($o->{$arg})) {
89 81         122 push @{$o->{$arg}}, $args->[++$i];
90 81 100       295 }
    100          
91 22         50 else {
92 22         49 $o->{$arg} = [$o->{$arg}, $args->[++$i]];
93             }
94             }
95 15         40 else {
96 15 50       38 $o->{$arg} = $args->[++$i];
97 0 0       0 }
98 0         0 }
  0         0  
99             else {
100             push @$a, $arg;
101 0         0 }
102             }
103              
104             return $lft_args, $lft_opts, $rgt_args, $rgt_opts;
105 15         61 }
106              
107             my ($self, $opts) = @_;
108             if ($opts->var) {
109 44         147 return Catmandu::Fix->new(
110             preprocess => 1,
111             fixes => $opts->fix,
112             variables => $opts->var,
113 32         142 );
114             }
115             Catmandu::Fix->new(
116             preprocess => $opts->preprocess ? 1 : 0,
117 9     9   29 fixes => $opts->fix,
118 9 50       33 );
119 0         0 }
120              
121             1;
122              
123              
124             =pod
125              
126 9 50       92 =head1 NAME
127              
128             Catmandu::Cmd - A base class for extending the Catmandu command line
129              
130             =head1 SYNOPSIS
131              
132             # to create a command:
133             $ catmandu hello_world
134              
135             # you need a package:
136             package Catmandu::Cmd::hello_world;
137             use parent 'Catmandu::Cmd';
138              
139             sub command_opt_spec {
140             (
141             [ "greeting|g=s", "provide a greeting text" ],
142             );
143             }
144              
145             sub description {
146             <<EOS;
147             examples:
148              
149             catmandu hello_world --greeting "Hoi"
150              
151             options:
152             EOS
153             }
154              
155             sub command {
156             my ($self, $opts, $args) = @_;
157             my $greeting = $opts->greeting // 'Hello';
158             print "$greeting, World!\n"
159             }
160              
161             =head1 NAME
162              
163             Catmandu::Cmd::hello_world - prints a funny line
164              
165             =cut
166              
167              
168              
169             =head1 DESCRIPTION
170              
171             Catmandu:Cmd is a base class to extend the commands that can be provided for
172             the 'catmandu' command line tools. New catmandu commands should be defined in
173             the Catmandu::Cmd namespace and extend Catmandu::Cmd.
174              
175             Every command needs to implement 4 things:
176              
177             * command_opt_spec - which should return an array of command options with documentation
178             * description - a long description of the command
179             * command - the body which is executed
180             * head1 NAME - a short description of the command
181              
182             =head1 METHODS
183              
184             =head2 log()
185              
186             Access to the logger
187              
188             =head2 command_opt_spec()
189              
190             This method should be overridden to provide option specifications. (This is list of arguments passed to describe_options from Getopt::Long::Descriptive, after the first.)
191              
192             If not overridden, it returns an empty list.
193              
194             =head2 description()
195              
196             This method should return a string containing the long documentation of the command
197              
198             =head2 command()
199              
200             This method does whatever it is the command should do! It is passed a hash reference of the parsed command-line options and an array reference of left over arguments.
201              
202             =head1 DOCUMENTATION
203              
204             At least provide for every command a NAME documentation
205              
206             =head1 SEE ALSO
207              
208             L<Catmandu::Cmd::config> , L<Catmandu::Cmd::convert> , L<Catmandu::Cmd::count> ,
209             L<Catmandu::Cmd::data> , L<Catmandu::Cmd::delete> , L<Catmandu::Cmd::export>,
210             L<Catmandu::Cmd::import> , L<Catmandu::Cmd::move> , L<Catmandu::Cmd::run>
211              
212             =cut