File Coverage

blib/lib/Data/Object/Cli.pm
Criterion Covered Total %
statement 173 201 86.0
branch 19 44 43.1
condition 10 36 27.7
subroutine 34 35 97.1
pod 10 16 62.5
total 246 332 74.1


line stmt bran cond sub pod time code
1             package Data::Object::Cli;
2              
3 1     1   44289 use 5.014;
  1         4  
4              
5 1     1   8 use strict;
  1         2  
  1         38  
6 1     1   6 use warnings;
  1         3  
  1         43  
7              
8 1     1   7 use feature 'say';
  1         2  
  1         142  
9              
10 1     1   8 use registry 'Data::Object::Types';
  1         3  
  1         8  
11 1     1   244467 use routines;
  1         3  
  1         7  
12              
13 1     1   2370 use Data::Object::Class;
  1         261  
  1         15  
14 1     1   907 use Data::Object::ClassHas;
  1         10492  
  1         11  
15 1     1   623 use Data::Object::Space;
  1         12879  
  1         41  
16              
17 1     1   1112 use Data::Object::Args;
  1         31537  
  1         38  
18 1     1   1159 use Data::Object::Data;
  1         6369  
  1         32  
19 1     1   1060 use Data::Object::Opts;
  1         28375  
  1         44  
20 1     1   1143 use Data::Object::Vars;
  1         13390  
  1         163  
21              
22             our $VERSION = '2.03'; # VERSION
23              
24             our $DEFAULT_SPACE = 15;
25              
26             # ATTRIBUTES
27              
28             has 'args' => (
29             is => 'ro',
30             isa => 'ArgsObject',
31             new => 1,
32             );
33              
34 6     6 0 3996 fun new_args($self) {
  6         15  
35 6         39 Data::Object::Args->new($self->_args_spec)
36             }
37              
38             has 'data' => (
39             is => 'ro',
40             isa => 'DataObject',
41             new => 1,
42             );
43              
44 4     4 0 3776 fun new_data($self) {
  4         9  
45 4         93 Data::Object::Data->new(from => ref $self)
46             }
47              
48             has 'opts' => (
49             is => 'ro',
50             isa => 'OptsObject',
51             new => 1,
52             );
53              
54 5     5 0 3376 fun new_opts($self) {
  5         11  
55 5         30 Data::Object::Opts->new($self->_opts_spec)
56             }
57              
58             has 'vars' => (
59             is => 'ro',
60             isa => 'VarsObject',
61             new => 1,
62             );
63              
64 4     4 0 2084 fun new_vars($self) {
  4         9  
65 4         80 Data::Object::Vars->new
66             }
67              
68             # METHODS
69              
70             sub auto {
71             {}
72 0     0 1 0 }
73              
74             sub main {
75 1     1 1 923 my ($self) = shift;
76              
77 1         2 my $result;
78              
79 1         8 my $auto = $self->handle('auto');
80 1   33     22 my $command = $self->args->command || $ARGV[0];
81 1 50 33     183 my $goto = $auto->{$command} if $auto && $command;
82              
83 1 50       4 if ($goto) {
84 1         4 $result = $self->handle($goto);
85             }
86             else {
87 0         0 say $self->help;
88             }
89              
90 1         15 return $result;
91             }
92              
93             sub subs {
94             {}
95 8     8 1 17 }
96              
97 4     4 1 38 method exit($code, $handler, @args) {
  4         13  
  4         8  
98              
99 4 50       15 $self->handle($handler, @args) if $handler;
100              
101 4   100     44 $code ||= 0;
102              
103 4         17 exit $code;
104             }
105              
106 1     1 1 9 method fail($handler, @args) {
  1         4  
  1         2  
107              
108 1         6 return $self->exit(1, $handler, @args);
109             }
110              
111 4     4 1 27 method handle($method, %args) {
  4         13  
  4         18  
112              
113 4         9 my %meta;
114              
115 4         104 $meta{args} = $self->args;
116 4         1330 $meta{data} = $self->data;
117 4         946 $meta{opts} = $self->opts;
118 4         2023 $meta{vars} = $self->vars;
119              
120 4         1322 return $self->$method(%meta, %args);
121             }
122              
123 9     9 1 7141 method help() {
  9         18  
124              
125 9         91 my $space = Data::Object::Space->new(ref $self);
126              
127 9         189 my $name = $self->name =~ s/\{(\w+)\}/$1/gr;
128 9         92 my $info = $self->info;
129 9         47 my $subs = $self->_help_subs;
130 9         47 my $opts = $self->_help_opts;
131              
132 9         16 my $data;
133              
134 9 50       40 if ($data = $space->data) {
135 0 0 0     0 if ($name && $data =~ /\{name\}/) {
136 0         0 $data =~ s/\{name\}/$name/g;
137             }
138              
139 0 0 0     0 if ($info && $data =~ /\{info\}/) {
140 0         0 $data =~ s/\{info\}/$info/g;
141             }
142              
143 0 0 0     0 if ($subs && $data =~ /\{subs\}/) {
144 0         0 $data =~ s/\{subs\}/$subs/g;
145             }
146              
147 0 0 0     0 if ($opts && $data =~ /\{opts\}/) {
148 0         0 $data =~ s/\{opts\}/$opts/g;
149             }
150              
151 0 0 0     0 if ($subs && $data =~ /\{commands\}/) {
152 0         0 $data =~ s/\{commands\}/$subs/g;
153             }
154              
155 0 0 0     0 if ($opts && $data =~ /\{options\}/) {
156 0         0 $data =~ s/\{options\}/$opts/g;
157             }
158              
159 0         0 $data =~ s/^\n//;
160             }
161             else {
162 9         346 my @help;
163              
164 9         27 push @help, "usage: $name", "";
165 9 100       33 push @help, $info, "" if $info;
166 9 100       34 push @help, $subs, "" if $subs;
167 9 50       24 push @help, $opts, "" if $opts;
168              
169 9         30 $data = join "\n", @help;
170             }
171              
172 9         101 return $data;
173             }
174              
175 11     11 0 2228 method info() {
  11         20  
176              
177 11         23 my $class = ref $self;
178              
179 1     1   1885 do { no strict 'refs'; ${"${class}::info"} };
  1         2  
  1         58  
  11         16  
  11         19  
  11         56  
180             }
181              
182 11     11 0 862 method name() {
  11         23  
183              
184 11         23 my $class = ref $self;
185              
186 1 100   1   87 do { no strict 'refs'; ${"${class}::name"} } || $0;
  1         3  
  1         67  
  11         17  
  11         14  
  11         87  
187             }
188              
189 1     1 1 14 method okay($handler, @args) {
  1         3  
  1         2  
190              
191 1         17 return $self->exit(0, $handler, @args);
192             }
193              
194 18     18 1 220804 method run($class: @args) {
  18         52  
  18         30  
195              
196 18         452 my $self = $class->new(@args);
197              
198 18 50       3608 return $self->handle('main') unless caller(1);
199              
200 18         226 return $self;
201             }
202              
203 13     13 1 27 method spec() {
  13         19  
204             {}
205 13         36 }
206              
207 6     6   15 method _args_spec() {
  6         9  
208              
209 6         21 my $args_spec = {named => {}};
210              
211 6         59 my $name = $self->name;
212 6         57 my @args = split /\s+/, $name;
213              
214 6         11 shift @args;
215              
216 6 100       75 return $args_spec if !@args;
217              
218 3         13 for (my $i=0; $i < @args; $i++) {
219 4 100       33 if (my ($token) = $args[$i] =~ /\{(\w+)\}/) {
220 3         19 $args_spec->{named}{$token} = "$i";
221             }
222             }
223              
224 3         69 return $args_spec;
225             }
226              
227 9     9   19 method _help_opts() {
  9         15  
228              
229 9         39 my $spec = $self->spec;
230 9         37 my $size = $DEFAULT_SPACE;
231              
232 9         15 my @opts;
233              
234 9         25 for my $name (keys %$spec) {
235 0         0 my %seen;
236              
237 0         0 my $data = $spec->{$name};
238              
239 0         0 my $args = $data->{args};
240 0         0 my $desc = $data->{desc};
241 0   0     0 my $flag = $data->{flag} || $name;
242 0         0 my $type = $data->{type};
243              
244             my $text = join ',',
245 0 0       0 map {length > 1 ? "--$_" : "-$_"}
246 0         0 grep !$seen{$_}++, sort $name, split /\|/, $flag;
247              
248 0 0       0 $text = "${text}, +1" if defined $args;
249 0 0       0 $size = length $text if length $text > $size;
250              
251 0         0 push @opts, [$text, "[$type] $desc"];
252             }
253              
254 9         20 @opts = sort {$a->[0] cmp $b->[0]} @opts;
  0         0  
255              
256 9         28 return join "\n", map {sprintf " %-*s %s", $size, @$_} @opts;
  0         0  
257             }
258              
259 9     9   30 method _help_subs() {
  9         15  
260              
261 9         56 my $spec = $self->subs;
262 9         24 my $size = $DEFAULT_SPACE;
263              
264 9         15 my @opts;
265              
266 9         53 for my $name (sort keys %$spec) {
267 2         6 my $text = $spec->{$name};
268              
269 2 50       7 $size = length $name if length $name > $size;
270              
271 2         7 push @opts, [$name, $text];
272             }
273              
274 9         36 return join "\n", map {sprintf " %-*s %s", $size, @$_} @opts;
  2         15  
275             }
276              
277 5     5   12 method _opts_spec() {
  5         10  
278              
279 5         21 my $opts_spec = {spec => []};
280              
281 5         46 my $spec = $self->spec;
282              
283 5         31 for my $name (keys %$spec) {
284 5         9 my %seen;
285              
286 5         9 my $data = $spec->{$name};
287              
288 5         9 my $args = $data->{args};
289 5   66     14 my $flag = $data->{flag} || $name;
290 5   100     15 my $type = $data->{type} || 'flag';
291              
292 5         16 my $code = {
293             float => 'f',
294             integer => 'i',
295             number => 'o',
296             string => 's',
297             };
298              
299 5         10 $code = $code->{$type};
300              
301 5         42 my @flags = grep !$seen{$_}++, reverse sort $name, split /\|/, $flag;
302              
303 5         12 $opts_spec->{named}{$name} = $flags[0];
304              
305 5         12 $flag = join '|', @flags;
306              
307 5 100 100     6 push @{$opts_spec->{spec}}, sprintf '%s%s%s', $flag, ($code ? "=$code" : ''), $args || '';
  5         36  
308             }
309              
310 5         112 return $opts_spec;
311             }
312              
313             1;
314              
315             =encoding utf8
316              
317             =head1 NAME
318              
319             Data::Object::Cli - Simple CLIs
320              
321             =cut
322              
323             =head1 ABSTRACT
324              
325             Command-line Interface Abstraction for Perl 5
326              
327             =cut
328              
329             =head1 SYNOPSIS
330              
331             package Command;
332              
333             use parent 'Data::Object::Cli';
334              
335             sub main {
336             my ($self) = @_;
337              
338             return $self->help;
339             }
340              
341             my $command = run Command;
342              
343             =cut
344              
345             =head1 DESCRIPTION
346              
347             This package provides an abstract base class for defining command-line
348             interface classes, which can be run as scripts or passed as objects in a more
349             complex system.
350              
351             =cut
352              
353             =head1 LIBRARIES
354              
355             This package uses type constraints from:
356              
357             L<Data::Object::Types>
358              
359             =cut
360              
361             =head1 ATTRIBUTES
362              
363             This package has the following attributes:
364              
365             =cut
366              
367             =head2 args
368              
369             args(ArgsObject)
370              
371             This attribute is read-only, accepts C<(ArgsObject)> values, and is optional.
372              
373             =cut
374              
375             =head2 data
376              
377             data(DataObject)
378              
379             This attribute is read-only, accepts C<(DataObject)> values, and is optional.
380              
381             =cut
382              
383             =head2 opts
384              
385             opts(OptsObject)
386              
387             This attribute is read-only, accepts C<(OptsObject)> values, and is optional.
388              
389             =cut
390              
391             =head2 vars
392              
393             vars(VarsObject)
394              
395             This attribute is read-only, accepts C<(VarsObject)> values, and is optional.
396              
397             =cut
398              
399             =head1 METHODS
400              
401             This package implements the following methods:
402              
403             =cut
404              
405             =head2 auto
406              
407             auto(Any %args) : HashRef
408              
409             The auto method is expected to be overridden by the subclass and should return
410             a hashref where the keys represent a subcommand at C<$ARGV[0]> and the value
411             represents the subroutine to be dispatched to using the C<handle> method. To
412             enable this functionality, the command name be declare a "command" token.
413              
414             =over 4
415              
416             =item auto example #1
417              
418             package Todo;
419              
420             use parent 'Data::Object::Cli';
421              
422             our $name = 'todo <{command}>';
423              
424             sub auto {
425             {
426             init => '_handle_init'
427             }
428             }
429              
430             sub _handle_init {
431             1234567890
432             }
433              
434             my $todo = run Todo;
435              
436             =back
437              
438             =cut
439              
440             =head2 exit
441              
442             exit(Int $code, Maybe[Str] $name, Any %args) : Any
443              
444             The exit method exits the program using the exit code provided. The exit code
445             defaults to C<0>. Optionally, you can call a handler before exiting by
446             providing a method name with arguments. The handler will be called using the
447             C<handle> method so the arguments should be key/value pairs.
448              
449             =over 4
450              
451             =item exit example #1
452              
453             # given: synopsis
454              
455             $command->exit(0);
456              
457             # $command->exit($code, $method_name, %args);
458             # $command->exit($code, $method_name);
459             # $command->exit($code);
460              
461             =back
462              
463             =over 4
464              
465             =item exit example #2
466              
467             # given: synopsis
468              
469             $command->exit(1);
470              
471             # $command->exit($code, $method_name, %args);
472             # $command->exit($code, $method_name);
473             # $command->exit($code);
474              
475             =back
476              
477             =cut
478              
479             =head2 fail
480              
481             fail(Maybe[Str] $name, Any %args) : Any
482              
483             The fail method exits the program with a C<1> exit code. Optionally, you can
484             call a handler before exiting by providing a method name with arguments. The
485             handler will be called using the C<handle> method so the arguments should be
486             key/value pairs.
487              
488             =over 4
489              
490             =item fail example #1
491              
492             # given: synopsis
493              
494             $command->fail;
495              
496             # $command->fail($method_name, %args);
497             # $command->fail($method_name);
498              
499             =back
500              
501             =cut
502              
503             =head2 handle
504              
505             handle(Str $name, Any %args) : Any
506              
507             The handle method dispatches to the method whose name is provided as the first
508             argument. The forwarded method will receive arguments as key/value pairs. This
509             method injects the C<args>, C<data>, C<vars>, and C<opts> attributes as
510             arguments for convenience of use in the forwarded method. Any additional
511             arguments should be passed as key/value pairs.
512              
513             =over 4
514              
515             =item handle example #1
516              
517             # given: synopsis
518              
519             $command->handle('main');
520              
521             # $command->handle($method_name, %args);
522             # $command->handle($method_name);
523              
524             =back
525              
526             =cut
527              
528             =head2 help
529              
530             help() : Str
531              
532             The help method returns the help text documented in POD if available.
533              
534             =over 4
535              
536             =item help example #1
537              
538             package Todolist;
539              
540             use parent 'Data::Object::Cli';
541              
542             my $todolist = run Todolist;
543              
544             # $todolist->help
545              
546             =back
547              
548             =over 4
549              
550             =item help example #2
551              
552             package Todolist;
553              
554             use parent 'Data::Object::Cli';
555              
556             our $name = 'todolist';
557              
558             my $todolist = run Todolist;
559              
560             # $todolist->help
561              
562             =back
563              
564             =over 4
565              
566             =item help example #3
567              
568             package Todolist;
569              
570             use parent 'Data::Object::Cli';
571              
572             sub name {
573             'todolist'
574             }
575              
576             my $todolist = run Todolist;
577              
578             # $todolist->help
579              
580             =back
581              
582             =over 4
583              
584             =item help example #4
585              
586             package Todolist;
587              
588             use parent 'Data::Object::Cli';
589              
590             our $name = 'todolist';
591             our $info = 'manage your todo list';
592              
593             my $todolist = run Todolist;
594              
595             # $todolist->help
596              
597             =back
598              
599             =over 4
600              
601             =item help example #5
602              
603             package Todolist;
604              
605             use parent 'Data::Object::Cli';
606              
607             sub name {
608             'todolist'
609             }
610              
611             sub info {
612             'manage your todo list'
613             }
614              
615             my $todolist = run Todolist;
616              
617             # $todolist->help
618              
619             =back
620              
621             =over 4
622              
623             =item help example #6
624              
625             package Todolist::Command::Show;
626              
627             use parent 'Data::Object::Cli';
628              
629             sub name {
630             'todolist show [<{priority}>]'
631             }
632              
633             sub info {
634             'show your todo list tasks by priority levels'
635             }
636              
637             my $command = run Todolist::Command::Show;
638              
639             # $command->help
640              
641             =back
642              
643             =cut
644              
645             =head2 main
646              
647             main(Any %args) : Any
648              
649             The main method is the "main method" and entrypoint into the program. It's
650             called automatically by the C<run> method if your package is configured as
651             recommended. This method accepts arguments as key/value pairs, and if called
652             by C<run> will receive the C<args>, C<data>, C<opts>, and C<vars> objects.
653              
654             =over 4
655              
656             =item main example #1
657              
658             package Todolist;
659              
660             use parent 'Data::Object::Cli';
661              
662             sub main {
663             my ($self, %args) = @_;
664              
665             return {%args} # no args
666             }
667              
668             my $todolist = run Todolist;
669              
670             $todolist->main;
671              
672             =back
673              
674             =over 4
675              
676             =item main example #2
677              
678             package Todolist;
679              
680             use parent 'Data::Object::Cli';
681              
682             sub main {
683             my ($self, %args) = @_;
684              
685             # has $args{args}
686             # has $args{data}
687             # has $args{opts}
688             # has $args{vars}
689              
690             return {%args}
691             }
692              
693             # $args{args} = $self->args; # isa <Data::Object::Args>
694             # represents @ARGV
695              
696             # $args{data} = $self->data; # isa <Data::Object::Data>
697             # represents __DATA__
698              
699             # $args{opts} = $self->opts; # isa <Data::Object::Opts>
700             # represents Getopt::Long
701              
702             # $args{vars} = $self->vars; # isa <Data::Object::Vars>
703             # represents %ENV
704              
705             my $todolist = run Todolist;
706              
707             $todolist->handle('main'); # called automatically by run
708              
709             =back
710              
711             =cut
712              
713             =head2 okay
714              
715             okay(Maybe[Str] $name, Any %args) : Any
716              
717             The okay method exits the program with a C<0> exit code. Optionally, you can
718             call a handler before exiting by providing a method name with arguments. The
719             handler will be called using the C<handle> method so the arguments should be
720             key/value pairs.
721              
722             =over 4
723              
724             =item okay example #1
725              
726             # given: synopsis
727              
728             $command->okay;
729              
730             # $command->okay($method_name, %args);
731             # $command->okay($method_name);
732              
733             =back
734              
735             =cut
736              
737             =head2 run
738              
739             run() : Object
740              
741             The run method is designed to bootstrap the program. It detects whether the
742             package is being invoked as a script or class and behaves accordingly. It will
743             be called automatically when the package is looaded if your package is
744             configured as recommended. This method will, if invoked as a script, call the
745             main method passing the C<args>, C<data>, C<opts>, and C<vars> objects.
746              
747             =over 4
748              
749             =item run example #1
750              
751             package Todolist;
752              
753             use parent 'Data::Object::Cli';
754              
755             run Todolist;
756              
757             =back
758              
759             =cut
760              
761             =head2 spec
762              
763             spec() : HashRef[HashRef]
764              
765             The spec method returns a hashref of flag definitions used to configure
766             L<Getopt::Long>. These options are accessible as methods on the
767             L<Data::Object::Opts> object through the C<opts> attribute. Each flag
768             definition can optionally declare C<args>, C<flag>, and C<type> values as
769             follows. The C<args> property denotes that multiple flags are permitted and its
770             value can be any valid L<Getopt::Long> I<repeat> specifier. The C<type>
771             property denotes the type of data allowed and defaults to type I<flag>.
772             Allowed values are C<string>, C<integer>, C<number>, C<float>, or C<flag>. The
773             C<flag> property denotes the flag aliases and should be a pipe-delimited
774             string, e.g. C<userid|id|u>, if multiple aliases are used.
775              
776             =over 4
777              
778             =item spec example #1
779              
780             package Todolist::Task;
781              
782             use parent 'Data::Object::Cli';
783              
784             our $name = 'todotask {id}';
785              
786             # id accessible as $self->args->id; alias of $ARGV[0]
787              
788             sub spec {
789             {
790             #
791             # represented in Getopt::Long as
792             # title|t=s
793             #
794             # title is accessible as $self->opts->title
795             #
796             title => {
797             type => 'string',
798             flag => 't'
799             },
800             #
801             # represented in Getopt::Long as
802             # content=s
803             #
804             # content is accessible as $self->opts->content
805             #
806             content => {
807             type => 'string',
808             },
809             #
810             # represented in Getopt::Long as
811             # attach|a=s@
812             #
813             # attach is accessible as $self->opts->attach
814             #
815             attach => {
816             flag => 'a',
817             args => '@' # allow multiple options
818             },
819             #
820             # represented in Getopt::Long as
821             # publish|p
822             #
823             # publish is accessible as $self->opts->publish
824             #
825             publish => {
826             flag => 'p',
827             type => 'flag'
828             },
829             #
830             # represented in Getopt::Long as
831             # unpublish|u
832             #
833             # unpublish is accessible as $self->opts->unpublish
834             #
835             unpublish => {
836             flag => 'u'
837             # defaults to type: flag
838             }
839             }
840             }
841              
842             my $todotask = run Todolist::Task;
843              
844             # $todotask->spec
845              
846             =back
847              
848             =cut
849              
850             =head2 subs
851              
852             subs(Any %args) : HashRef
853              
854             The subs method works in tandem with the L</auto> method and is expected to be
855             overridden by the subclass and should return a hashref where the keys represent
856             a subcommand at C<$ARGV[0]> and the value represents the description of the
857             corresponding action (i.e. I<command>).
858              
859             =over 4
860              
861             =item subs example #1
862              
863             package Todo::Admin;
864              
865             use parent 'Data::Object::Cli';
866              
867             our $name = 'todo <action>';
868              
869             sub auto {
870             {
871             add_user => '_handle_add_user',
872             del_user => '_handle_del_user'
873             }
874             }
875              
876             sub subs {
877             {
878             add_user => 'Add a new user to the system',
879             del_user => 'Remove a user to the system'
880             }
881             }
882              
883             my $admin = run Todo::Admin;
884              
885             __DATA__
886              
887             Usage: {name}
888              
889             Commands:
890              
891             {commands}
892              
893             Options:
894              
895             {options}
896              
897             =back
898              
899             =cut
900              
901             =head1 AUTHOR
902              
903             Al Newkirk, C<awncorp@cpan.org>
904              
905             =head1 LICENSE
906              
907             Copyright (C) 2011-2019, Al Newkirk, et al.
908              
909             This is free software; you can redistribute it and/or modify it under the terms
910             of the The Apache License, Version 2.0, as elucidated in the L<"license
911             file"|https://github.com/iamalnewkirk/data-object-cli/blob/master/LICENSE>.
912              
913             =head1 PROJECT
914              
915             L<Wiki|https://github.com/iamalnewkirk/data-object-cli/wiki>
916              
917             L<Project|https://github.com/iamalnewkirk/data-object-cli>
918              
919             L<Initiatives|https://github.com/iamalnewkirk/data-object-cli/projects>
920              
921             L<Milestones|https://github.com/iamalnewkirk/data-object-cli/milestones>
922              
923             L<Contributing|https://github.com/iamalnewkirk/data-object-cli/blob/master/CONTRIBUTE.md>
924              
925             L<Issues|https://github.com/iamalnewkirk/data-object-cli/issues>
926              
927             =cut