File Coverage

blib/lib/Text/Diff/Table.pm
Criterion Covered Total %
statement 122 140 87.1
branch 56 76 73.6
condition 16 34 47.0
subroutine 12 14 85.7
pod 0 6 0.0
total 206 270 76.3


line stmt bran cond sub pod time code
1             package Text::Diff::Table;
2              
3 2     2   34 use 5.006;
  2         4  
4 2     2   6 use strict;
  2         3  
  2         39  
5 2     2   5 use warnings;
  2         2  
  2         52  
6 2     2   6 use Carp;
  2         2  
  2         109  
7 2     2   843 use Text::Diff::Config;
  2         4  
  2         3630  
8              
9             our $VERSION = '1.43';
10             our @ISA = qw( Text::Diff::Base Exporter );
11             our @EXPORT_OK = qw( expand_tabs );
12              
13             my %escapes = map {
14             my $c =
15             $_ eq '"' || $_ eq '$' ? qq{'$_'}
16             : $_ eq "\\" ? qq{"\\\\"}
17             : qq{"$_"};
18             ( ord eval $c => $_ )
19             } (
20             map( chr, 32..126),
21             map( sprintf( "\\x%02x", $_ ), ( 0..31, 127..255 ) ),
22             # map( "\\c$_", "A".."Z"),
23             "\\t", "\\n", "\\r", "\\f", "\\b", "\\a", "\\e"
24             ## NOTE: "\\\\" is not here because some things are explicitly
25             ## escaped before escape() is called and we don't want to
26             ## double-escape "\". Also, in most texts, leaving "\" more
27             ## readable makes sense.
28             );
29              
30             sub expand_tabs($) {
31 18     18 0 16 my $s = shift;
32 18         9 my $count = 0;
33 18         41 $s =~ s{(\t)(\t*)|([^\t]+)}{
34 36 100       51 if ( $1 ) {
35 12         19 my $spaces = " " x ( 8 - $count % 8 + 8 * length $2 );
36 12         7 $count = 0;
37 12         21 $spaces;
38             }
39             else {
40 24         19 $count += length $3;
41 24         36 $3;
42             }
43             }ge;
44              
45 18         25 return $s;
46             }
47              
48             sub trim_trailing_line_ends($) {
49 0     0 0 0 my $s = shift;
50 0         0 $s =~ s/[\r\n]+(?!\n)$//;
51 0         0 return $s;
52             }
53              
54             sub escape($);
55              
56             SCOPE: {
57             ## use utf8 if available. don't if not.
58             my $escaper = <<'EOCODE';
59             sub escape($) {
60             use utf8;
61             join "", map {
62             my $c = $_;
63             $_ = ord;
64             exists $escapes{$_}
65             ? $escapes{$_}
66             : $Text::Diff::Config::Output_Unicode
67             ? $c
68             : sprintf( "\\x{%04x}", $_ );
69             } split //, shift;
70             }
71              
72             1;
73             EOCODE
74 2 0   2 0 1282 unless ( eval $escaper ) {
  2 50   22   55  
  2         8  
  22         45  
  105         67  
  105         82  
  105         199  
75             $escaper =~ s/ *use *utf8 *;\n// or die "Can't drop use utf8;";
76             eval $escaper or die $@;
77             }
78             }
79              
80             sub new {
81 8     8 0 10 my $proto = shift;
82 8         20 return bless { @_ }, $proto
83             }
84              
85             my $missing_elt = [ "", "" ];
86              
87             sub hunk {
88 8     8 0 8 my $self = shift;
89 8         12 my @seqs = ( shift, shift );
90 8         8 my $ops = shift; ## Leave sequences in @_[0,1]
91 8         7 my $options = shift;
92              
93 8         6 my ( @A, @B );
94 8         13 for ( @$ops ) {
95 15         18 my $opcode = $_->[Text::Diff::OPCODE()];
96 15 50       24 if ( $opcode eq " " ) {
97 0         0 push @A, $missing_elt while @A < @B;
98 0         0 push @B, $missing_elt while @B < @A;
99             }
100 15 100 50     72 push @A, [ $_->[0] + ( $options->{OFFSET_A} || 0), $seqs[0][$_->[0]] ]
      66        
101             if $opcode eq " " || $opcode eq "-";
102 15 100 50     64 push @B, [ $_->[1] + ( $options->{OFFSET_B} || 0), $seqs[1][$_->[1]] ]
      66        
103             if $opcode eq " " || $opcode eq "+";
104             }
105              
106 8         17 push @A, $missing_elt while @A < @B;
107 8         14 push @B, $missing_elt while @B < @A;
108 8         7 my @elts;
109 8         16 for ( 0..$#A ) {
110 8         11 my ( $A, $B ) = (shift @A, shift @B );
111            
112             ## Do minimal cleaning on identical elts so these look "normal":
113             ## tabs are expanded, trailing newelts removed, etc. For differing
114             ## elts, make invisible characters visible if the invisible characters
115             ## differ.
116 8 50       26 my $elt_type = $B == $missing_elt ? "A" :
    50          
    100          
117             $A == $missing_elt ? "B" :
118             $A->[1] eq $B->[1] ? "="
119             : "*";
120 8 100       13 if ( $elt_type ne "*" ) {
121 1 50 33     9 if ( $elt_type eq "=" || $A->[1] =~ /\S/ || $B->[1] =~ /\S/ ) {
      33        
122 0         0 $A->[1] = escape trim_trailing_line_ends expand_tabs $A->[1];
123 0         0 $B->[1] = escape trim_trailing_line_ends expand_tabs $B->[1];
124             }
125             else {
126 1         23 $A->[1] = escape $A->[1];
127 1         18 $B->[1] = escape $B->[1];
128             }
129             }
130             else {
131             ## not using \z here for backcompat reasons.
132 7         44 $A->[1] =~ /^(\s*?)([^ \t].*?)?(\s*)(?![\n\r])$/s;
133 7         18 my ( $l_ws_A, $body_A, $t_ws_A ) = ( $1, $2, $3 );
134 7 100       12 $body_A = "" unless defined $body_A;
135 7         19 $B->[1] =~ /^(\s*?)([^ \t].*?)?(\s*)(?![\n\r])$/s;
136 7         9 my ( $l_ws_B, $body_B, $t_ws_B ) = ( $1, $2, $3 );
137 7 100       13 $body_B = "" unless defined $body_B;
138              
139 7         3 my $added_escapes;
140              
141 7 100       13 if ( $l_ws_A ne $l_ws_B ) {
142             ## Make leading tabs visible. Other non-' ' chars
143             ## will be dealt with in escape(), but this prevents
144             ## tab expansion from hiding tabs by making them
145             ## look like ' '.
146 1 50       11 $added_escapes = 1 if $l_ws_A =~ s/\t/\\t/g;
147 1 50       5 $added_escapes = 1 if $l_ws_B =~ s/\t/\\t/g;
148             }
149              
150 7 100       8 if ( $t_ws_A ne $t_ws_B ) {
151             ## Only trailing whitespace gets the \s treatment
152             ## to make it obvious what's going on.
153 3 100       9 $added_escapes = 1 if $t_ws_A =~ s/ /\\s/g;
154 3 50       5 $added_escapes = 1 if $t_ws_B =~ s/ /\\s/g;
155 3 100       6 $added_escapes = 1 if $t_ws_A =~ s/\t/\\t/g;
156 3 100       6 $added_escapes = 1 if $t_ws_B =~ s/\t/\\t/g;
157             }
158             else {
159 4         6 $t_ws_A = $t_ws_B = "";
160             }
161              
162 7   66     14 my $do_tab_escape = $added_escapes || do {
163             my $expanded_A = expand_tabs join( $body_A, $l_ws_A, $t_ws_A );
164             my $expanded_B = expand_tabs join( $body_B, $l_ws_B, $t_ws_B );
165             $expanded_A eq $expanded_B;
166             };
167              
168 7   66     10 my $do_back_escape = $do_tab_escape || do {
169             my ( $unescaped_A, $escaped_A,
170             $unescaped_B, $escaped_B
171             ) =
172             map
173             join( "", /(\\.)/g ),
174             map {
175             ( $_, escape $_ )
176             }
177             expand_tabs join( $body_A, $l_ws_A, $t_ws_A ),
178             expand_tabs join( $body_B, $l_ws_B, $t_ws_B );
179             $unescaped_A ne $unescaped_B && $escaped_A eq $escaped_B;
180             };
181              
182 7 100       11 if ( $do_back_escape ) {
183 4         4 $body_A =~ s/\\/\\\\/g;
184 4         3 $body_B =~ s/\\/\\\\/g;
185             }
186              
187 7         12 my $line_A = join $body_A, $l_ws_A, $t_ws_A;
188 7         6 my $line_B = join $body_B, $l_ws_B, $t_ws_B;
189              
190 7 100       12 unless ( $do_tab_escape ) {
191 3         4 $line_A = expand_tabs $line_A;
192 3         5 $line_B = expand_tabs $line_B;
193             }
194              
195 7         146 $A->[1] = escape $line_A;
196 7         126 $B->[1] = escape $line_B;
197             }
198              
199 8         33 push @elts, [ @$A, @$B, $elt_type ];
200             }
201              
202 8         7 push @{$self->{ELTS}}, @elts, ["bar"];
  8         28  
203 8         24 return "";
204             }
205              
206             sub _glean_formats {
207 0     0   0 my $self = shift;
208             }
209              
210             sub file_footer {
211 8     8 0 9 my $self = shift;
212 8         11 my @seqs = (shift,shift);
213 8         7 my $options = pop;
214              
215 8         7 my @heading_lines;
216            
217 8 50 33     32 if ( defined $options->{FILENAME_A} || defined $options->{FILENAME_B} ) {
218             push @heading_lines, [
219             map(
220             {
221 0 0       0 ( "", escape( defined $_ ? $_ : "" ) );
222             }
223 0         0 ( @{$options}{qw( FILENAME_A FILENAME_B)} )
  0         0  
224             ),
225             "=",
226             ];
227             }
228              
229 8 50 33     30 if ( defined $options->{MTIME_A} || defined $options->{MTIME_B} ) {
230             push @heading_lines, [
231             map( {
232 0 0 0     0 ( "",
233             escape(
234             ( defined $_ && length $_ )
235             ? localtime $_
236             : ""
237             )
238             );
239             }
240 0         0 @{$options}{qw( MTIME_A MTIME_B )}
  0         0  
241             ),
242             "=",
243             ];
244             }
245              
246 8 50       13 if ( defined $options->{INDEX_LABEL} ) {
247 0 0       0 push @heading_lines, [ "", "", "", "", "=" ] unless @heading_lines;
248             $heading_lines[-1]->[0] = $heading_lines[-1]->[2] =
249 0         0 $options->{INDEX_LABEL};
250             }
251              
252             ## Not ushifting on to @{$self->{ELTS}} in case it's really big. Want
253             ## to avoid the overhead.
254              
255 8         7 my $four_column_mode = 0;
256 8         8 for my $cols ( @heading_lines, @{$self->{ELTS}} ) {
  8         14  
257 15 100       26 next if $cols->[-1] eq "bar";
258 8 100       22 if ( $cols->[0] ne $cols->[2] ) {
259 1         1 $four_column_mode = 1;
260 1         2 last;
261             }
262             }
263              
264 8 100       19 unless ( $four_column_mode ) {
265 7         5 for my $cols ( @heading_lines, @{$self->{ELTS}} ) {
  7         9  
266 14 100       51 next if $cols->[-1] eq "bar";
267 7         12 splice @$cols, 2, 1;
268             }
269             }
270              
271 8         12 my @w = (0,0,0,0);
272 8         7 for my $cols ( @heading_lines, @{$self->{ELTS}} ) {
  8         12  
273 16 100       25 next if $cols->[-1] eq "bar";
274 8         16 for my $i (0..($#$cols-1)) {
275 25 100 66     94 $w[$i] = length $cols->[$i]
276             if defined $cols->[$i] && length $cols->[$i] > $w[$i];
277             }
278             }
279              
280 8 100       61 my %fmts = $four_column_mode
281             ? (
282             "=" => "| %$w[0]s|%-$w[1]s | %$w[2]s|%-$w[3]s |\n",
283             "A" => "* %$w[0]s|%-$w[1]s * %$w[2]s|%-$w[3]s |\n",
284             "B" => "| %$w[0]s|%-$w[1]s * %$w[2]s|%-$w[3]s *\n",
285             "*" => "* %$w[0]s|%-$w[1]s * %$w[2]s|%-$w[3]s *\n",
286             )
287             : (
288             "=" => "| %$w[0]s|%-$w[1]s |%-$w[2]s |\n",
289             "A" => "* %$w[0]s|%-$w[1]s |%-$w[2]s |\n",
290             "B" => "| %$w[0]s|%-$w[1]s |%-$w[2]s *\n",
291             "*" => "* %$w[0]s|%-$w[1]s |%-$w[2]s *\n",
292             );
293              
294 8         12 my @args = ('', '', '');
295 8 100       15 push(@args, '') if $four_column_mode;
296 8         31 $fmts{bar} = sprintf $fmts{"="}, @args;
297 8         40 $fmts{bar} =~ s/\S/+/g;
298 8         32 $fmts{bar} =~ s/ /-/g;
299              
300             # Sometimes the sprintf has too many arguments,
301             # which results in a warning on Perl 5.021+
302             # I really wanted to write:
303             # no warnings 'redundant';
304             # but that causes a compilation error on older versions of perl
305             # where the warnings pragma doesn't know about 'redundant'
306 2     2   13 no warnings;
  2         2  
  2         368  
307              
308             return join( "",
309             map {
310 24         86 sprintf( $fmts{$_->[-1]}, @$_ );
311             } (
312             ["bar"],
313             @heading_lines,
314             @heading_lines ? ["bar"] : (),
315 8 50       21 @{$self->{ELTS}},
  8         12  
316             ),
317             );
318              
319 0           @{$self->{ELTS}} = [];
  0            
320             }
321              
322             1;
323              
324             __END__