File Coverage

blib/lib/App/jl.pm
Criterion Covered Total %
statement 186 189 98.4
branch 85 94 90.4
condition 39 47 82.9
subroutine 31 33 93.9
pod 3 3 100.0
total 344 366 93.9


line stmt bran cond sub pod time code
1             package App::jl;
2 5     5   441512 use strict;
  5         49  
  5         149  
3 5     5   26 use warnings;
  5         8  
  5         123  
4 5     5   2215 use JSON qw//;
  5         41531  
  5         115  
5 5     5   2367 use Sub::Data::Recursive;
  5         3417  
  5         198  
6 5     5   35 use B;
  5         10  
  5         265  
7 5     5   3738 use Getopt::Long qw/GetOptionsFromArray/;
  5         53948  
  5         22  
8              
9             our $VERSION = '0.17';
10              
11             my $MAX_RECURSIVE_CALL = 255;
12              
13             my $MAYBE_UNIXTIME = join '|', (
14             'create',
15             'update',
16             'expire',
17             '.._(?:at|on)',
18             '.ed$',
19             'date',
20             'time',
21             'since',
22             'when',
23             );
24              
25             my $LOG_LEVEL_STRINGS = join '|', (
26             'debug',
27             'trace',
28             'info',
29             'notice',
30             'warn',
31             'error',
32             'crit(?:ical)?',
33             'fatal',
34             'emerg(?:ency)?',
35             );
36              
37             my $L_BRACKET = '[ \\( \\{ \\< ]';
38             my $R_BRACKET = '[ \\) \\} \\> ]';
39              
40             my $UNIXTIMESTAMP_KEY = '';
41              
42             my $GMTIME;
43              
44             my $INVOKER = 'Sub::Data::Recursive';
45              
46             sub new {
47 32     32 1 23981 my $class = shift;
48 32         74 my @argv = @_;
49              
50 32         83 my $opt = $class->_parse_opt(@argv);
51              
52             my $self = bless {
53             _opt => $opt,
54 32         389 _json => JSON->new->utf8->pretty(!$opt->{no_pretty})->canonical(1),
55             __current_orig_line => undef,
56             }, $class;
57              
58 32         124 $self->_lazyload_modules;
59              
60 32         113 return $self;
61             }
62              
63             sub opt {
64 321     321 1 516 my ($self, $key) = @_;
65              
66 321         982 return $self->{_opt}{$key};
67             }
68              
69             sub run {
70 4     4 1 8 my ($self) = @_;
71              
72 4         9 local $| = !!$self->opt('unbuffered');
73              
74 4 100       9 my $out = !!$self->opt('stderr') ? *STDERR : *STDOUT;
75              
76 4         31 while ($self->{__current_orig_line} = ) {
77 4 100       12 if (my $line = $self->_run_line) {
78 3         68 print $out $line;
79             }
80 4         134 $self->{__current_orig_line} = undef;
81             }
82             }
83              
84             sub _run_line {
85 32     32   164 my ($self) = @_;
86              
87 32 100       141 if ($self->{__current_orig_line} =~ m!^[\s\t\r\n]+$!) {
88 1         4 return;
89             }
90              
91 31 100       130 if ($self->{__current_orig_line} !~ m!^\s*[\[\{]!) {
92 2 100       5 return $self->opt('sweep') ? undef : $self->{__current_orig_line};
93             }
94              
95 29 100       62 if (my $rs = $self->opt('grep')) {
96 4 100       11 if (!$self->_match_grep($rs)) {
97 1         4 return; # no match
98             }
99             }
100              
101 28 100       56 if (my $rs = $self->opt('ignore')) {
102 3 50       8 if ($self->_match_grep($rs)) {
103 3         10 return; # ignore if even one match
104             }
105             }
106              
107 25         59 return $self->_process;
108             }
109              
110             sub _match_grep {
111 7     7   14 my ($self, $rs) = @_;
112              
113 7         9 for my $r (@{$rs}) {
  7         15  
114 7 100       73 return 1 if $self->{__current_orig_line} =~ m!$r!;
115             }
116             }
117              
118             sub _lazyload_modules {
119 32     32   66 my ($self) = @_;
120              
121 32 100 66     68 if ($self->opt('xxxx') || $self->opt('timestamp_key')) {
122 10         1291 require 'POSIX.pm'; ## no critic
123 10         13738 POSIX->import;
124             }
125              
126 32 100       22415 if ($self->opt('yaml')) {
127 1         763 require 'YAML/Syck.pm'; ## no critic
128 1         2342 YAML::Syck->import;
129 1         4 $YAML::Syck::SortKeys = 1;
130             }
131             }
132              
133             sub _process {
134 25     25   45 my ($self) = @_;
135              
136 25         38 my $decoded = eval {
137 25         220 $self->{_json}->decode($self->{__current_orig_line});
138             };
139 25 100       68 if ($@) {
140 1         5 return $self->{__current_orig_line};
141             }
142             else {
143 24         64 $self->_recursive_process($decoded);
144 24         489 return $self->_encode($decoded);
145             }
146             }
147              
148             sub _encode {
149 24     24   46 my ($self, $decoded) = @_;
150              
151 24 100       45 if ($self->opt('yaml')) {
152 1         5 return YAML::Syck::Dump($decoded);
153             }
154             else {
155 23         313 return $self->{_json}->encode($decoded);
156             }
157             }
158              
159             sub _recursive_process {
160 24     24   48 my ($self, $decoded) = @_;
161              
162 24         102 $self->_recursive_pre_process($decoded);
163              
164 24         223 $self->{_recursive_call} = $MAX_RECURSIVE_CALL;
165 24         71 $self->_recursive_decode_json($decoded);
166              
167 24         776 $self->_recursive_post_process($decoded);
168             }
169              
170             sub _recursive_pre_process {
171 24     24   47 my ($self, $decoded) = @_;
172              
173 24         136 $INVOKER->invoke(\&_trim => $decoded);
174              
175 24 100       331 $self->_invoker(\&_split_lf => $decoded) if $self->opt('x');
176             }
177              
178             sub _recursive_post_process {
179 24     24   49 my ($self, $decoded) = @_;
180              
181 24 100       50 if ($self->opt('x')) {
182 14         35 $self->_invoker(\&_split_lf => $decoded);
183             }
184              
185 24 100       302 if ($self->opt('xx')) {
186 14         35 $self->_invoker(\&_split_comma => $decoded);
187             }
188              
189 24 100       270 if ($self->opt('xxx')) {
190 12         32 $self->_invoker(\&_split_label => $decoded);
191             }
192              
193 24 100 66     239 if ($self->opt('xxxx') || $self->opt('timestamp_key')) {
194 10 100       23 if ($self->opt('xxxxx')) {
195 7         25 $INVOKER->invoke(\&_forcely_convert_timestamp => $decoded);
196             }
197             else {
198 3         10 $self->_invoker(\&_convert_timestamp => $decoded);
199             }
200             }
201              
202 24         251 $INVOKER->invoke(\&_trim => $decoded);
203             }
204              
205             my $LAST_VALUE;
206              
207             sub _invoker {
208 57     57   114 my ($self, $code_ref, $hash) = @_;
209              
210 57         74 $LAST_VALUE = '';
211 57         143 $INVOKER->massive_invoke($code_ref => $hash);
212             }
213              
214             sub _skippable_value {
215 309     309   482 my ($context, $last_value) = @_;
216              
217 309   100     1642 return $context && $context eq 'HASH'
218             && $last_value && $last_value =~ m!user[\-\_\s]*agent!i;
219             }
220              
221             sub _split_lf {
222 135     135   2092 my $line = $_[0];
223 135         173 my $context = $_[1];
224              
225 135 100       200 if (_skippable_value($context, $LAST_VALUE)) {
226 14         25 $LAST_VALUE = $line;
227 14         32 return $line;
228             }
229              
230 121         197 $LAST_VALUE = $line;
231              
232 121 100       392 if ($line =~ m![\t\r\n]!) {
233 8         17 chomp $line;
234 8         40 my @elements = split /[\t\r\n]+/, $line;
235 8 50       53 $_[0] = \@elements if scalar @elements > 1;
236             }
237             }
238              
239             sub _split_comma {
240 88     88   1385 my $line = $_[0];
241 88         105 my $context = $_[1];
242              
243 88 100       155 if (_skippable_value($context, $LAST_VALUE)) {
244 7         10 $LAST_VALUE = $line;
245 7         17 return $line;
246             }
247              
248 81         119 $LAST_VALUE = $line;
249              
250 81 100 66     306 return $line if $line !~ m!, ! || $line =~ m!\\!;
251              
252 2         6 chomp $line;
253              
254 2         16 my @elements = split /,\s+/, $line;
255              
256 2 50       14 $_[0] = \@elements if scalar @elements > 1;
257             }
258              
259             sub _split_label {
260 86     86   1604 my $line = $_[0];
261 86         112 my $context = $_[1];
262              
263 86 100       133 if (_skippable_value($context, $LAST_VALUE)) {
264 6         11 $LAST_VALUE = $line;
265 6         14 return $line;
266             }
267              
268 80         140 $LAST_VALUE = $line;
269              
270 80 50       172 return $line if $line =~ m!\\!;
271              
272 80         110 chomp $line;
273              
274             # remove spaces between braces
275 80         329 $line =~ s!( $R_BRACKET ) [\s\t]+ ( $R_BRACKET )!$1$2!xg;
276              
277             # replace square brackets label
278 80         187 $line =~ s!( \[ [\s\t]* .+ [\s\t]* \] )!$1\n!ixg;
279              
280             # replace log level labels
281 80         475 $line =~ s!( $L_BRACKET ) [\s\t]* ( $LOG_LEVEL_STRINGS ) [\s\t]* ( $R_BRACKET )!$1$2$3\n!ixg;
282              
283 80         174 my @elements = split /\n/, $line;
284              
285 80 100       304 $_[0] = \@elements if scalar @elements > 1;
286             }
287              
288             sub _convert_timestamp {
289 37     37   649 my $line = $_[0];
290 37         45 my $context = $_[1];
291              
292 37 100 66     126 return $line if !$context || $context ne 'HASH';
293              
294 26 100 100     363 if (
      66        
      66        
      100        
295             ($UNIXTIMESTAMP_KEY && $LAST_VALUE eq $UNIXTIMESTAMP_KEY && $line =~ m!(\d+(\.\d+)?)!)
296             || ($LAST_VALUE =~ m!(?:$MAYBE_UNIXTIME)!i && $line =~ m!(\d+(\.\d+)?)!)
297             ) {
298 9 50       23 if (my $date = _ts2date($1, $2)) {
299 9         30 $_[0] = $date;
300             }
301             }
302              
303 26         90 $LAST_VALUE = $line;
304             }
305              
306             sub _forcely_convert_timestamp {
307 46     46   537 my $line = $_[0];
308              
309 46 100       156 if ($line =~ m!(\d+(\.\d+)?)!) {
310 7 100       17 if (my $date = _ts2date($1, $2)) {
311 3         22 $_[0] = $date;
312             }
313             }
314             }
315              
316             sub _ts2date {
317 16     16   43 my $unix_timestamp = shift;
318 16   100     53 my $msec = shift || '';
319              
320             # 946684800 = 2000-01-01T00:00:00Z
321 16 100 100     107 if ($unix_timestamp >= 946684800 && $unix_timestamp <= ((2**32 - 1) * 1000)) {
322 12 100       35 if ($unix_timestamp > 2**32 -1) {
323 3         44 ($msec) = ($unix_timestamp =~ m!(\d\d\d)$!);
324 3         10 $msec = ".$msec";
325 3         10 $unix_timestamp = int($unix_timestamp / 1000);
326             }
327 12 100       439 my @t = $GMTIME ? gmtime($unix_timestamp) : localtime($unix_timestamp);
328 12         1034 return POSIX::strftime('%Y-%m-%d %H:%M:%S', @t) . $msec;
329             }
330             }
331              
332             sub _trim {
333 219     219   3258 my $line = $_[0];
334              
335 219         269 my $trim = 0;
336              
337 219 100       587 if ($line =~ m!^[\s\t\r\n]+!) {
338 3         10 $line =~ s!^[\s\t\r\n]+!!;
339 3         29 $trim = 1;
340             }
341              
342 219 100       518 if ($line =~ m![\s\t\r\n]+$!) {
343 9         43 $line =~ s![\s\t\r\n]+$!!;
344 9         19 $trim = 1;
345             }
346              
347 219 100       539 if ($trim) {
348 11         46 $_[0] = $line;
349             }
350             }
351              
352             sub _recursive_decode_json {
353 63     63   154 my ($self, $hash) = @_;
354              
355             Sub::Data::Recursive->invoke(sub {
356 174 50   174   2895 if ($self->{_recursive_call} > 0) {
357 174         259 my $orig = $_[0];
358 174 50       379 return if $orig =~ m!^\[\d+\]$!;
359 174 100       299 if (!_is_number($_[0])) {
360 149         196 my $decoded = eval {
361 149         1083 $self->{_json}->decode($orig);
362             };
363 149 100       726 if (!$@) {
364 39         80 $_[0] = $decoded;
365 39         54 $self->{_recursive_call}--;
366 39         87 $self->_recursive_decode_json($_[0]); # recursive calling
367             }
368             }
369             }
370 63         302 } => $hash);
371             }
372              
373             # copied from Data::Recursive::Encode
374             sub _is_number {
375 174     174   227 my $value = shift;
376 174 50       295 return 0 unless defined $value;
377              
378 174         420 my $b_obj = B::svref_2object(\$value);
379 174         366 my $flags = $b_obj->FLAGS;
380 174 100 66     675 return $flags & ( B::SVp_IOK | B::SVp_NOK ) && !( $flags & B::SVp_POK ) ? 1 : 0;
381             }
382              
383             sub _parse_opt {
384 35     35   1358 my ($class, @argv) = @_;
385              
386 35         62 my $opt = {};
387              
388             GetOptionsFromArray(
389             \@argv,
390             'no-pretty' => \$opt->{no_pretty},
391             'x' => \$opt->{x},
392             'xx' => \$opt->{xx},
393             'xxx' => \$opt->{xxx},
394             'xxxx' => \$opt->{xxxx},
395             'X|xxxxx' => \$opt->{xxxxx},
396             'timestamp-key=s' => \$opt->{timestamp_key},
397             'gmtime' => \$opt->{gmtime},
398             'g|grep=s@' => \$opt->{grep},
399             'ignore=s@' => \$opt->{ignore},
400             'yaml|yml' => \$opt->{yaml},
401             'unbuffered' => \$opt->{unbuffered},
402             'stderr' => \$opt->{stderr},
403             'sweep' => \$opt->{sweep},
404             'h|help' => sub {
405 0     0   0 $class->_show_usage(1);
406             },
407             'v|version' => sub {
408 0     0   0 print "$0 $VERSION\n";
409 0         0 exit 1;
410             },
411 35 50       379 ) or $class->_show_usage(2);
412              
413 35   100     35882 $opt->{xxxx} ||= $opt->{xxxxx};
414 35   100     152 $opt->{xxx} ||= $opt->{xxxx};
415 35   100     165 $opt->{xx} ||= $opt->{xxx};
416 35   66     117 $opt->{x} ||= $opt->{xx};
417              
418 35         88 $UNIXTIMESTAMP_KEY = $opt->{timestamp_key};
419              
420 35         72 $GMTIME = $opt->{gmtime};
421              
422 35         81 return $opt;
423             }
424              
425             sub _show_usage {
426 1     1   92 my ($class, $exitval) = @_;
427              
428 1         591 require Pod::Usage;
429 1         52361 Pod::Usage::pod2usage(-exitval => $exitval);
430             }
431              
432             1;
433              
434             __END__