File Coverage

blib/lib/App/NDTools/NDQuery.pm
Criterion Covered Total %
statement 119 119 100.0
branch 43 50 86.0
condition 3 3 100.0
subroutine 20 20 100.0
pod 0 9 0.0
total 185 201 92.0


line stmt bran cond sub pod time code
1             package App::NDTools::NDQuery;
2              
3 1     1   579 use strict;
  1         1  
  1         28  
4 1     1   4 use warnings FATAL => 'all';
  1         2  
  1         38  
5 1     1   5 use parent 'App::NDTools::NDTool';
  1         2  
  1         21  
6              
7 1     1   45 use Digest::MD5 qw(md5_hex);
  1         2  
  1         41  
8 1     1   5 use JSON qw();
  1         2  
  1         13  
9 1     1   4 use Log::Log4Cli;
  1         2  
  1         72  
10 1     1   6 use App::NDTools::Slurp qw(s_dump);
  1         1  
  1         62  
11 1     1   6 use Struct::Path 0.80 qw(list_paths path path_delta);
  1         13  
  1         46  
12 1     1   412 use Struct::Path::PerlStyle 0.80 qw(str2path path2str);
  1         43539  
  1         66  
13 1     1   8 use Term::ANSIColor qw(color);
  1         2  
  1         1252  
14              
15             our $VERSION = '0.36';
16              
17             sub arg_opts {
18 47     47 0 78 my $self = shift;
19              
20             return (
21             $self->SUPER::arg_opts(),
22             'colors!' => \$self->{OPTS}->{colors},
23             'delete|ignore=s@' => \$self->{OPTS}->{delete},
24             'depth|d=i' => \$self->{OPTS}->{depth},
25             'grep=s@' => \$self->{OPTS}->{grep},
26             'keys' => \$self->{OPTS}->{keys},
27             'list|l' => \$self->{OPTS}->{list},
28             'md5' => \$self->{OPTS}->{md5},
29             'path|p=s' => \$self->{OPTS}->{path},
30 4     4   4670 'raw-output' => sub { $self->{OPTS}->{ofmt} = 'RAW' },
31             'replace' => \$self->{OPTS}->{replace},
32             'strict!' => \$self->{OPTS}->{strict},
33             'values|vals' => \$self->{OPTS}->{values},
34 47         166 );
35             }
36              
37             sub check_args {
38 45     45 0 77 my $self = shift;
39              
40 45 100       100 if ($self->{OPTS}->{replace}) {
41             die_fatal "--replace opt can't be used with --keys", 1
42 4 50       9 if ($self->{OPTS}->{keys});
43             die_fatal "--replace opt can't be used with --list", 1
44 4 100       12 if ($self->{OPTS}->{list});
45             die_fatal "--replace opt can't be used with --md5", 1
46 3 100       10 if ($self->{OPTS}->{md5});
47             }
48              
49 43         105 return $self;
50             }
51              
52             sub configure {
53 45     45 0 72 my $self = shift;
54              
55 45         144 $self->SUPER::configure();
56              
57             $self->{OPTS}->{colors} = $self->{TTY}
58 43 100       126 unless (defined $self->{OPTS}->{colors});
59              
60 43         54 for (
61 43         81 @{$self->{OPTS}->{grep}},
62 43         99 @{$self->{OPTS}->{delete}}
63             ) {
64 12         18 my $tmp = eval { str2path($_) };
  12         45  
65 12 50       8061 die_fatal "Failed to parse '$_'", 4 if ($@);
66 12         45 $_ = $tmp;
67             }
68              
69 43         75 return $self;
70             }
71              
72             sub defaults {
73 47     47 0 73 my $self = shift;
74              
75             return {
76 47         54 %{$self->SUPER::defaults()},
  47         142  
77             'color-common' => 'bold black',
78             'strict' => 1, # exit with 8 if unexisted path specified
79             'ofmt' => 'JSON',
80             };
81             }
82              
83             sub dump {
84 29     29 0 53 my ($self, $uri, $data) = @_;
85              
86 29 100       72 $uri = \*STDOUT unless ($self->{OPTS}->{replace});
87 29         86 s_dump($uri, $self->{OPTS}->{ofmt}, {pretty => $self->{OPTS}->{pretty}}, @{$data});
  29         77  
88             }
89              
90             sub exec {
91 43     43 0 62 my $self = shift;
92              
93 43 50       55 for my $uri (@{$self->{ARGV}} ? @{$self->{ARGV}} : \*STDIN) {
  43         113  
  43         109  
94 47         182 my @data = $self->load_struct($uri, $self->{OPTS}->{ifmt});
95              
96 47 100       112 if (defined $self->{OPTS}->{path}) {
97 15         19 my $spath = eval { str2path($self->{OPTS}->{path}) };
  15         67  
98 15 50       10868 die_fatal "Failed to parse '$self->{OPTS}->{path}'", 4 if ($@);
99              
100 15 100       64 unless (@data = path($data[0], $spath, deref => 1)) {
101             die_fatal "Failed to lookup path '$self->{OPTS}->{path}'", 8
102 2 100       76 if ($self->{OPTS}->{strict});
103 1         8 next;
104             }
105             }
106              
107             @data = $self->grep($self->{OPTS}->{grep}, @data)
108 45 100       8010 if (@{$self->{OPTS}->{grep}});
  45         132  
109              
110 45         62 for my $spath (@{$self->{OPTS}->{delete}}) {
  45         109  
111 4 50       109 map { path($_, $spath, delete => 1) if (ref $_) } @data;
  4         32  
112             }
113              
114 45 100       372 if ($self->{OPTS}->{keys}) {
    100          
    100          
115 4         13 $self->list_keys(\@data);
116             } elsif ($self->{OPTS}->{list}) {
117 7         26 $self->list($uri, \@data);
118             } elsif ($self->{OPTS}->{md5}) {
119 5         13 $self->md5($uri, \@data);
120             } else {
121 29         85 $self->dump($uri, \@data);
122             }
123             }
124              
125 42         193 die_info "All done", 0;
126             }
127              
128             my $JSON = JSON->new->canonical->allow_nonref;
129              
130             sub list_keys {
131 4     4 0 10 my ($self, $data) = @_;
132 4         5 my @out;
133              
134 4         5 for (@{$data}) {
  4         9  
135 10 100       26 if (ref $_ eq 'HASH') {
    100          
136 1         2 push @out, sort keys %{$_};
  1         6  
137             } elsif (ref $_ eq 'ARRAY') {
138 3         4 push @out, "0 .. " . $#{$_};
  3         7  
139             } else {
140 6         29 push @out, $JSON->encode($_);
141             }
142             }
143              
144 4         130 print join("\n", @out) . "\n";
145             }
146              
147             sub list {
148 7     7 0 14 my ($self, $uri, $data) = @_;
149              
150             my $base_pfx = $self->{OPTS}->{colors}
151 7 100       30 ? color($self->{OPTS}->{'color-common'}) : "";
152 7 100       54 my $base_sfx = $self->{OPTS}->{colors} ? color('reset') : "";
153              
154 7         25 for (@{$data}) {
  7         13  
155 7         22 my @list = list_paths($_, depth => $self->{OPTS}->{depth});
156 7         1157 my (@delta, $line, $path, $prev, $value, @out);
157              
158 7         19 while (@list) {
159 58         128 ($path, $value) = splice @list, 0, 2;
160              
161 58         116 @delta = path_delta($prev, $path);
162             $line = $base_pfx .
163 58         2852 path2str([@{$path}[0 .. @{$path} - @delta - 1]]) . $base_sfx .
  58         141  
  58         104  
164             path2str(\@delta);
165              
166 58 100       4907 if ($self->{OPTS}->{values}) {
167 37         58 $line .= " = ";
168 37 100 100     81 if ($self->{OPTS}->{ofmt} eq 'RAW' and not ref ${$value}) {
  3         9  
169 2         3 $line .= ${$value};
  2         5  
170             } else {
171 35         43 $line .= $JSON->encode(${$value});
  35         130  
172             }
173             }
174              
175 58         93 push @out, $line;
176 58         135 $prev = $path;
177             }
178              
179 7         289 print join("\n", @out) . "\n";
180             }
181             }
182              
183             sub md5 {
184 5     5 0 12 my ($self, $uri, $data) = @_;
185              
186 5 50       6 print md5_hex($JSON->encode(@{$data} == 1 ? $data->[0] : $data)) .
  5 50       197  
187             (ref $uri ? " -\n" : " $uri\n");
188             }
189              
190             1; # End of App::NDTools::NDQuery