File Coverage

blib/lib/Test/Stream/Table.pm
Criterion Covered Total %
statement 122 122 100.0
branch 38 40 95.0
condition 26 30 86.6
subroutine 15 15 100.0
pod 3 6 50.0
total 204 213 95.7


line stmt bran cond sub pod time code
1             package Test::Stream::Table;
2 102     102   1187 use strict;
  102         195  
  102         2522  
3 102     102   515 use warnings;
  102         185  
  102         2680  
4              
5 102     102   56026 use Test::Stream::Table::LineBreak;
  102         249  
  102         3208  
6              
7 102     102   538 use List::Util qw/min max sum/;
  102         199  
  102         11303  
8 102     102   560 use Scalar::Util qw/blessed/;
  102         204  
  102         4368  
9              
10 102     102   566 use Test::Stream::Util qw/term_size/;
  102         195  
  102         720  
11              
12 102     102   531 use Test::Stream::Exporter;
  102         197  
  102         670  
13             exports qw/table/;
14 102     102   530 no Test::Stream::Exporter;
  102         195  
  102         511  
15              
16             sub BORDER_SIZE() { 4 } # '| ' and ' |' borders
17             sub DIV_SIZE() { 3 } # ' | ' column delimiter
18             sub PAD_SIZE() { 4 } # Extra arbitrary padding
19              
20             my %CHAR_MAP = (
21             "\a" => '\\a',
22             "\b" => '\\b',
23             "\e" => '\\e',
24             "\f" => '\\f',
25             "\n" => '\\n',
26             "\r" => '\\r',
27             "\t" => '\\t',
28             " " => ' ',
29             );
30              
31             sub char_id {
32 35     35 0 50 my $char = shift;
33 35         234 return "\\N{U+" . sprintf("\%X", ord($char)) . "}";
34             }
35              
36             sub show_char {
37 168     168 0 342 my ($char) = @_;
38 168   66     910 return $CHAR_MAP{$char} || char_id($char);
39             }
40              
41             sub sanitize {
42 166     166 1 312 for (@_) {
43 998 50       1820 next unless defined $_;
44 102     102   90008 s/([\s\t\p{Zl}\p{C}\p{Zp}])/show_char($1)/ge; # All whitespace except normal space
  102         1974  
  102         1482  
  998         1747  
  155         334  
45             }
46 166         259 return @_;
47             }
48              
49             sub mark_tail {
50 165     165 1 281 for (@_) {
51 998 50       1773 next unless defined $_;
52 998 100       1629 s/([\s\t\p{Zl}\p{C}\p{Zp}])$/$1 eq ' ' ? char_id($1) : show_char($1)/e;
  4         22  
53             }
54 165         231 return @_;
55             }
56              
57             sub resize {
58 10     10 0 18 my ($max, $show, $lengths) = @_;
59              
60 10         34 my $fair = int($max / @$show); # Fair size for all rows
61              
62 10         17 my $used = 0;
63 10         14 my @resize;
64 10         21 for my $i (@$show) {
65 49         60 my $size = $lengths->[$i];
66 49 100       96 if ($size <= $fair) {
67 24         27 $used += $size;
68 24         41 next;
69             }
70              
71 25         43 push @resize => $i;
72             }
73              
74 10         17 my $new_max = $max - $used;
75 10         22 my $new_fair = int($new_max / @resize);
76 10         43 $lengths->[$_] = $new_fair for @resize;
77             }
78              
79             sub table {
80 116     116 1 50613 my %params = @_;
81 116         225 my $header = $params{header};
82 116         185 my $rows = $params{rows};
83 116         216 my $collapse = $params{collapse};
84 116   66     638 my $maxwidth = $params{max_width} || term_size();
85 116         269 my $sanitize = $params{sanitize};
86 116         188 my $mark_tail = $params{mark_tail};
87 116   100     355 my $no_collapse = $params{no_collapse} || [];
88              
89 116         202 $no_collapse = { map {($_ => 1)} @$no_collapse };
  192         592  
90              
91 116 100       405 my $last = ($header ? scalar @$header : max(map { scalar @{$_} } @$rows)) - 1;
  3         6  
  3         15  
92 116         301 my @all = 0 .. $last;
93              
94 116         195 my $uniwarn = 0;
95 116         138 my @lengths;
96 116         266 for my $row (@$rows) {
97 213   100     389 $uniwarn ||= m/[^\x00-\x7F]/ for grep { defined($_) } @$row;
  1140         4947  
98 213 100       677 sanitize(@$row) if $sanitize;
99 213 100       632 mark_tail(@$row) if $mark_tail;
100 213 100       365 @$row = map { Test::Stream::Table::LineBreak->new(string => defined($row->[$_]) ? "$row->[$_]" : '') } @all;
  1140         5140  
101 213   100     939 $lengths[$_] = max($row->[$_]->columns, $lengths[$_] || 0) for @all;
102             }
103              
104             # How many columns are we showing?
105 116 100       285 my @show = $collapse ? (grep { $lengths[$_] || $no_collapse->{$_} } @all) : (@all);
  582 100       1662  
106              
107             # Titles should fit
108 116 100       344 if ($header) {
109 114         193 @$header = map {Test::Stream::Table::LineBreak->new(string => "$_")} @$header;
  634         2115  
110 114         341 for my $i (@all) {
111 634 100 100     3025 next if $collapse && !$lengths[$i] && !$no_collapse->{$i};
      100        
112 452   100     1216 $lengths[$i] = max($header->[$i]->columns, $lengths[$i] || 0);
113             }
114             }
115              
116             # Figure out size of screen, and a fair size for each column.
117 116         243 my $divs = @show * DIV_SIZE(); # size of the dividers combined
118 116         256 my $max_size = $maxwidth # initial terminal size
119             - BORDER_SIZE() # Subtract the border
120             - PAD_SIZE() # subtract the padding
121             - $divs; # Subtract dividers
122              
123             # Make sure we do not spill off the screen
124 116 100       524 resize($max_size, \@show, \@lengths) if sum(@lengths) > $max_size;
125              
126             # Put together borders and row template
127 116         203 my $border = join '-', '+', map { '-' x $lengths[$_], "+" } @show;
  458         1379  
128 116         285 my $row_tmpl = join ' ', '|', map { "\%s |" } @show;
  458         781  
129              
130 116 100       351 for my $row ($header ? ($header) : (), @$rows) {
131 327         485 for my $i (@show) {
132 1338         3932 $row->[$i]->break($lengths[$i]);
133             }
134             }
135              
136 116         145 my @new_rows;
137 116         186 my $span = 0;
138 116         273 while (@$rows) {
139 456         527 my @new;
140 456         604 my $row = $rows->[0];
141 456         523 my $found = 0;
142 456         524 $span++;
143              
144 456         692 for my $i (@show) {
145 1912         2446 my $item = $row->[$i];
146 1912         4686 my $part = $item->next;
147              
148 1912 100       3322 if (defined($part)) {
149 840         925 $found++;
150 840         1647 push @new => $part;
151             }
152             else {
153 1072         2810 push @new => ' ' x $lengths[$i];
154             }
155             }
156              
157 456 100 100     1582 if ($found || $span > 2) {
158 257         411 push @new_rows => \@new;
159             }
160              
161 456 100       1292 unless ($found) {
162 213         278 shift @$rows;
163 213         1397 $span = 0;
164             }
165             }
166              
167             # Remove trailing row padding
168 116 100 66     313 pop @new_rows if @new_rows && !grep { m/\S/ } @{$new_rows[-1]};
  458         1954  
  116         256  
169              
170             return (
171             $uniwarn && !$INC{'Unicode/GCString.pm'} ? (
172             "Unicode::GCString is not installed, table may not display all unicode characters properly",
173             ) : (),
174              
175             $header ? (
176             $border,
177 452         1130 sprintf($row_tmpl, map { $_->next } @$header[@show]),
178             ) : (),
179              
180             $border,
181              
182 116 100 66     562 (map {sprintf($row_tmpl, @{$_})} @new_rows),
  253 100       323  
  253         1811  
183              
184             $border,
185             );
186             }
187              
188             1;
189              
190             __END__