File Coverage

blib/lib/Term/TablePrint.pm
Criterion Covered Total %
statement 45 529 8.5
branch 1 286 0.3
condition 0 45 0.0
subroutine 16 35 45.7
pod 2 2 100.0
total 64 897 7.1


line stmt bran cond sub pod time code
1             package Term::TablePrint;
2              
3 1     1   68664 use warnings;
  1         2  
  1         31  
4 1     1   5 use strict;
  1         2  
  1         16  
5 1     1   12 use 5.10.0;
  1         4  
6              
7             our $VERSION = '0.159';
8 1     1   6 use Exporter 'import';
  1         2  
  1         51  
9             our @EXPORT_OK = qw( print_table );
10              
11 1     1   6 use Carp qw( croak );
  1         2  
  1         53  
12              
13 1     1   6 use List::Util qw( sum max );
  1         2  
  1         124  
14 1     1   7 use Scalar::Util qw( looks_like_number );
  1         2  
  1         43  
15              
16 1     1   708 use Term::Choose qw( choose );
  1         93319  
  1         126  
17 1     1   20 use Term::Choose::Constants qw( WIDTH_CURSOR );
  1         4  
  1         54  
18 1     1   29 use Term::Choose::LineFold qw( line_fold cut_to_printwidth print_columns );
  1         3  
  1         69  
19 1     1   7 use Term::Choose::Screen qw( hide_cursor show_cursor );
  1         2  
  1         97  
20 1     1   8 use Term::Choose::ValidateOptions qw( validate_options );
  1         2  
  1         47  
21 1     1   619 use Term::Choose::Util qw( get_term_width insert_sep );
  1         29684  
  1         68  
22 1     1   554 use Term::TablePrint::ProgressBar qw();
  1         3  
  1         76  
23              
24              
25             BEGIN {
26 1 50   1   1985 if ( $^O eq 'MSWin32' ) {
27 0         0 require Win32::Console::ANSI;
28             }
29             }
30              
31             my $save_memory = 0;
32              
33             sub new {
34 0     0 1   my $class = shift;
35 0 0         croak "new: called with " . @_ . " arguments - 0 or 1 arguments expected." if @_ > 1;
36 0           my ( $opt ) = @_;
37 0           my $instance_defaults = _defaults();
38 0 0         if ( defined $opt ) {
39 0 0         croak "new: The (optional) argument is not a HASH reference." if ref $opt ne 'HASH';
40 0           validate_options( _valid_options(), $opt, 'new' );
41 0           for my $key ( keys %$opt ) {
42 0 0         $instance_defaults->{$key} = $opt->{$key} if defined $opt->{$key};
43             }
44             }
45 0           my $self = bless $instance_defaults, $class;
46 0           $self->{backup_instance_defaults} = { %$instance_defaults };
47 0           return $self;
48             }
49              
50              
51             sub _valid_options {
52             return {
53 0     0     codepage_mapping => '[ 0 1 ]',
54             hide_cursor => '[ 0 1 ]', # documentation
55             mouse => '[ 0 1 ]',
56             squash_spaces => '[ 0 1 ]',
57             table_expand => '[ 0 1 ]',
58             trunc_fract_first => '[ 0 1 ]',
59             binary_filter => '[ 0 1 2 ]',
60             color => '[ 0 1 2 ]',
61             page => '[ 0 1 2 ]', # undocumented
62             search => '[ 0 1 2 ]', #
63             keep => '[ 1-9 ][ 0-9 ]*', # undocumented
64             max_rows => '[ 0-9 ]+',
65             min_col_width => '[ 0-9 ]+', ##
66             progress_bar => '[ 0-9 ]+',
67             tab_width => '[ 0-9 ]+',
68             binary_string => 'Str', ##
69             decimal_separator => 'Str',
70             footer => 'Str',
71             info => 'Str',
72             prompt => 'Str',
73             undef => 'Str',
74             #thsd_sep => 'Str',
75             };
76             }
77              
78              
79             sub _defaults {
80             return {
81 0     0     binary_filter => 0,
82             binary_string => 'BNRY',
83             codepage_mapping => 0,
84             color => 0,
85             decimal_separator => '.',
86             footer => undef,
87             hide_cursor => 1,
88             info => undef,
89             keep => undef,
90             max_rows => 0,
91             min_col_width => 30,
92             mouse => 0,
93             page => 2, ##
94             progress_bar => 40000,
95             prompt => '',
96             search => 1,
97             squash_spaces => 0,
98             tab_width => 2,
99             table_expand => 1,
100             trunc_fract_first => 1,
101             undef => '',
102             thsd_sep => ',', #
103             }
104             }
105              
106              
107             sub __reset {
108 0     0     my ( $self ) = @_;
109 0 0         if ( $self->{hide_cursor} ) {
110 0           print show_cursor();
111             }
112 0 0         if ( exists $self->{backup_instance_defaults} ) {
113 0           my $instance_defaults = $self->{backup_instance_defaults};
114 0           for my $key ( keys %$self ) {
115 0 0 0       if ( $key eq 'plugin' || $key eq 'backup_instance_defaults' ) {
    0          
116 0           next;
117             }
118             elsif ( exists $instance_defaults->{$key} ) {
119 0           $self->{$key} = $instance_defaults->{$key};
120             }
121             else {
122 0           delete $self->{$key};
123             }
124             }
125             }
126             }
127              
128              
129             sub print_table {
130 0 0   0 1   if ( ref $_[0] ne __PACKAGE__ ) {
131 0           my $ob = __PACKAGE__->new();
132 0           delete $ob->{backup_instance_defaults};
133 0           return $ob->print_table( @_ );
134             }
135 0           my $self = shift;
136 0           my ( $tbl_orig, $opt ) = @_;
137 0 0 0       croak "print_table: called with " . @_ . " arguments - 1 or 2 arguments expected." if @_ < 1 || @_ > 2;
138 0 0         croak "print_table: requires an ARRAY reference as its first argument." if ref $tbl_orig ne 'ARRAY';
139 0 0         if ( defined $opt ) {
140 0 0         croak "print_table: the (optional) second argument is not a HASH reference." if ref $opt ne 'HASH';
141 0           validate_options( _valid_options(), $opt, 'print_table' );
142 0           for my $key ( keys %$opt ) {
143 0 0         $self->{$key} = $opt->{$key} if defined $opt->{$key};
144             }
145             }
146 0           $self->{tab_w} = $self->{tab_width};
147 0 0         if ( ! ( $self->{tab_width} % 2 ) ) {
148 0           ++$self->{tab_w};
149             }
150 0           local $| = 1;
151             local $SIG{INT} = sub {
152 0     0     $self->__reset();
153 0           print "\n";
154 0           exit;
155 0           };
156 0 0         if ( print_columns( $self->{decimal_separator} ) != 1 ) {
157 0           $self->{decimal_separator} = '.';
158             }
159 0 0         if ( $self->{decimal_separator} ne '.' ) {
160 0           $self->{thsd_sep} = '_';
161             }
162 0 0         if ( $self->{hide_cursor} ) {
163 0           print hide_cursor();
164             }
165 0 0         if ( ! @$tbl_orig ) {
166             # Choose
167 0           choose(
168             [ 'Close with ENTER' ],
169             { prompt => "'print_table': empty table without header row!", hide_cursor => 0 }
170             );
171 0           $self->__reset();
172 0           return;
173             }
174 0           my $data_row_count = @$tbl_orig - 1;
175 0           my $info_row = '';
176 0 0 0       if ( $self->{max_rows} && $data_row_count > $self->{max_rows} ) {
177 0           $info_row = sprintf( 'Limited to %s rows', insert_sep( $self->{max_rows}, $self->{thsd_sep} ) );
178 0           $info_row .= sprintf( ' (total %s)', insert_sep( $data_row_count, $self->{thsd_sep} ) );
179 0           $data_row_count = $self->{max_rows};
180             }
181 0 0 0       my $const = {
182             extra_w => $^O eq 'MSWin32' || $^O eq 'cygwin' ? 0 : WIDTH_CURSOR,
183             data_row_count => $data_row_count,
184             info_row => $info_row,
185             regex_number => "^([^.EeNn]*)(\Q$self->{decimal_separator}\E[0-9]+)?\\z",
186             };
187 0           my $search = {
188             filter => '',
189             map_indexes => [],
190             };
191 0           my $mr = {
192             last => 0,
193             window_width_changed => 1,
194             enter_search_string => 2,
195             returned_from_filtered_table => 3,
196             };
197              
198 0           my ( $term_w, $tbl_print, $tbl_w, $header_rows, $w_col_names ) = $self->__get_data( $tbl_orig, $const );
199 0 0         if ( ! defined $term_w ) {
200 0           $self->__reset();
201 0           return;
202             }
203              
204 0           WRITE_TABLE: while ( 1 ) {
205 0           my $next = $self->__write_table(
206             $term_w, $tbl_orig, $tbl_print, $tbl_w, $header_rows, $w_col_names, $const, $search, $mr
207             );
208 0 0         if ( ! defined $next ) {
    0          
    0          
    0          
    0          
209 0           die;
210             }
211             elsif ( $next == $mr->{last} ) {
212 0           last WRITE_TABLE;
213             }
214             elsif ( $next == $mr->{window_width_changed} ) {
215 0           ( $term_w, $tbl_print, $tbl_w, $header_rows, $w_col_names ) = $self->__get_data( $tbl_orig, $const );
216 0 0         if ( ! defined $term_w ) {
217 0           last WRITE_TABLE;
218             }
219 0           next WRITE_TABLE;
220             }
221             elsif ( $next == $mr->{enter_search_string} ) {
222 0           $self->__search( $tbl_orig, $const, $search );
223 0           next WRITE_TABLE;
224             }
225             elsif ( $next == $mr->{returned_from_filtered_table} ) {
226 0           $self->__reset_search( $search );
227 0           next WRITE_TABLE;
228             }
229             }
230 0           $self->__reset();
231 0           return;
232             }
233              
234              
235             sub __get_data {
236 0     0     my ( $self, $tbl_orig, $const ) = @_;
237 0           my $term_w = get_term_width() + $const->{extra_w};
238             my $progress = Term::TablePrint::ProgressBar->new( {
239             data_row_count => $const->{data_row_count},
240 0           col_count => scalar @{$tbl_orig->[0]},
241             threshold => $self->{progress_bar},
242 0           count_progress_bars => 3,
243             } );
244 0           my $tbl_copy = $self->__copy_table( $tbl_orig, $progress );
245 0           my ( $w_col_names, $w_cols, $w_int, $w_fract ) = $self->__calc_col_width( $tbl_copy, $const, $progress );
246 0           my $w_cols_calc = $self->__calc_avail_col_width( $term_w, $tbl_copy, $w_col_names, $w_cols, $w_int, $w_fract );
247 0 0         if ( ! defined $w_cols_calc ) {
248 0           return;
249             }
250 0           my $tbl_w = sum( @{$w_cols_calc}, $self->{tab_w} * $#{$w_cols_calc} );
  0            
  0            
251 0           my $tbl_print = $self->__cols_to_string( $tbl_orig, $tbl_copy, $w_cols_calc, $w_fract, $const, $progress );
252 0           my @tmp_header_rows;
253 0 0         if ( length $self->{prompt} ) {
254 0           push @tmp_header_rows, $self->{prompt};
255             }
256 0 0 0       if ( length $self->{info} || length $self->{prompt} ) {
257 0           push @tmp_header_rows, $self->__header_sep( $w_cols_calc );
258             }
259 0           my $col_names = shift @{$tbl_print};
  0            
260 0           push @tmp_header_rows, $col_names, $self->__header_sep( $w_cols_calc );
261 0           my $header_rows = join "\n", @tmp_header_rows;
262 0 0         if ( $const->{info_row} ) {
263 0 0         if ( print_columns( $const->{info_row} ) > $tbl_w ) {
264 0           push @{$tbl_print}, cut_to_printwidth( $const->{info_row}, $tbl_w - 3 ) . '...';
  0            
265             }
266             else {
267 0           push @{$tbl_print}, $const->{info_row};
  0            
268             }
269             }
270 0           return $term_w, $tbl_print, $tbl_w, $header_rows, $w_col_names;
271             }
272              
273              
274             sub __write_table {
275 0     0     my ( $self, $term_w, $tbl_orig, $tbl_print, $tbl_w, $header_rows, $w_col_names, $const, $search, $mr ) = @_;
276 0           my @idxs_tbl_print;
277 0           my $return = $mr->{last};
278 0 0         if ( $search->{filter} ) {
279 0           @idxs_tbl_print = map { $_ - 1 } @{$search->{map_indexes}}; # because of the removed tbl_print header row
  0            
  0            
280 0           $return = $mr->{returned_from_filtered_table};
281             }
282 0           my $footer;
283 0 0         if ( $self->{footer} ) {
284 0           $footer = $self->{footer};
285 0 0         if ( $search->{filter} ) {
286 0           $footer .= $search->{filter};
287             }
288             }
289 0 0 0       my $old_row = exists $ENV{TC_POS_AT_SEARCH} && ! $search->{filter} ? delete( $ENV{TC_POS_AT_SEARCH} ) : 0;
290 0           my $auto_jumped_to_first_row = 2;
291 0           my $row_is_expanded = 0;
292              
293 0           while ( 1 ) {
294 0 0         if ( $term_w != get_term_width() + $const->{extra_w} ) {
295 0           return $mr->{window_width_changed};
296             }
297 0 0         if ( ! @{$tbl_print} ) {
  0            
298 0           push @{$tbl_print}, ''; # so that going back requires always the same amount of keystrokes
  0            
299             }
300 0           $ENV{TC_RESET_AUTO_UP} = 0;
301             # Choose
302             my $row = choose(
303 0           @idxs_tbl_print ? [ @{$tbl_print}[@idxs_tbl_print] ]
304             : $tbl_print,
305             { info => $self->{info}, prompt => $header_rows, index => 1, default => $old_row, ll => $tbl_w, layout => 2,
306             clear_screen => 1, mouse => $self->{mouse}, hide_cursor => 0, footer => $footer, color => $self->{color},
307             codepage_mapping => $self->{codepage_mapping}, search => $self->{search}, keep => $self->{keep},
308             page => $self->{page} }
309 0 0         );
310 0 0         if ( ! defined $row ) {
    0          
311 0           return $return;
312             }
313             elsif ( $row < 0 ) {
314 0 0         if ( $row == -1 ) { # with option `ll` set and changed window width `choose` returns -1;
    0          
315 0           return $mr->{window_width_changed};
316             }
317             elsif ( $row == -13 ) { # with option `ll` set `choose` returns -13 if `Ctrl-F` was pressed
318 0 0         if ( $search->{filter} ) {
319 0           $self->__reset_search( $search );
320             }
321 0           return $mr->{enter_search_string};
322             }
323             else {
324 0           return $mr->{last};
325             }
326             }
327 0 0         if ( ! $self->{table_expand} ) {
328 0 0         if ( $row == 0 ) {
329 0           return $return;
330             }
331 0           next;
332             }
333             else {
334 0 0         if ( $old_row == $row ) {
335 0 0         if ( $row == 0 ) {
    0          
336 0 0         if ( $self->{table_expand} ) {
337 0 0         if ( $row_is_expanded ) {
338 0           return $return;
339             }
340 0 0         if ( $auto_jumped_to_first_row == 1 ) {
341 0           return $return;
342             }
343             }
344 0           $auto_jumped_to_first_row = 0;
345             }
346             elsif ( $ENV{TC_RESET_AUTO_UP} ) {
347 0           $auto_jumped_to_first_row = 0;
348             }
349             else {
350 0           $old_row = 0;
351 0           $auto_jumped_to_first_row = 1;
352 0           $row_is_expanded = 0;
353 0           next;
354             }
355             }
356 0           $old_row = $row;
357 0           $row_is_expanded = 1;
358 0 0 0       if ( $const->{info_row} && $row == $#{$tbl_print} ) {
  0            
359             # Choose
360             choose(
361             [ 'Close' ],
362 0           { prompt => $const->{info_row}, clear_screen => 1, mouse => $self->{mouse}, hide_cursor => 0 }
363             );
364 0           next;
365             }
366 0           my $orig_row;
367 0 0         if ( @{$search->{map_indexes}} ) {
  0            
368 0           $orig_row = $search->{map_indexes}[$row];
369             }
370             else {
371 0           $orig_row = $row + 1; # because $tbl_print has no header row while $tbl_orig has a header row
372             }
373 0           $self->__print_single_row( $tbl_orig, $orig_row, $w_col_names, $footer );
374             }
375 0           delete $ENV{TC_RESET_AUTO_UP};
376             }
377             }
378              
379              
380             sub __copy_table {
381 0     0     my ( $self, $tbl_orig, $progress ) = @_;
382 0           my $tbl_copy = [];
383 0           my $count = $progress->set_progress_bar(); #
384 0           ROW: for my $row ( @$tbl_orig ) {
385 0           my $tmp_row = [];
386 0           COL: for ( @$row ) {
387 0           my $str = $_; # this is where the copying happens
388 0 0         $str = $self->{undef} if ! defined $str;
389 0 0         $str = _handle_reference( $str ) if ref $str;
390 0 0         if ( $self->{squash_spaces} ) {
391 0           $str =~ s/^\p{Space}+//;
392 0           $str =~ s/\p{Space}+\z//;
393 0           $str =~ s/\p{Space}+/ /g;
394             }
395 0 0         if ( $self->{color} ) {
396 0           $str =~ s/\x{feff}//g;
397 0           $str =~ s/\e\[[\d;]*m/\x{feff}/g;
398             }
399 0 0 0       if ( $self->{binary_filter} && substr( $str, 0, 100 ) =~ /[\x00-\x08\x0B-\x0C\x0E-\x1F]/ ) {
400             #$str = $self->{binary_filter} == 2 ? sprintf("%v02X", $str) =~ tr/./ /r : $self->{binary_string}; # perl 5.14
401 0 0         if ( $self->{binary_filter} == 2 ) {
402 0           ( $str = sprintf("%v02X", $str) ) =~ tr/./ /;
403             }
404             else {
405 0           $str = $self->{binary_string};
406             }
407             }
408 0           $str =~ s/\t/ /g;
409 0           $str =~ s/\v+/\ \ /g;
410 0           $str =~ s/[\p{Cc}\p{Noncharacter_Code_Point}\p{Cs}]//g;
411 0           push @$tmp_row, $str;
412             }
413 0           push @$tbl_copy, $tmp_row;
414 0 0         if ( @$tbl_copy == $self->{max_rows} ) {
415 0           last;
416             }
417 0 0         if ( $progress->{count_progress_bars} ) { #
418 0 0         if ( $count >= $progress->{next_update} ) { #
419 0           $progress->update_progress_bar( $count ); #
420             } #
421 0           ++$count; #
422             } #
423             }
424 0 0         if ( $progress->{count_progress_bars} ) { #
425 0           $progress->last_update_progress_bar( $count ); #
426             } #
427 0           return $tbl_copy
428             }
429              
430              
431             sub __calc_col_width {
432 0     0     my ( $self, $tbl_copy, $const, $progress ) = @_;
433 0           my $count = $progress->set_progress_bar(); #
434 0           my @col_idx = ( 0 .. $#{$tbl_copy->[0]} );
  0            
435 0           my $col_count = @col_idx;
436 0           my $w_col_names = [];
437 0           my $w_cols = [ ( 1 ) x $col_count ];
438 0           my $w_int = [ ( 0 ) x $col_count ];
439 0           my $w_fract = [ ( 0 ) x $col_count ];
440 0           my $regex_number = $const->{regex_number};
441 0           my $col_names = shift @$tbl_copy;
442 0           for my $col ( @col_idx ) {
443 0           $w_col_names->[$col] = print_columns( $col_names->[$col] );
444             }
445              
446 0           for my $row ( 0 .. $#$tbl_copy ) {
447 0           for my $col ( @col_idx ) {
448 0 0         if ( ! length $tbl_copy->[$row][$col] ) {
    0          
449             # nothing to do
450             }
451             elsif ( looks_like_number $tbl_copy->[$row][$col] ) {
452 0 0         if ( $tbl_copy->[$row][$col] =~ /$regex_number/ ) {
453 0 0 0       if ( ( length $1 // 0 ) > $w_int->[$col] ) {
454 0           $w_int->[$col] = length $1;
455             }
456 0 0 0       if ( ( length $2 // 0 ) > $w_fract->[$col] ) {
457 0           $w_fract->[$col] = length $2;
458             }
459             }
460             else {
461             # scientific notation, NaN, Inf, Infinity
462 0 0         if ( length $tbl_copy->[$row][$col] > $w_cols->[$col] ) {
463 0           $w_cols->[$col] = length $tbl_copy->[$row][$col];
464             }
465             }
466             }
467             else {
468 0           my $str_w = print_columns( $tbl_copy->[$row][$col] );
469 0 0         if ( $str_w > $w_cols->[$col] ) {
470 0           $w_cols->[$col] = $str_w;
471             }
472             }
473             }
474 0 0         if ( $progress->{count_progress_bars} ) { #
475 0 0         if ( $count >= $progress->{next_update} ) { #
476 0           $progress->update_progress_bar( $count ); #
477             } #
478 0           ++$count; #
479             } #
480             }
481 0           for my $col ( @col_idx ) {
482 0 0         if ( $w_int->[$col] + $w_fract->[$col] > $w_cols->[$col] ) {
483 0           $w_cols->[$col] = $w_int->[$col] + $w_fract->[$col];
484             }
485             }
486 0           unshift @$tbl_copy, $col_names;
487 0 0         if ( $progress->{count_progress_bars} ) { #
488 0           $progress->last_update_progress_bar( $count ); #
489             } #
490 0           return $w_col_names, $w_cols, $w_int, $w_fract;
491             }
492              
493              
494             sub __calc_avail_col_width {
495 0     0     my ( $self, $term_w, $tbl_copy, $w_col_names, $w_cols, $w_int, $w_fract ) = @_;
496 0           my $w_cols_calc = [ @{$w_cols} ];
  0            
497 0           my $avail_w = $term_w - $self->{tab_w} * $#$w_cols_calc;
498 0           my $sum = sum( @$w_cols_calc );
499 0 0         if ( $sum < $avail_w ) {
    0          
500              
501 0           HEAD: while ( 1 ) {
502 0           my $prev_sum = $sum;
503 0           for my $col ( 0 .. $#$w_col_names ) {
504 0 0         if ( $w_col_names->[$col] > $w_cols_calc->[$col] ) {
505 0           ++$w_cols_calc->[$col];
506 0           ++$sum;
507 0 0         if ( $sum == $avail_w ) {
508 0           last HEAD;
509             }
510             }
511             }
512 0 0         if ( $sum == $prev_sum ) {
513 0           last HEAD;
514             }
515             }
516             }
517             elsif ( $sum > $avail_w ) {
518 0 0         if ( $self->{trunc_fract_first} ) {
519              
520 0           TRUNC_FRACT: while ( $sum > $avail_w ) {
521 0           my $prev_sum = $sum;
522 0           for my $col ( 0 .. $#$w_cols_calc ) {
523 0 0 0       if ( $w_fract->[$col] && $w_fract->[$col] > 3 # 3 == 1 decimal separator + 2 decimal places
524             #&& $w_int->[$col] + $w_fract->[$col] == $w_cols_calc->[$col] #
525             ## the column width could be larger than w_int + w_fract, if the column contains non-digit strings
526             ) {
527 0           --$w_fract->[$col];
528 0           --$w_cols_calc->[$col];
529 0           --$sum;
530 0 0         if ( $sum == $avail_w ) {
531 0           last TRUNC_FRACT;
532             }
533             }
534             }
535 0 0         if ( $sum == $prev_sum ) {
536 0           last TRUNC_FRACT;
537             }
538             }
539             }
540 0 0         my $min_col_width = $self->{min_col_width} < 2 ? 2 : $self->{min_col_width}; # n
541 0           my $percent = 4;
542              
543 0           TRUNC_COLS: while ( $sum > $avail_w ) {
544 0           ++$percent;
545 0           for my $col ( 0 .. $#$w_cols_calc ) {
546 0 0         if ( $w_cols_calc->[$col] > $min_col_width ) {
547 0           my $reduced_col_w = _minus_x_percent( $w_cols_calc->[$col], $percent );
548 0 0         if ( $reduced_col_w < $min_col_width ) {
549 0           $reduced_col_w = $min_col_width;
550             }
551 0 0         if ( $w_fract->[$col] > 2 ) {
552 0           $w_fract->[$col] -= $w_cols_calc->[$col] - $reduced_col_w;
553 0 0         if ( $w_fract->[$col] < 2 ) {
554 0           $w_fract->[$col] = 2;
555             }
556             }
557             #if ( $w_fract->[$col] > 0 ) {
558             # $w_fract->[$col] -= $w_cols_calc->[$col] - $reduced_col_w;
559             # if ( $w_fract->[$col] < 1 ) {
560             # $w_fract->[$col] = "0 but true";
561             # # keep it true eaven if it is 0 for __cols_to_string to work properly.
562             # }
563             #}
564 0           $w_cols_calc->[$col] = $reduced_col_w;
565             }
566             }
567 0           my $prev_sum = $sum;
568 0           $sum = sum( @$w_cols_calc );
569 0 0         if ( $sum == $prev_sum ) {
570 0           --$min_col_width;
571 0 0         if ( $min_col_width == 2 ) { # a character could have a print width of 2
572 0           $self->__print_term_not_wide_enough_message( $tbl_copy );
573 0           return;
574             }
575             }
576             }
577 0           my $remainder_w = $avail_w - $sum;
578 0 0         if ( $remainder_w ) {
579              
580 0           REMAINDER_W: while ( 1 ) {
581 0           my $prev_remainder_w = $remainder_w;
582 0           for my $col ( 0 .. $#$w_cols_calc ) {
583 0 0         if ( $w_cols_calc->[$col] < $w_cols->[$col] ) {
584 0           ++$w_cols_calc->[$col];
585 0           --$remainder_w;
586 0 0         if ( $remainder_w == 0 ) {
587 0           last REMAINDER_W;
588             }
589             }
590             }
591 0 0         if ( $remainder_w == $prev_remainder_w ) {
592 0           last REMAINDER_W;
593             }
594             }
595             }
596             }
597             #else {
598             # #$sum == $avail_w, nothing to do
599             #}
600 0           return $w_cols_calc;
601             }
602              
603             sub __cols_to_string {
604 0     0     my ( $self, $tbl_orig, $tbl_copy, $w_cols_calc, $w_fract, $const, $progress ) = @_;
605 0           my $count = $progress->set_progress_bar(); #
606 0           my $tab = ( ' ' x int( $self->{tab_w} / 2 ) ) . '|' . ( ' ' x int( $self->{tab_w} / 2 ) );
607 0           my $regex_number = $const->{regex_number};
608 0           my $one_precision_w = length sprintf "%.1e", 123;
609              
610 0           ROW: for my $row ( 0 .. $#{$tbl_copy} ) {
  0            
611 0           my $str = '';
612 0           COL: for my $col ( 0 .. $#{$w_cols_calc} ) {
  0            
613 0 0         if ( ! length $tbl_copy->[$row][$col] ) {
    0          
614 0           $str = $str . ' ' x $w_cols_calc->[$col];
615             }
616             elsif ( looks_like_number $tbl_copy->[$row][$col] ) {
617 0           my $number = '';
618 0 0         if ( $w_fract->[$col] ) {
619 0           my $fract = '';
620 0 0         if ( $tbl_copy->[$row][$col] =~ /$regex_number/ ) {
621 0 0         if ( length $2 ) {
622 0 0         if ( length $2 > $w_fract->[$col] ) {
    0          
623 0           $fract = substr( $2, 0, $w_fract->[$col] );
624             }
625             elsif ( length $2 < $w_fract->[$col] ) {
626 0           $fract = $2 . ' ' x ( $w_fract->[$col] - length $2 );
627             }
628             else {
629 0           $fract = $2;
630             }
631             }
632             else {
633 0           $fract = ' ' x $w_fract->[$col];
634             }
635 0 0         $number = ( length $1 ? $1 : '' ) . $fract;
636             }
637             else {
638             # scientific notation, NaN, Inf, Infinity, '0 but true'
639 0           $number = $tbl_copy->[$row][$col];
640             }
641             }
642             else {
643 0           $number = $tbl_copy->[$row][$col];
644             }
645 0 0         if ( length $number > $w_cols_calc->[$col] ) {
    0          
646 0 0         my $signed_1_precision_w = $one_precision_w + ( $number =~ /^-/ ? 1 : 0 );
647 0           my $precision;
648 0 0         if ( $w_cols_calc->[$col] < $signed_1_precision_w ) {
649             # special treatment because zero precision has no dot
650 0           $precision = 0;
651             }
652             else {
653 0           $precision = $w_cols_calc->[$col] - ( $signed_1_precision_w - 1 );
654             }
655 0           $number = sprintf "%.*e", $precision, $number;
656             # if $number is a scientific-notation-string which is to big for a conversation to a number
657             # 'sprintf' returns 'Inf' instead of reducing the precision.
658 0 0         if ( length( $number ) > $w_cols_calc->[$col] ) {
    0          
659 0           $str = $str . ( '-' x $w_cols_calc->[$col] );
660             }
661             elsif ( length $number < $w_cols_calc->[$col] ) {
662             # if $w_cols_calc->[$col] == zero_precision_w + 1 or if $number == Inf
663 0           $str = $str . ' ' x ( $w_cols_calc->[$col] - length $number ) . $number;
664             }
665             else {
666 0           $str = $str . $number;
667             }
668             }
669             elsif ( length $number < $w_cols_calc->[$col] ) {
670 0           $str = $str . ' ' x ( $w_cols_calc->[$col] - length $number ) . $number;
671             }
672             else {
673 0           $str = $str . $number;
674             }
675             }
676             else {
677 0           my $str_w = print_columns( $tbl_copy->[$row][$col] );
678 0 0         if ( $str_w > $w_cols_calc->[$col] ) {
    0          
679 0           $str = $str . cut_to_printwidth( $tbl_copy->[$row][$col], $w_cols_calc->[$col] );
680             }
681             elsif ( $str_w < $w_cols_calc->[$col] ) {
682 0           $str = $str . $tbl_copy->[$row][$col] . ' ' x ( $w_cols_calc->[$col] - $str_w );
683             }
684             else {
685 0           $str = $str . $tbl_copy->[$row][$col];
686             }
687             }
688 0 0         if ( $self->{color} ) {
689 0 0         if ( defined $tbl_orig->[$row][$col] ) {
690 0           my @color = $tbl_orig->[$row][$col] =~ /(\e\[[\d;]*m)/g;
691 0           $str =~ s/\x{feff}/shift @color/ge;
  0            
692 0 0         if ( @color ) {
693 0           $str = $str . $color[-1];
694             }
695             }
696             }
697 0 0         if ( $col != $#$w_cols_calc ) {
698 0           $str = $str . $tab;
699             }
700             }
701 0           $tbl_copy->[$row] = $str; # overwrite $tbl_copy to save memory
702 0 0         if ( $progress->{count_progress_bars} ) { #
703 0 0         if ( $count >= $progress->{next_update} ) { #
704 0           $progress->update_progress_bar( $count ); #
705             } #
706 0           ++$count; #
707             } #
708             }
709 0 0         if ( $progress->{count_progress_bars} ) { #
710 0           $progress->last_update_progress_bar( $count ); #
711             } #
712 0           return $tbl_copy; # $tbl_copy is now $tbl_print
713             }
714              
715              
716             sub __print_single_row {
717 0     0     my ( $self, $tbl_orig, $row, $w_col_names, $footer ) = @_;
718 0           my $term_w = get_term_width();
719 0           my $max_key_w = max( @{$w_col_names} ) + 1;
  0            
720 0 0         if ( $max_key_w > int( $term_w / 3 ) ) {
721 0           $max_key_w = int( $term_w / 3 );
722             }
723 0           my $separator = ' : ';
724 0           my $sep_w = length( $separator );
725 0           my $max_value_w = $term_w - ( $max_key_w + $sep_w + 1 );
726 0           my $separator_row = ' ';
727 0           my $row_data = [ ' Close with ENTER' ];
728 0           my $last_color_prev_value;
729              
730 0           for my $col ( 0 .. $#{$tbl_orig->[0]} ) {
  0            
731 0           push @$row_data, $separator_row;
732 0   0       my $key = $tbl_orig->[0][$col] // $self->{undef};
733 0           my @key_color;
734 0 0         if ( $self->{color} ) {
735 0           $key =~ s/\x{feff}//g;
736 0 0         $key =~ s/(\e\[[\d;]*m)/push( @key_color, $1 ) && "\x{feff}"/ge;
  0            
737             }
738 0 0 0       if ( $self->{binary_filter} && substr( $key, 0, 100 ) =~ /[\x00-\x08\x0B-\x0C\x0E-\x1F]/ ) {
739             #$key = $self->{binary_filter} == 2 ? sprintf("%v02X", $key) =~ tr/./ /r : $self->{binary_string}; # perl 5.14
740 0 0         if ( $self->{binary_filter} == 2 ) {
741 0           ( $key = sprintf("%v02X", $key) ) =~ tr/./ /;
742             }
743             else {
744 0           $key = $self->{binary_string};
745             }
746             }
747 0           $key =~ s/\t/ /g;
748 0           $key =~ s/\v+/\ \ /g;
749 0           $key =~ s/[\p{Cc}\p{Noncharacter_Code_Point}\p{Cs}]//g;
750 0           my $key_w = print_columns( $key );
751 0 0         if ( $key_w > $max_key_w ) {
    0          
752 0           $key = cut_to_printwidth( $key, $max_key_w );
753             }
754             elsif ( $key_w < $max_key_w ) {
755 0           $key = ( ' ' x ( $max_key_w - $key_w ) ) . $key;
756             }
757 0 0         if ( @key_color ) {
758 0           $key =~ s/\x{feff}/shift @key_color/ge;
  0            
759 0           $key = $key . "\e[0m";
760             }
761 0           my $value = $tbl_orig->[$row][$col];
762             # $value: color and invalid char handling in `line_fold`
763 0 0         if ( ! length $value ) {
764 0           $value = ' '; # to show also keys/columns with no values
765             }
766 0 0         if ( ref $value ) {
767 0           $value = _handle_reference( $value );
768             }
769 0 0         if ( $self->{color} ) {
770             # color is reset only at the end of a table row
771 0 0 0       if ( $col && length $tbl_orig->[$row][$col-1] ) {
772 0   0       $last_color_prev_value = ( $tbl_orig->[$row][$col-1] =~ /(\e\[[\d;]*m)/g )[-1] // $last_color_prev_value;
773             }
774 0 0         if ( $last_color_prev_value ) {
775 0           $value = $last_color_prev_value . $value;
776             }
777             }
778 0           my $subseq_tab = ' ' x ( $max_key_w + $sep_w );
779 0           my $count;
780              
781 0           for my $line ( line_fold( $value, $max_value_w, { join => 0, color => $self->{color}, binary_filter => $self->{binary_filter} } ) ) {
782 0 0         if ( ! $count++ ) {
783 0           push @$row_data, $key . $separator . $line;
784             }
785             else {
786 0           push @$row_data, $subseq_tab . $line;
787             }
788             }
789             }
790 0           my $regex = qr/^\Q$separator_row\E\z/;
791             # Choose
792             choose(
793             $row_data,
794             { prompt => '', layout => 2, clear_screen => 1, mouse => $self->{mouse}, hide_cursor => 0, empty => ' ',
795             search => $self->{search}, skip_items => $regex, footer => $footer, page => $self->{page},
796             color => $self->{color} }
797 0           );
798             }
799              
800              
801             sub __search {
802 0     0     my ( $self, $tbl_orig, $const, $search ) = @_;
803 0 0         if ( ! $self->{search} ) {
804 0           return;
805             }
806 0           require Term::Form::ReadLine;
807 0           Term::Form::ReadLine->VERSION(0.544);
808 0           my $term = Term::Form::ReadLine->new();
809 0           my $error_message;
810 0           my $prompt = '> search-pattern: ';
811 0           my $default = '';
812              
813 0           READ: while ( 1 ) {
814 0 0         my $string = $term->readline(
815             $prompt,
816             { info => $error_message, hide_cursor => 2, clear_screen => defined $error_message ? 1 : 2,
817             default => $default }
818             );
819 0 0         if ( ! length $string ) {
820 0           return;
821             }
822 0           print "\r${prompt}${string}";
823 0 0         if ( ! eval {
824 0 0         $search->{filter} = $self->{search} == 1 ? qr/$string/i : qr/$string/;
825 0           'Teststring' =~ $search->{filter};
826 0           1
827             } ) {
828 0 0         $default = $default eq $string ? '' : $string;
829 0           $error_message = "$@";
830 0           next READ;
831             }
832 0           last READ;
833             }
834 1     1   5230 no warnings 'uninitialized';
  1         2  
  1         644  
835 0           my @col_idx = ( 0 .. $#{$tbl_orig->[0]} );
  0            
836             # begin: "1" to skipp the header row
837             # end: "data_row_count" as it its because +1 for the header row and -1 to get the 0-based index
838 0           for my $idx_row ( 1 .. $const->{data_row_count} ) {
839 0           for ( @col_idx ) {
840 0 0         if ( $tbl_orig->[$idx_row][$_] =~ /$search->{filter}/ ) {
841 0           push @{$search->{map_indexes}}, $idx_row;
  0            
842 0           last;
843             }
844             }
845             }
846 0 0         if ( ! @{$search->{map_indexes}} ) {
  0            
847 0           my $message = '/' . $search->{filter} . '/: No matches found.';
848             # Choose
849 0           choose(
850             [ 'Continue with ENTER' ],
851             { prompt => $message, layout => 0, clear_screen => 1 }
852             );
853 0           $search->{filter} = '';
854 0           return;
855             }
856 0           return;
857             }
858              
859              
860             sub __reset_search {
861 0     0     my ( $self, $search ) = @_;
862 0           $search->{map_indexes} = [];
863 0           $search->{filter} = '';
864             }
865              
866              
867             sub __header_sep {
868 0     0     my ( $self, $w_cols_calc ) = @_;
869 0           my $tab = ( '-' x int( $self->{tab_w} / 2 ) ) . '|' . ( '-' x int( $self->{tab_w} / 2 ) );
870 0           my $header_sep = '';
871 0           for my $col ( 0 .. $#$w_cols_calc ) {
872 0           $header_sep .= '-' x $w_cols_calc->[$col];
873 0 0         if ( $col != $#$w_cols_calc ) {
874 0           $header_sep .= $tab;
875             }
876             }
877 0           return $header_sep;
878             }
879              
880              
881             sub _handle_reference {
882 0     0     require Data::Dumper;
883 0           local $Data::Dumper::Useqq = 1;
884 0           local $Data::Dumper::Indent = 0;
885 0           local $Data::Dumper::Terse = 1;
886 0           local $Data::Dumper::Maxdepth = 2;
887 0           return 'ref: ' . Data::Dumper::Dumper( $_[0] );
888             }
889              
890              
891             sub __print_term_not_wide_enough_message {
892 0     0     my ( $self, $tbl_copy ) = @_;
893 0           my $prompt_1 = 'To many columns - terminal window is not wide enough.';
894             # Choose
895             choose(
896             [ 'Press ENTER to show the column names.' ],
897 0           { prompt => $prompt_1, clear_screen => 1, mouse => $self->{mouse}, hide_cursor => 0 }
898             );
899 0           my $prompt_2 = 'Column names (close with ENTER).';
900             # Choose
901             choose(
902             $tbl_copy->[0],
903             { prompt => $prompt_2, clear_screen => 1, mouse => $self->{mouse}, hide_cursor => 0, search => $self->{search} }
904 0           );
905             }
906              
907              
908             sub _minus_x_percent {
909             #my ( $value, $percent ) = @_;
910 0   0 0     return int( $_[0] - ( $_[0] / 100 * $_[1] ) ) || 1;
911             }
912              
913              
914              
915              
916              
917              
918              
919              
920             1;
921              
922             __END__