File Coverage

blib/lib/App/NDTools/NDDiff.pm
Criterion Covered Total %
statement 106 304 34.8
branch 20 122 16.3
condition 4 48 8.3
subroutine 19 39 48.7
pod 0 19 0.0
total 149 532 28.0


line stmt bran cond sub pod time code
1             package App::NDTools::NDDiff;
2              
3 1     1   626 use strict;
  1         2  
  1         58  
4 1     1   6 use warnings FATAL => 'all';
  1         2  
  1         38  
5 1     1   5 use parent 'App::NDTools::NDTool';
  1         2  
  1         16  
6              
7 1     1   46 use Algorithm::Diff;
  1         3  
  1         54  
8 1     1   5 use JSON qw();
  1         2  
  1         19  
9 1     1   5 use App::NDTools::Slurp qw(s_dump);
  1         1  
  1         44  
10 1     1   5 use Log::Log4Cli 0.18;
  1         19  
  1         90  
11 1     1   545 use Struct::Diff 0.94 qw();
  1         7196  
  1         35  
12 1     1   7 use Struct::Path 0.80 qw(path path_delta);
  1         15  
  1         59  
13 1     1   543 use Struct::Path::PerlStyle 0.80 qw(str2path path2str);
  1         176722  
  1         94  
14 1     1   13 use Term::ANSIColor qw(colored);
  1         2  
  1         3035  
15              
16             our $VERSION = '0.33';
17              
18             my $JSON = JSON->new->canonical->allow_nonref;
19              
20             sub arg_opts {
21 3     3 0 6 my $self = shift;
22              
23             return (
24             $self->SUPER::arg_opts(),
25 0     0   0 'brief' => sub { $self->{OPTS}->{ofmt} = $_[0] },
26             'colors!' => \$self->{OPTS}->{colors},
27             'ctx-text=i' => \$self->{OPTS}->{'ctx-text'},
28             'full' => \$self->{OPTS}->{full},
29             'full-headers' => \$self->{OPTS}->{'full-headers'},
30             'grep=s@' => \$self->{OPTS}->{grep},
31 0     0   0 'json' => sub { $self->{OPTS}->{ofmt} = $_[0] },
32             'ignore=s@' => \$self->{OPTS}->{ignore},
33 0     0   0 'rules' => sub { $self->{OPTS}->{ofmt} = $_[0] },
34             'quiet|q' => \$self->{OPTS}->{quiet},
35             'show' => \$self->{OPTS}->{show},
36             )
37 3         9 }
38              
39             sub check_args {
40 3     3 0 5 my $self = shift;
41              
42 3 50       15 if ($self->{OPTS}->{show}) {
    50          
43 0 0       0 die_fatal "At least one argument expected when --show used", 1
44             unless (@_);
45             } elsif (@_ < 2) {
46 0         0 die_fatal "At least two arguments expected for diff", 1;
47             }
48              
49 3         5 return $self;
50             }
51              
52             sub configure {
53 3     3 0 5 my $self = shift;
54              
55 3         17 $self->SUPER::configure();
56              
57             $self->{OPTS}->{colors} = -t STDOUT ? 1 : 0
58 3 50       35 unless (defined $self->{OPTS}->{colors});
    50          
59              
60 3         7 for (@{$self->{OPTS}->{grep}}, @{$self->{OPTS}->{ignore}}) {
  3         7  
  3         46  
61 0         0 my $tmp = eval { str2path($_) };
  0         0  
62 0 0       0 die_fatal "Failed to parse '$_'", 4 if ($@);
63 0         0 $_ = $tmp;
64             }
65              
66 3         8 return $self;
67             }
68              
69             sub defaults {
70 3     3 0 6 my $self = shift;
71              
72             my $out = {
73 3         5 %{$self->SUPER::defaults()},
  3         11  
74             'ctx-text' => 3,
75             'term' => {
76             'head' => 'yellow',
77             'line' => {
78             'A' => 'green',
79             'D' => 'yellow',
80             'U' => 'white',
81             'R' => 'red',
82             '@' => 'magenta',
83             },
84             'sign' => {
85             'A' => '+',
86             'D' => '!',
87             'U' => ' ',
88             'R' => '-',
89             '@' => ' ',
90             },
91             },
92             'ofmt' => 'term',
93             };
94 3         11 $out->{term}{line}{N} = $out->{term}{line}{A};
95 3         6 $out->{term}{line}{O} = $out->{term}{line}{R};
96 3         6 $out->{term}{sign}{N} = $out->{term}{sign}{A};
97 3         4 $out->{term}{sign}{O} = $out->{term}{sign}{R};
98 3         11 return $out;
99             }
100              
101             sub diff {
102 3     3 0 7 my ($self, $old, $new) = @_;
103              
104 3     0   20 log_debug { "Calculating diff for structure" };
  0         0  
105             my $diff = Struct::Diff::diff(
106             $old, $new,
107 3 50       27 noU => $self->{OPTS}->{full} ? 0 : 1,
108             );
109              
110 3 50       316 if ($self->{OPTS}->{ofmt} eq 'term') {
111 3 50       10 $self->diff_term($diff) or return undef;
112             }
113              
114 3         10 return $diff;
115             }
116              
117             sub _lcsidx2ranges {
118 2     2   256 my ($in_a, $in_b) = @_;
119              
120 2 50       3 return [], [] unless (@{$in_a});
  2         8  
121              
122 0         0 my @out_a = [ shift @{$in_a} ];
  0         0  
123 0         0 my @out_b = [ shift @{$in_b} ];
  0         0  
124              
125 0         0 while (@{$in_a}) {
  0         0  
126 0         0 my $i_a = shift @{$in_a};
  0         0  
127 0         0 my $i_b = shift @{$in_b};
  0         0  
128 0 0 0     0 if (
129             ($i_a - $out_a[-1][-1] < 2) and
130             ($i_b - $out_b[-1][-1] < 2)
131             ) { # update ranges - both sequences are continous
132 0         0 $out_a[-1][1] = $i_a;
133 0         0 $out_b[-1][1] = $i_b;
134             } else { # new ranges
135 0         0 push @out_a, [ $i_a ];
136 0         0 push @out_b, [ $i_b ];
137             }
138             }
139              
140 0         0 return \@out_a, \@out_b;
141             }
142              
143             sub diff_term {
144 3     3 0 6 my ($self, $diff) = @_;
145              
146 3     0   14 log_debug { "Calculating diffs for text values" };
  0         0  
147              
148 3         12 my $dref; # ref to diff
149 3         12 my ($o, $n); # LCS ranges
150 3         0 my ($po, $pn); # current positions in splitted texts
151 3         0 my ($ro, $rn); # current LCS range
152 3         15 my @list = Struct::Diff::list_diff($diff);
153              
154 3         60 while (@list) {
155 3         7 (undef, $dref) = splice @list, 0, 2;
156              
157 3 100       5 next unless (exists ${$dref}->{N});
  3         8  
158 2 50       5 unless (exists ${$dref}->{O}) {
  2         5  
159 0     0   0 log_error { "Incomplete diff passed (old value is absent)" };
  0         0  
160 0         0 return undef;
161             }
162              
163 2         11 my @old = split($/, ${$dref}->{O}, -1)
164 2 50 33     4 if (${$dref}->{O} and not ref ${$dref}->{O});
  2         9  
  2         29  
165 2         10 my @new = split($/, ${$dref}->{N}, -1)
166 2 50 33     5 if (${$dref}->{N} and not ref ${$dref}->{N});
  2         8  
  2         27  
167              
168 2 50 33     9 if (@old > 1 or @new > 1) {
169 2         4 delete ${$dref}->{O};
  2         6  
170 2         4 delete ${$dref}->{N};
  2         6  
171              
172 2 50 33     8 if ($old[-1] eq '' and $new[-1] eq '') {
173 0         0 pop @old; # because split by newline and -1 for LIMIT
174 0         0 pop @new; # -"-
175             }
176              
177 2         18 ($o, $n) = _lcsidx2ranges(Algorithm::Diff::LCSidx \@old, \@new);
178 2         5 ($po, $pn) = (0, 0);
179              
180 2         3 while (@{$o}) {
  2         6  
181 0         0 ($ro, $rn) = (shift @{$o}, shift @{$n});
  0         0  
  0         0  
182 0 0       0 push @{${$dref}->{T}}, { R => [ @old[$po .. $ro->[0] - 1] ] }
  0         0  
  0         0  
183             if ($ro->[0] > $po);
184 0 0       0 push @{${$dref}->{T}}, { A => [ @new[$pn .. $rn->[0] - 1] ] }
  0         0  
  0         0  
185             if ($rn->[0] > $pn);
186 0         0 push @{${$dref}->{T}}, { U => [ @new[$rn->[0] .. $rn->[-1]] ] };
  0         0  
  0         0  
187 0         0 $po = $ro->[-1] + 1;
188 0         0 $pn = $rn->[-1] + 1;
189             }
190              
191             # collect tailing added/removed
192 2 50       6 push @{${$dref}->{T}}, { R => [ @old[$po .. $#old] ] }
  2         2  
  2         10  
193             if ($po <= $#old);
194 2 50       6 push @{${$dref}->{T}}, { A => [ @new[$pn .. $#new] ] }
  2         3  
  2         11  
195             if ($pn <= $#new);
196             }
197             }
198              
199 3         12 return $self;
200             }
201              
202             sub dump {
203 0     0 0 0 my ($self, $diff) = @_;
204              
205 0     0   0 log_debug { "Dumping results" };
  0         0  
206              
207 0 0       0 if ($self->{OPTS}->{ofmt} eq 'term') {
    0          
    0          
208 0         0 $self->dump_term($diff);
209             } elsif ($self->{OPTS}->{ofmt} eq 'brief') {
210 0         0 $self->dump_brief($diff);
211             } elsif ($self->{OPTS}->{ofmt} eq 'rules') {
212 0         0 $self->dump_rules($diff);
213             } else {
214             s_dump(\*STDOUT, $self->{OPTS}->{ofmt},
215 0         0 {pretty => $self->{OPTS}->{pretty}}, $diff);
216             }
217              
218 0         0 return $self;
219             }
220              
221             sub dump_brief {
222 0     0 0 0 my ($self, $diff) = @_;
223              
224 0         0 my ($path, $dref, $tag);
225 0         0 my @list = Struct::Diff::list_diff($diff, sort => 1);
226              
227 0         0 while (@list) {
228 0         0 ($path, $dref) = splice @list, 0, 2;
229 0         0 for $tag (qw{R N A}) {
230             $self->print_brief_block($path, $tag)
231 0 0       0 if (exists ${$dref}->{$tag});
  0         0  
232             }
233             }
234             }
235              
236             sub dump_rules {
237 0     0 0 0 my ($self, $diff) = @_;
238              
239 0         0 my ($path, $dref, $item, @out);
240 0         0 my @list = Struct::Diff::list_diff($diff, sort => 1);
241              
242 0         0 while (@list) {
243 0         0 ($path, $dref) = splice @list, 0, 2;
244 0         0 for (qw{R N A}) {
245 0 0       0 next unless (exists ${$dref}->{$_});
  0         0  
246             unshift @out, {
247             modname => $_ eq "R" ? "Remove" : "Insert",
248             path => $self->dump_rules_path($path),
249 0 0       0 value => ${$dref}->{$_}
  0         0  
250             };
251             }
252             }
253              
254 0         0 s_dump(\*STDOUT, 'JSON', {pretty => $self->{OPTS}->{pretty}}, \@out);
255             }
256              
257             sub dump_rules_path { # to be able to override
258 0     0 0 0 return path2str($_[1]);
259             }
260              
261             sub dump_term {
262 0     0 0 0 my ($self, $diff) = @_;
263              
264 0         0 my ($path, $dref, $tag);
265 0         0 my @list = Struct::Diff::list_diff($diff, sort => 1);
266              
267 0         0 while (@list) {
268 0         0 ($path, $dref) = splice @list, 0, 2;
269 0         0 for $tag (qw{R O N A T}) {
270 0         0 $self->print_term_block(${$dref}->{$tag}, $path, $tag)
271 0 0       0 if (exists ${$dref}->{$tag});
  0         0  
272             }
273             }
274             }
275              
276             sub exec {
277 0     0 0 0 my $self = shift;
278 0         0 my @items;
279              
280 0         0 while (@{$self->{ARGV}}) {
  0         0  
281 0         0 my $name = shift @{$self->{ARGV}};
  0         0  
282 0 0       0 my $data = $self->load($name) or die_fatal undef, 1;
283              
284 0         0 my $diff;
285              
286 0 0       0 if ($self->{OPTS}->{show}) {
287 0         0 $self->print_term_header($name);
288 0         0 $diff = $data;
289             } else {
290 0         0 push @items, { name => $name, data => $data };
291 0 0       0 next unless (@items > 1);
292              
293 0         0 $self->print_term_header($items[0]->{name}, $items[1]->{name});
294              
295             $diff = $self->diff($items[0]->{data}, $items[1]->{data})
296 0 0       0 or die_fatal undef, 1;
297              
298 0         0 shift @items;
299             }
300              
301             $self->dump($diff) or die_fatal undef, 1
302 0 0 0     0 unless ($self->{OPTS}->{quiet});
303              
304 0 0 0     0 $self->{status} = 8 unless (not keys %{$diff} or exists $diff->{U});
  0         0  
305             }
306              
307 0 0       0 die_info "All done, no difference found", 0 unless ($self->{status});
308 0         0 die_info "Difference found", 8;
309             }
310              
311             sub load {
312 6     6 0 466 my $self = shift;
313              
314             my $data = $self->load_struct($_[0], $self->{OPTS}->{ifmt})
315 6 50       36 or return undef;
316              
317             ($data) = $self->grep($self->{OPTS}->{grep}, $data)
318 6 50       11 if (@{$self->{OPTS}->{grep}});
  6         18  
319              
320 6 50       12 map { path($data, $_, delete => 1) } @{$self->{OPTS}->{ignore}}
  0         0  
  0         0  
321             if (ref $data);
322              
323 6         34 return $data;
324             }
325              
326             sub print_brief_block {
327 0     0 0   my ($self, $path, $status) = @_;
328              
329 0 0         return unless (@{$path}); # nothing to show
  0            
330              
331 0           $path = [ @{$path} ]; # prevent passed path corruption (used later for items with same subpath)
  0            
332 0 0         $status = 'D' if ($status eq 'N');
333 0           my $last = path2str([pop @{$path}]);
  0            
334 0           my $base = path2str($path);
335              
336 0 0         if ($self->{OPTS}->{colors}) {
337 0           $last = colored($last, "bold " . $self->{OPTS}->{term}->{line}->{$status});
338 0           $base = colored($base, $self->{OPTS}->{term}->{line}->{U});
339             }
340              
341 0           print $self->{OPTS}->{term}->{sign}->{$status} . " " . $base . $last . "\n";
342             }
343              
344             sub print_term_block {
345 0     0 0   my ($self, $value, $path, $status) = @_;
346              
347 0     0     log_trace { "'" . path2str($path) . "' (" . $status . ")" };
  0            
348              
349 0           my @lines;
350 0           my $color = $self->{OPTS}->{term}->{line}->{$status};
351 0           my $dsign = $self->{OPTS}->{term}->{sign}->{$status};
352              
353             # diff for path
354 0 0 0       if (@{$path} and my @delta = path_delta($self->{'hdr_path'}, $path)) {
  0            
355 0           $self->{'hdr_path'} = [@{$path}];
  0            
356 0           for (my $s = 0; $s < @{$path}; $s++) {
  0            
357 0 0 0       next if (not $self->{OPTS}->{'full-headers'} and $s < @{$path} - @delta);
  0            
358 0           my $line = sprintf("%" . $s * 2 . "s", "") . path2str([$path->[$s]]);
359 0 0 0       if (($status eq 'A' or $status eq 'R') and $s == $#{$path}) {
  0   0        
360 0           $line = "$dsign $line";
361 0 0         $line = colored($line, "bold $color") if ($self->{OPTS}->{colors});
362             } else {
363 0           $line = " $line";
364             }
365 0           push @lines, $line;
366             }
367             }
368              
369             # diff for value
370 0           my $indent = sprintf "%" . @{$path} * 2 . "s", "";
  0            
371 0           push @lines, $self->term_value_diff($value, $status, $indent);
372              
373 0           print join("\n", @lines) . "\n";
374             }
375              
376             sub print_term_header {
377 0     0 0   my ($self, @names) = @_;
378              
379 0 0         return unless (-t STDOUT); # don't dump to pipes
380              
381 0 0         my $header = @names == 1 ? $names[0] :
382             "--- a: $names[0] \n+++ b: $names[1]";
383              
384             $header = colored($header, $self->{OPTS}->{term}->{head})
385 0 0         if ($self->{OPTS}->{colors});
386              
387 0           print $header . "\n";
388             }
389              
390             sub term_value_diff {
391 0     0 0   my ($self, $value, $status, $indent) = @_;
392              
393 0 0         return $self->term_value_diff_text($value, $indent)
394             if ($status eq 'T');
395              
396 0           return $self->term_value_diff_default($value, $status, $indent);
397             }
398              
399             sub term_value_diff_default {
400 0     0 0   my ($self, $value, $status, $indent) = @_;
401 0           my @out;
402              
403 0 0 0       $value = $JSON->pretty($self->{OPTS}->{pretty})->encode($value)
404             if (ref $value or not defined $value);
405              
406 0           for my $line (split($/, $value)) {
407 0           substr($line, 0, 0, $self->{OPTS}->{term}->{sign}->{$status} . $indent . " ");
408             $line = colored($line, $self->{OPTS}->{term}->{line}->{$status})
409 0 0         if ($self->{OPTS}->{colors});
410 0           push @out, $line;
411             }
412              
413 0           return @out;
414             }
415              
416             sub term_value_diff_text {
417 0     0 0   my ($self, $diff, $indent) = @_;
418 0           my (@out, @head_ctx, @tail_ctx, $pos);
419              
420 0           while (my $hunk = shift @{$diff}) {
  0            
421 0           my ($status, $lines) = each %{$hunk};
  0            
422 0           my $sign = $self->{OPTS}->{term}->{sign}->{$status};
423 0           my $color = $self->{OPTS}->{term}->{line}->{$status};
424 0           $pos += @{$lines};
  0            
425              
426 0 0         if ($status eq 'U') {
427 0 0         if ($self->{OPTS}->{'ctx-text'}) {
428 0           @head_ctx = splice(@{$lines}); # before changes
  0            
429 0 0         @tail_ctx = splice(@head_ctx, 0, $self->{OPTS}->{'ctx-text'}) # after changes
430             if (@out);
431             splice(@head_ctx, 0, @head_ctx - $self->{OPTS}->{'ctx-text'})
432 0 0         if (@head_ctx > $self->{OPTS}->{'ctx-text'});
433              
434 0 0         splice(@head_ctx) unless (@{$diff});
  0            
435              
436             @head_ctx = map {
437 0           my $l = $sign . " " . $indent . $_;
  0            
438 0 0         $self->{OPTS}->{colors} ? colored($l, $color) : $l;
439             } @head_ctx;
440             @tail_ctx = map {
441 0           my $l = $sign . " " . $indent . $_;
  0            
442 0 0         $self->{OPTS}->{colors} ? colored($l, $color) : $l;
443             } @tail_ctx;
444             } else {
445 0           splice(@{$lines}); # purge or will be printed in the next block
  0            
446             }
447             }
448              
449 0           push @out, splice @tail_ctx;
450 0 0 0       if (@head_ctx or (not $self->{OPTS}->{'ctx-text'} and $status eq 'U' and @{$diff}) or not @out) {
  0   0        
      0        
      0        
451 0           my $l = $self->{OPTS}->{term}->{sign}->{'@'} . " " . $indent . "@@ $pos,- -,- @@";
452 0 0         push @out, $self->{OPTS}->{colors} ? colored($l, $self->{OPTS}->{term}->{line}->{'@'}) : $l;
453             }
454 0           push @out, splice @head_ctx;
455             push @out, map {
456 0           my $l = $sign . " " . $indent . $_;
457 0 0         $self->{OPTS}->{colors} ? colored($l, $color) : $l;
458 0           } @{$lines};
  0            
459             }
460              
461 0           return @out;
462             }
463              
464             1; # End of App::NDTools::NDDiff