File Coverage

blib/lib/YATT/Lite/Util/CmdLine.pm
Criterion Covered Total %
statement 39 61 63.9
branch 20 40 50.0
condition 12 29 41.3
subroutine 6 7 85.7
pod 0 4 0.0
total 77 141 54.6


line stmt bran cond sub pod time code
1             package YATT::Lite::Util::CmdLine;
2 9     9   803 use strict;
  9         19  
  9         284  
3 9     9   47 use warnings qw(FATAL all NONFATAL misc);
  9         16  
  9         530  
4              
5 9     9   52 BEGIN {require Exporter; *import = \&Exporter::import}
  9         8448  
6              
7             our @EXPORT = qw(parse_opts parse_params);
8             our @EXPORT_OK = (@EXPORT, qw(run process_result));
9              
10             # posix style option.
11             sub parse_opts {
12 6     6 0 396 my ($pack, $list, $result, $alias) = @_;
13 6         12 my $wantarray = wantarray;
14 6 100       15 unless (defined $result) {
15 5 50       14 $result = $wantarray ? [] : {};
16             }
17 6   100     64 while (@$list and my ($n, $v) = $list->[0]
18             =~ m{^--$ | ^(?:--? ([\w:\-\.]+) (?: =(.*))?)$}xs) {
19 11         14 shift @$list;
20 11 100       24 last unless defined $n;
21 10 100 66     25 $n = $alias->{$n} if $alias and $alias->{$n};
22 10 100       20 $v = 1 unless defined $v;
23 10 100       22 if (ref $result eq 'HASH') {
24 3         21 $result->{$n} = $v;
25             } else {
26 7         51 push @$result, $n, $v;
27             }
28             }
29 6 100 66     77 $wantarray && ref $result ne 'HASH' ? @$result : $result;
30             }
31              
32             # 'Make' style parameter.
33             sub parse_params {
34 3     3 0 546 my ($pack, $list, $hash) = @_;
35 3         3 my $explicit;
36 3 50       6 unless (defined $hash) {
37 3         6 $hash = {}
38             } else {
39 0         0 $explicit++;
40             }
41 3   100     21 for (; @$list and $list->[0] =~ /^([^=]+)=(.*)/s; shift @$list) {
42 5         37 $hash->{$1} = $2;
43             }
44 3 50 33     20 if (not $explicit and wantarray) {
45             # return empty list if hash is empty
46 3 100       22 %$hash ? $hash : ();
47             } else {
48 0         0 $hash
49             }
50             }
51              
52             sub run {
53 1     1 0 27 my ($pack, $list, $alias) = @_;
54              
55 1         5 my @opts = parse_opts($pack, $list, $alias);
56 1         1 my $app = do {
57 1 50       4 if (ref $pack) {
58 0         0 $pack->configure(@opts);
59 0         0 $pack;
60             } else {
61 1         10 $pack->new(@opts);
62             }
63             };
64 1   50     5 my $cmd = shift @$list || 'help';
65 1         4 $app->configure(parse_opts($pack, \@_, $alias));
66              
67 1 50       13 if (my $sub = $app->can("cmd_$cmd")) {
    0          
68 1         4 $sub->($app, @$list);
69             } elsif ($sub = $app->can($cmd)) {
70 0           process_result($sub->($app, @$list));
71             } else {
72 0           die "$0: Unknown subcommand '$cmd'\n"
73             }
74 1 50         if (my $sub = $app->can('DESTROY')) {
75 0           $sub->($app);
76             }
77             }
78              
79             sub process_result {
80 0     0 0   my (@res) = @_;
81 0 0 0       if (not @res
    0 0        
      0        
      0        
82             or @res == 1 and not $res[0]) {
83 0           exit 1;
84             } elsif (@res == 1 and defined $res[0] and $res[0] eq 1) {
85             # nop
86             } else {
87 0           require YATT::Lite::Util;
88 0           foreach my $res (@res) {
89 0 0         unless (defined $res) {
    0          
    0          
90 0           print "(undef)\n";
91             } elsif (not ref $res) {
92 0           print $res, "\n";
93             } elsif (my $sub = $res->can('get_columns')) {
94 0           my @kv = $sub->($res);
95 0           my $cnt;
96 0           while (my ($k, $v) = splice @kv, 0, 2) {
97 0 0         print "\t" if $cnt++;
98 0           print "$k=", YATT::Lite::Util::terse_dump($v);
99             }
100 0           print "\n";
101             } else {
102 0           print YATT::Lite::Util::terse_dump($res), "\n";
103             }
104             }
105             }
106             }
107              
108             1;