File Coverage

blib/lib/Term/TablePrint.pm
Criterion Covered Total %
statement 45 525 8.5
branch 1 282 0.3
condition 0 45 0.0
subroutine 16 35 45.7
pod 2 2 100.0
total 64 889 7.2


line stmt bran cond sub pod time code
1             package Term::TablePrint;
2              
3 1     1   69809 use warnings;
  1         2  
  1         31  
4 1     1   5 use strict;
  1         1  
  1         18  
5 1     1   10 use 5.10.0;
  1         4  
6              
7             our $VERSION = '0.161';
8 1     1   7 use Exporter 'import';
  1         12  
  1         51  
9             our @EXPORT_OK = qw( print_table );
10              
11 1     1   6 use Carp qw( croak );
  1         2  
  1         54  
12              
13 1     1   7 use List::Util qw( sum max );
  1         2  
  1         134  
14 1     1   7 use Scalar::Util qw( looks_like_number );
  1         1  
  1         47  
15              
16 1     1   816 use Term::Choose qw( choose );
  1         116936  
  1         121  
17 1     1   19 use Term::Choose::Constants qw( WIDTH_CURSOR );
  1         3  
  1         47  
18 1     1   30 use Term::Choose::LineFold qw( line_fold cut_to_printwidth print_columns );
  1         3  
  1         65  
19 1     1   6 use Term::Choose::Screen qw( hide_cursor show_cursor );
  1         2  
  1         47  
20 1     1   18 use Term::Choose::ValidateOptions qw( validate_options );
  1         4  
  1         40  
21 1     1   663 use Term::Choose::Util qw( get_term_width insert_sep );
  1         31238  
  1         74  
22 1     1   546 use Term::TablePrint::ProgressBar qw();
  1         3  
  1         54  
23              
24              
25             BEGIN {
26 1 50   1   2051 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 0 0         if ( $self->{binary_filter} == 2 ) {
401 0   0       ( $str = sprintf("%v02X", $_ // $self->{undef} ) ) =~ tr/./ /;
402             }
403             else {
404 0           $str = $self->{binary_string};
405             }
406             }
407 0           $str =~ s/\t/ /g;
408 0           $str =~ s/\v+/\ \ /g;
409 0           $str =~ s/[\p{Cc}\p{Noncharacter_Code_Point}\p{Cs}]//g;
410 0           push @$tmp_row, $str;
411             }
412 0           push @$tbl_copy, $tmp_row;
413 0 0         if ( @$tbl_copy == $self->{max_rows} ) {
414 0           last;
415             }
416 0 0         if ( $progress->{count_progress_bars} ) { #
417 0 0         if ( $count >= $progress->{next_update} ) { #
418 0           $progress->update_progress_bar( $count ); #
419             } #
420 0           ++$count; #
421             } #
422             }
423 0 0         if ( $progress->{count_progress_bars} ) { #
424 0           $progress->last_update_progress_bar( $count ); #
425             } #
426 0           return $tbl_copy
427             }
428              
429              
430             sub __calc_col_width {
431 0     0     my ( $self, $tbl_copy, $const, $progress ) = @_;
432 0           my $count = $progress->set_progress_bar(); #
433 0           my @col_idx = ( 0 .. $#{$tbl_copy->[0]} );
  0            
434 0           my $col_count = @col_idx;
435 0           my $w_col_names = [];
436 0           my $w_cols = [ ( 1 ) x $col_count ];
437 0           my $w_int = [ ( 0 ) x $col_count ];
438 0           my $w_fract = [ ( 0 ) x $col_count ];
439 0           my $regex_number = $const->{regex_number};
440 0           my $col_names = shift @$tbl_copy;
441 0           for my $col ( @col_idx ) {
442 0           $w_col_names->[$col] = print_columns( $col_names->[$col] );
443             }
444              
445 0           for my $row ( 0 .. $#$tbl_copy ) {
446 0           for my $col ( @col_idx ) {
447 0 0         if ( ! length $tbl_copy->[$row][$col] ) {
    0          
448             # nothing to do
449             }
450             elsif ( looks_like_number $tbl_copy->[$row][$col] ) {
451 0 0         if ( $tbl_copy->[$row][$col] =~ /$regex_number/ ) {
452 0 0 0       if ( ( length $1 // 0 ) > $w_int->[$col] ) {
453 0           $w_int->[$col] = length $1;
454             }
455 0 0 0       if ( ( length $2 // 0 ) > $w_fract->[$col] ) {
456 0           $w_fract->[$col] = length $2;
457             }
458             }
459             else {
460             # scientific notation, NaN, Inf, Infinity
461 0 0         if ( length $tbl_copy->[$row][$col] > $w_cols->[$col] ) {
462 0           $w_cols->[$col] = length $tbl_copy->[$row][$col];
463             }
464             }
465             }
466             else {
467 0           my $str_w = print_columns( $tbl_copy->[$row][$col] );
468 0 0         if ( $str_w > $w_cols->[$col] ) {
469 0           $w_cols->[$col] = $str_w;
470             }
471             }
472             }
473 0 0         if ( $progress->{count_progress_bars} ) { #
474 0 0         if ( $count >= $progress->{next_update} ) { #
475 0           $progress->update_progress_bar( $count ); #
476             } #
477 0           ++$count; #
478             } #
479             }
480 0           for my $col ( @col_idx ) {
481 0 0         if ( $w_int->[$col] + $w_fract->[$col] > $w_cols->[$col] ) {
482 0           $w_cols->[$col] = $w_int->[$col] + $w_fract->[$col];
483             }
484             }
485 0           unshift @$tbl_copy, $col_names;
486 0 0         if ( $progress->{count_progress_bars} ) { #
487 0           $progress->last_update_progress_bar( $count ); #
488             } #
489 0           return $w_col_names, $w_cols, $w_int, $w_fract;
490             }
491              
492              
493             sub __calc_avail_col_width {
494 0     0     my ( $self, $term_w, $tbl_copy, $w_col_names, $w_cols, $w_int, $w_fract ) = @_;
495 0           my $w_cols_calc = [ @{$w_cols} ];
  0            
496 0           my $avail_w = $term_w - $self->{tab_w} * $#$w_cols_calc;
497 0           my $sum = sum( @$w_cols_calc );
498 0 0         if ( $sum < $avail_w ) {
    0          
499              
500 0           HEAD: while ( 1 ) {
501 0           my $prev_sum = $sum;
502 0           for my $col ( 0 .. $#$w_col_names ) {
503 0 0         if ( $w_col_names->[$col] > $w_cols_calc->[$col] ) {
504 0           ++$w_cols_calc->[$col];
505 0           ++$sum;
506 0 0         if ( $sum == $avail_w ) {
507 0           last HEAD;
508             }
509             }
510             }
511 0 0         if ( $sum == $prev_sum ) {
512 0           last HEAD;
513             }
514             }
515             }
516             elsif ( $sum > $avail_w ) {
517 0 0         if ( $self->{trunc_fract_first} ) {
518              
519 0           TRUNC_FRACT: while ( $sum > $avail_w ) {
520 0           my $prev_sum = $sum;
521 0           for my $col ( 0 .. $#$w_cols_calc ) {
522 0 0 0       if ( $w_fract->[$col] && $w_fract->[$col] > 3 # 3 == 1 decimal separator + 2 decimal places
523             #&& $w_int->[$col] + $w_fract->[$col] == $w_cols_calc->[$col] #
524             ## the column width could be larger than w_int + w_fract, if the column contains non-digit strings
525             ) {
526 0           --$w_fract->[$col];
527 0           --$w_cols_calc->[$col];
528 0           --$sum;
529 0 0         if ( $sum == $avail_w ) {
530 0           last TRUNC_FRACT;
531             }
532             }
533             }
534 0 0         if ( $sum == $prev_sum ) {
535 0           last TRUNC_FRACT;
536             }
537             }
538             }
539 0 0         my $min_col_width = $self->{min_col_width} < 2 ? 2 : $self->{min_col_width}; # n
540 0           my $percent = 4;
541              
542 0           TRUNC_COLS: while ( $sum > $avail_w ) {
543 0           ++$percent;
544 0           for my $col ( 0 .. $#$w_cols_calc ) {
545 0 0         if ( $w_cols_calc->[$col] > $min_col_width ) {
546 0           my $reduced_col_w = _minus_x_percent( $w_cols_calc->[$col], $percent );
547 0 0         if ( $reduced_col_w < $min_col_width ) {
548 0           $reduced_col_w = $min_col_width;
549             }
550 0 0         if ( $w_fract->[$col] > 2 ) {
551 0           $w_fract->[$col] -= $w_cols_calc->[$col] - $reduced_col_w;
552 0 0         if ( $w_fract->[$col] < 2 ) {
553 0           $w_fract->[$col] = 2;
554             }
555             }
556             #if ( $w_fract->[$col] > 0 ) {
557             # $w_fract->[$col] -= $w_cols_calc->[$col] - $reduced_col_w;
558             # if ( $w_fract->[$col] < 1 ) {
559             # $w_fract->[$col] = "0 but true";
560             # # keep it true eaven if it is 0 for __cols_to_string to work properly.
561             # }
562             #}
563 0           $w_cols_calc->[$col] = $reduced_col_w;
564             }
565             }
566 0           my $prev_sum = $sum;
567 0           $sum = sum( @$w_cols_calc );
568 0 0         if ( $sum == $prev_sum ) {
569 0           --$min_col_width;
570 0 0         if ( $min_col_width == 2 ) { # a character could have a print width of 2
571 0           $self->__print_term_not_wide_enough_message( $tbl_copy );
572 0           return;
573             }
574             }
575             }
576 0           my $remainder_w = $avail_w - $sum;
577 0 0         if ( $remainder_w ) {
578              
579 0           REMAINDER_W: while ( 1 ) {
580 0           my $prev_remainder_w = $remainder_w;
581 0           for my $col ( 0 .. $#$w_cols_calc ) {
582 0 0         if ( $w_cols_calc->[$col] < $w_cols->[$col] ) {
583 0           ++$w_cols_calc->[$col];
584 0           --$remainder_w;
585 0 0         if ( $remainder_w == 0 ) {
586 0           last REMAINDER_W;
587             }
588             }
589             }
590 0 0         if ( $remainder_w == $prev_remainder_w ) {
591 0           last REMAINDER_W;
592             }
593             }
594             }
595             }
596             #else {
597             # #$sum == $avail_w, nothing to do
598             #}
599 0           return $w_cols_calc;
600             }
601              
602             sub __cols_to_string {
603 0     0     my ( $self, $tbl_orig, $tbl_copy, $w_cols_calc, $w_fract, $const, $progress ) = @_;
604 0           my $count = $progress->set_progress_bar(); #
605 0           my $tab = ( ' ' x int( $self->{tab_w} / 2 ) ) . '|' . ( ' ' x int( $self->{tab_w} / 2 ) );
606 0           my $regex_number = $const->{regex_number};
607 0           my $one_precision_w = length sprintf "%.1e", 123;
608              
609 0           ROW: for my $row ( 0 .. $#{$tbl_copy} ) {
  0            
610 0           my $str = '';
611 0           COL: for my $col ( 0 .. $#{$w_cols_calc} ) {
  0            
612 0 0         if ( ! length $tbl_copy->[$row][$col] ) {
    0          
613 0           $str = $str . ' ' x $w_cols_calc->[$col];
614             }
615             elsif ( looks_like_number $tbl_copy->[$row][$col] ) {
616 0           my $number = '';
617 0 0         if ( $w_fract->[$col] ) {
618 0           my $fract = '';
619 0 0         if ( $tbl_copy->[$row][$col] =~ /$regex_number/ ) {
620 0 0         if ( length $2 ) {
621 0 0         if ( length $2 > $w_fract->[$col] ) {
    0          
622 0           $fract = substr( $2, 0, $w_fract->[$col] );
623             }
624             elsif ( length $2 < $w_fract->[$col] ) {
625 0           $fract = $2 . ' ' x ( $w_fract->[$col] - length $2 );
626             }
627             else {
628 0           $fract = $2;
629             }
630             }
631             else {
632 0           $fract = ' ' x $w_fract->[$col];
633             }
634 0 0         $number = ( length $1 ? $1 : '' ) . $fract;
635             }
636             else {
637             # scientific notation, NaN, Inf, Infinity, '0 but true'
638 0           $number = $tbl_copy->[$row][$col];
639             }
640             }
641             else {
642 0           $number = $tbl_copy->[$row][$col];
643             }
644 0 0         if ( length $number > $w_cols_calc->[$col] ) {
    0          
645 0 0         my $signed_1_precision_w = $one_precision_w + ( $number =~ /^-/ ? 1 : 0 );
646 0           my $precision;
647 0 0         if ( $w_cols_calc->[$col] < $signed_1_precision_w ) {
648             # special treatment because zero precision has no dot
649 0           $precision = 0;
650             }
651             else {
652 0           $precision = $w_cols_calc->[$col] - ( $signed_1_precision_w - 1 );
653             }
654 0           $number = sprintf "%.*e", $precision, $number;
655             # if $number is a scientific-notation-string which is to big for a conversation to a number
656             # 'sprintf' returns 'Inf' instead of reducing the precision.
657 0 0         if ( length( $number ) > $w_cols_calc->[$col] ) {
    0          
658 0           $str = $str . ( '-' x $w_cols_calc->[$col] );
659             }
660             elsif ( length $number < $w_cols_calc->[$col] ) {
661             # if $w_cols_calc->[$col] == zero_precision_w + 1 or if $number == Inf
662 0           $str = $str . ' ' x ( $w_cols_calc->[$col] - length $number ) . $number;
663             }
664             else {
665 0           $str = $str . $number;
666             }
667             }
668             elsif ( length $number < $w_cols_calc->[$col] ) {
669 0           $str = $str . ' ' x ( $w_cols_calc->[$col] - length $number ) . $number;
670             }
671             else {
672 0           $str = $str . $number;
673             }
674             }
675             else {
676 0           my $str_w = print_columns( $tbl_copy->[$row][$col] );
677 0 0         if ( $str_w > $w_cols_calc->[$col] ) {
    0          
678 0           $str = $str . cut_to_printwidth( $tbl_copy->[$row][$col], $w_cols_calc->[$col] );
679             }
680             elsif ( $str_w < $w_cols_calc->[$col] ) {
681 0           $str = $str . $tbl_copy->[$row][$col] . ' ' x ( $w_cols_calc->[$col] - $str_w );
682             }
683             else {
684 0           $str = $str . $tbl_copy->[$row][$col];
685             }
686             }
687 0 0         if ( $self->{color} ) {
688 0 0         if ( defined $tbl_orig->[$row][$col] ) {
689 0           my @color = $tbl_orig->[$row][$col] =~ /(\e\[[\d;]*m)/g;
690 0 0         if ( @color ) {
691 0           $str =~ s/\x{feff}/shift @color/ge;
  0            
692 0           $str .= "\e[0m";
693             }
694             #if ( @color ) {
695             # if ( $color[-1] !~ /^\e\[0?m/ ) {
696             # push @color, "\e[0m";
697             # }
698             # $str =~ s/\x{feff}/shift @color/ge;
699             # if ( @color ) {
700             # $str .= $color[-1];
701             # }
702             #}
703             }
704             }
705 0 0         if ( $col != $#$w_cols_calc ) {
706 0           $str = $str . $tab;
707             }
708             }
709 0           $tbl_copy->[$row] = $str; # overwrite $tbl_copy to save memory
710 0 0         if ( $progress->{count_progress_bars} ) { #
711 0 0         if ( $count >= $progress->{next_update} ) { #
712 0           $progress->update_progress_bar( $count ); #
713             } #
714 0           ++$count; #
715             } #
716             }
717 0 0         if ( $progress->{count_progress_bars} ) { #
718 0           $progress->last_update_progress_bar( $count ); #
719             } #
720 0           return $tbl_copy; # $tbl_copy is now $tbl_print
721             }
722              
723              
724             sub __print_single_row {
725 0     0     my ( $self, $tbl_orig, $row, $w_col_names, $footer ) = @_;
726 0           my $term_w = get_term_width();
727 0           my $max_key_w = max( @{$w_col_names} ) + 1;
  0            
728 0 0         if ( $max_key_w > int( $term_w / 3 ) ) {
729 0           $max_key_w = int( $term_w / 3 );
730             }
731 0           my $separator = ' : ';
732 0           my $sep_w = length( $separator );
733 0           my $max_value_w = $term_w - ( $max_key_w + $sep_w + 1 );
734 0           my $separator_row = ' ';
735 0           my $row_data = [ ' Close with ENTER' ];
736              
737 0           for my $col ( 0 .. $#{$tbl_orig->[0]} ) {
  0            
738 0           push @$row_data, $separator_row;
739 0   0       my $key = $tbl_orig->[0][$col] // $self->{undef};
740 0           my @key_color;
741 0 0         if ( $self->{color} ) {
742 0           $key =~ s/\x{feff}//g;
743 0 0         $key =~ s/(\e\[[\d;]*m)/push( @key_color, $1 ) && "\x{feff}"/ge;
  0            
744             }
745 0 0 0       if ( $self->{binary_filter} && substr( $key, 0, 100 ) =~ /[\x00-\x08\x0B-\x0C\x0E-\x1F]/ ) {
746 0 0         if ( $self->{binary_filter} == 2 ) {
747 0   0       ( $key = sprintf("%v02X", $tbl_orig->[0][$col] // $self->{undef} ) ) =~ tr/./ /;
748             }
749             else {
750 0           $key = $self->{binary_string};
751             }
752 0 0         if ( @key_color ) {
753 0           @key_color = ();
754             }
755             }
756 0           $key =~ s/\t/ /g;
757 0           $key =~ s/\v+/\ \ /g;
758 0           $key =~ s/[\p{Cc}\p{Noncharacter_Code_Point}\p{Cs}]//g;
759 0           my $key_w = print_columns( $key );
760 0 0         if ( $key_w > $max_key_w ) {
    0          
761 0           $key = cut_to_printwidth( $key, $max_key_w );
762             }
763             elsif ( $key_w < $max_key_w ) {
764 0           $key = ( ' ' x ( $max_key_w - $key_w ) ) . $key;
765             }
766 0 0         if ( @key_color ) {
767 0           $key =~ s/\x{feff}/shift @key_color/ge;
  0            
768 0           $key .= "\e[0m";
769             }
770 0           my $value = $tbl_orig->[$row][$col];
771             # $value: color and invalid char handling in `line_fold`
772 0 0         if ( ! length $value ) {
773 0           $value = ' '; # to show also keys/columns with no values
774             }
775 0 0         if ( ref $value ) {
776 0           $value = _handle_reference( $value );
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   4354 no warnings 'uninitialized';
  1         3  
  1         673  
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__