452 lines
13 KiB
Perl
452 lines
13 KiB
Perl
package Term::Table;
|
|
use strict;
|
|
use warnings;
|
|
|
|
our $VERSION = '0.015';
|
|
|
|
use Term::Table::Cell();
|
|
|
|
use Term::Table::Util qw/term_size uni_length USE_GCS/;
|
|
use Scalar::Util qw/blessed/;
|
|
use List::Util qw/max sum/;
|
|
use Carp qw/croak carp/;
|
|
|
|
use Term::Table::HashBase qw/rows _columns collapse max_width mark_tail sanitize show_header auto_columns no_collapse header allow_overflow pad/;
|
|
|
|
sub BORDER_SIZE() { 4 } # '| ' and ' |' borders
|
|
sub DIV_SIZE() { 3 } # ' | ' column delimiter
|
|
sub CELL_PAD_SIZE() { 2 } # space on either side of the |
|
|
|
|
sub init {
|
|
my $self = shift;
|
|
|
|
croak "You cannot have a table with no rows"
|
|
unless $self->{+ROWS} && @{$self->{+ROWS}};
|
|
|
|
$self->{+MAX_WIDTH} ||= term_size();
|
|
$self->{+NO_COLLAPSE} ||= {};
|
|
if (ref($self->{+NO_COLLAPSE}) eq 'ARRAY') {
|
|
$self->{+NO_COLLAPSE} = {map { ($_ => 1) } @{$self->{+NO_COLLAPSE}}};
|
|
}
|
|
|
|
if ($self->{+NO_COLLAPSE} && $self->{+HEADER}) {
|
|
my $header = $self->{+HEADER};
|
|
for(my $idx = 0; $idx < @$header; $idx++) {
|
|
$self->{+NO_COLLAPSE}->{$idx} ||= $self->{+NO_COLLAPSE}->{$header->[$idx]};
|
|
}
|
|
}
|
|
|
|
$self->{+PAD} = 4 unless defined $self->{+PAD};
|
|
|
|
$self->{+COLLAPSE} = 1 unless defined $self->{+COLLAPSE};
|
|
$self->{+SANITIZE} = 1 unless defined $self->{+SANITIZE};
|
|
$self->{+MARK_TAIL} = 1 unless defined $self->{+MARK_TAIL};
|
|
|
|
if($self->{+HEADER}) {
|
|
$self->{+SHOW_HEADER} = 1 unless defined $self->{+SHOW_HEADER};
|
|
}
|
|
else {
|
|
$self->{+HEADER} = [];
|
|
$self->{+AUTO_COLUMNS} = 1;
|
|
$self->{+SHOW_HEADER} = 0;
|
|
}
|
|
}
|
|
|
|
sub columns {
|
|
my $self = shift;
|
|
|
|
$self->regen_columns unless $self->{+_COLUMNS};
|
|
|
|
return $self->{+_COLUMNS};
|
|
}
|
|
|
|
sub regen_columns {
|
|
my $self = shift;
|
|
|
|
my $has_header = $self->{+SHOW_HEADER} && @{$self->{+HEADER}};
|
|
my %new_col = (width => 0, count => $has_header ? -1 : 0);
|
|
|
|
my $cols = [map { {%new_col} } @{$self->{+HEADER}}];
|
|
my @rows = @{$self->{+ROWS}};
|
|
|
|
for my $row ($has_header ? ($self->{+HEADER}, @rows) : (@rows)) {
|
|
for my $ci (0 .. max(@$cols - 1, @$row - 1)) {
|
|
$cols->[$ci] ||= {%new_col} if $self->{+AUTO_COLUMNS};
|
|
my $c = $cols->[$ci] or next;
|
|
$c->{idx} ||= $ci;
|
|
$c->{rows} ||= [];
|
|
|
|
my $r = $row->[$ci];
|
|
$r = Term::Table::Cell->new(value => $r)
|
|
unless blessed($r)
|
|
&& ($r->isa('Term::Table::Cell')
|
|
|| $r->isa('Term::Table::CellStack')
|
|
|| $r->isa('Term::Table::Spacer'));
|
|
|
|
$r->sanitize if $self->{+SANITIZE};
|
|
$r->mark_tail if $self->{+MARK_TAIL};
|
|
|
|
my $rs = $r->width;
|
|
$c->{width} = $rs if $rs > $c->{width};
|
|
$c->{count}++ if $rs;
|
|
|
|
push @{$c->{rows}} => $r;
|
|
}
|
|
}
|
|
|
|
# Remove any empty columns we can
|
|
@$cols = grep {$_->{count} > 0 || $self->{+NO_COLLAPSE}->{$_->{idx}}} @$cols
|
|
if $self->{+COLLAPSE};
|
|
|
|
my $current = sum(map {$_->{width}} @$cols);
|
|
my $border = sum(BORDER_SIZE, $self->{+PAD}, DIV_SIZE * (@$cols - 1));
|
|
my $total = $current + $border;
|
|
|
|
if ($total > $self->{+MAX_WIDTH}) {
|
|
my $fair = ($self->{+MAX_WIDTH} - $border) / @$cols;
|
|
if ($fair < 1) {
|
|
return $self->{+_COLUMNS} = $cols if $self->{+ALLOW_OVERFLOW};
|
|
croak "Table is too large ($total including $self->{+PAD} padding) to fit into max-width ($self->{+MAX_WIDTH})";
|
|
}
|
|
|
|
my $under = 0;
|
|
my @fix;
|
|
for my $c (@$cols) {
|
|
if ($c->{width} > $fair) {
|
|
push @fix => $c;
|
|
}
|
|
else {
|
|
$under += $c->{width};
|
|
}
|
|
}
|
|
|
|
# Recalculate fairness
|
|
$fair = int(($self->{+MAX_WIDTH} - $border - $under) / @fix);
|
|
if ($fair < 1) {
|
|
return $self->{+_COLUMNS} = $cols if $self->{+ALLOW_OVERFLOW};
|
|
croak "Table is too large ($total including $self->{+PAD} padding) to fit into max-width ($self->{+MAX_WIDTH})";
|
|
}
|
|
|
|
# Adjust over-long columns
|
|
$_->{width} = $fair for @fix;
|
|
}
|
|
|
|
$self->{+_COLUMNS} = $cols;
|
|
}
|
|
|
|
sub render {
|
|
my $self = shift;
|
|
|
|
my $cols = $self->columns;
|
|
for my $col (@$cols) {
|
|
for my $cell (@{$col->{rows}}) {
|
|
$cell->reset;
|
|
}
|
|
}
|
|
my $width = sum(BORDER_SIZE, $self->{+PAD}, DIV_SIZE * @$cols, map { $_->{width} } @$cols);
|
|
|
|
#<<< NO-TIDY
|
|
my $border = '+' . join('+', map { '-' x ($_->{width} + CELL_PAD_SIZE) } @$cols) . '+';
|
|
my $template = '|' . join('|', map { my $w = $_->{width} + CELL_PAD_SIZE; '%s' } @$cols) . '|';
|
|
my $spacer = '|' . join('|', map { ' ' x ($_->{width} + CELL_PAD_SIZE) } @$cols) . '|';
|
|
#>>>
|
|
|
|
my @out = ($border);
|
|
my ($row, $split, $found) = (0, 0, 0);
|
|
while(1) {
|
|
my @row;
|
|
|
|
my $is_spacer = 0;
|
|
|
|
for my $col (@$cols) {
|
|
my $r = $col->{rows}->[$row];
|
|
unless($r) {
|
|
push @row => '';
|
|
next;
|
|
}
|
|
|
|
my ($v, $vw);
|
|
|
|
if ($r->isa('Term::Table::Cell')) {
|
|
my $lw = $r->border_left_width;
|
|
my $rw = $r->border_right_width;
|
|
$vw = $col->{width} - $lw - $rw;
|
|
$v = $r->break->next($vw);
|
|
}
|
|
elsif ($r->isa('Term::Table::CellStack')) {
|
|
($v, $vw) = $r->break->next($col->{width});
|
|
}
|
|
elsif ($r->isa('Term::Table::Spacer')) {
|
|
$is_spacer = 1;
|
|
}
|
|
|
|
if ($is_spacer) {
|
|
last;
|
|
}
|
|
elsif (defined $v) {
|
|
$found++;
|
|
my $bcolor = $r->border_color || '';
|
|
my $vcolor = $r->value_color || '';
|
|
my $reset = $r->reset_color || '';
|
|
|
|
if (my $need = $vw - uni_length($v)) {
|
|
$v .= ' ' x $need;
|
|
}
|
|
|
|
my $rt = "${reset}${bcolor}\%s${reset} ${vcolor}\%s${reset} ${bcolor}\%s${reset}";
|
|
push @row => sprintf($rt, $r->border_left || '', $v, $r->border_right || '');
|
|
}
|
|
else {
|
|
push @row => ' ' x ($col->{width} + 2);
|
|
}
|
|
}
|
|
|
|
if (!grep {$_ && m/\S/} @row) {
|
|
last unless $found || $is_spacer;
|
|
|
|
push @out => $border if $row == 0 && $self->{+SHOW_HEADER} && @{$self->{+HEADER}};
|
|
push @out => $spacer if $split > 1 || $is_spacer;
|
|
|
|
$row++;
|
|
$split = 0;
|
|
$found = 0;
|
|
|
|
next;
|
|
}
|
|
|
|
if ($split == 1 && @out > 1 && $out[-2] ne $border && $out[-2] ne $spacer) {
|
|
my $last = pop @out;
|
|
push @out => ($spacer, $last);
|
|
}
|
|
|
|
push @out => sprintf($template, @row);
|
|
$split++;
|
|
}
|
|
|
|
pop @out while @out && $out[-1] eq $spacer;
|
|
|
|
unless (USE_GCS) {
|
|
for my $row (@out) {
|
|
next unless $row =~ m/[^\x00-\x7F]/;
|
|
unshift @out => "Unicode::GCString is not installed, table may not display all unicode characters properly";
|
|
last;
|
|
}
|
|
}
|
|
|
|
return (@out, $border);
|
|
}
|
|
|
|
sub display {
|
|
my $self = shift;
|
|
my ($fh) = @_;
|
|
|
|
my @parts = map "$_\n", $self->render;
|
|
|
|
print $fh @parts if $fh;
|
|
print @parts;
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
|
|
=pod
|
|
|
|
=encoding UTF-8
|
|
|
|
=head1 NAME
|
|
|
|
Term::Table - Format a header and rows into a table
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This is used by some failing tests to provide diagnostics about what has gone
|
|
wrong. This module is able to generic format rows of data into tables.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Term::Table;
|
|
|
|
my $table = Term::Table->new(
|
|
max_width => 80, # defaults to terminal size
|
|
pad => 4, # Extra padding between table and max-width (defaults to 4)
|
|
allow_overflow => 0, # default is 0, when off an exception will be thrown if the table is too big
|
|
collapse => 1, # do not show empty columns
|
|
|
|
header => ['name', 'age', 'hair color'],
|
|
rows => [
|
|
['Fred Flinstone', 2000000, 'black'],
|
|
['Wilma Flinstone', 1999995, 'red'],
|
|
...
|
|
],
|
|
);
|
|
|
|
say $_ for $table->render;
|
|
|
|
This prints a table like this:
|
|
|
|
+-----------------+---------+------------+
|
|
| name | age | hair color |
|
|
+-----------------+---------+------------+
|
|
| Fred Flinstone | 2000000 | black |
|
|
| Wilma Flinstone | 1999995 | red |
|
|
| ... | ... | ... |
|
|
+-----------------+---------+------------+
|
|
|
|
=head1 INTERFACE
|
|
|
|
use Term::Table;
|
|
my $table = Term::Table->new(...);
|
|
|
|
=head2 OPTIONS
|
|
|
|
=over 4
|
|
|
|
=item header => [ ... ]
|
|
|
|
If you want a header specify it here. This takes an arrayref with each columns
|
|
heading.
|
|
|
|
=item rows => [ [...], [...], ... ]
|
|
|
|
This should be an arrayref containing an arrayref per row.
|
|
|
|
=item collapse => $bool
|
|
|
|
Use this if you want to hide empty columns, that is any column that has no data
|
|
in any row. Having a header for the column will not effect collapse.
|
|
|
|
=item max_width => $num
|
|
|
|
Set the maximum width of the table, the table may not be this big, but it will
|
|
be no bigger. If none is specified it will attempt to find the width of your
|
|
terminal and use that, otherwise it falls back to the terminal width or C<80>.
|
|
|
|
=item pad => $num
|
|
|
|
Defaults to 4, extra padding for row width calculations. Default is for legacy
|
|
support. Set this to 0 to turn padding off.
|
|
|
|
=item allow_overflow => $bool
|
|
|
|
Defaults to 0. If this is off then an exception will be thrown if the table
|
|
cannot be made to fit inside the max-width. If this is set to 1 then the table
|
|
will be rendered anyway, larger than max-width, if it is not possible to stay
|
|
within the max-width. In other words this turns max-width from a hard-limit to
|
|
a soft recommendation.
|
|
|
|
=item sanitize => $bool
|
|
|
|
This will sanitize all the data in the table such that newlines, control
|
|
characters, and all whitespace except for ASCII 20 C<' '> are replaced with
|
|
escape sequences. This prevents newlines, tabs, and similar whitespace from
|
|
disrupting the table.
|
|
|
|
B<Note:> newlines are marked as '\n', but a newline is also inserted into the
|
|
data so that it typically displays in a way that is useful to humans.
|
|
|
|
Example:
|
|
|
|
my $field = "foo\nbar\nbaz\n";
|
|
|
|
print join "\n" => table(
|
|
sanitize => 1,
|
|
rows => [
|
|
[$field, 'col2' ],
|
|
['row2 col1', 'row2 col2']
|
|
]
|
|
);
|
|
|
|
Prints:
|
|
|
|
+-----------------+-----------+
|
|
| foo\n | col2 |
|
|
| bar\n | |
|
|
| baz\n | |
|
|
| | |
|
|
| row2 col1 | row2 col2 |
|
|
+-----------------+-----------+
|
|
|
|
So it marks the newlines by inserting the escape sequence, but it also shows
|
|
the data across as many lines as it would normally display.
|
|
|
|
=item mark_tail => $bool
|
|
|
|
This will replace the last whitespace character of any trailing whitespace with
|
|
its escape sequence. This makes it easier to notice trailing whitespace when
|
|
comparing values.
|
|
|
|
=item show_header => $bool
|
|
|
|
Set this to false to hide the header. This defaults to true if the header is
|
|
set, false if no header is provided.
|
|
|
|
=item auto_columns => $bool
|
|
|
|
Set this to true to automatically add columns that are not named in the header.
|
|
This defaults to false if a header is provided, and defaults to true when there
|
|
is no header.
|
|
|
|
=item no_collapse => [ $col_num_a, $col_num_b, ... ]
|
|
|
|
=item no_collapse => [ $col_name_a, $col_name_b, ... ]
|
|
|
|
=item no_collapse => { $col_num_a => 1, $col_num_b => 1, ... }
|
|
|
|
=item no_collapse => { $col_name_a => 1, $col_name_b => 1, ... }
|
|
|
|
Specify (by number and/or name) columns that should not be removed when empty.
|
|
The 'name' form only works when a header is specified. There is currently no
|
|
protection to insure that names you specify are actually in the header, invalid
|
|
names are ignored, patches to fix this will be happily accepted.
|
|
|
|
=back
|
|
|
|
=head1 NOTE ON UNICODE/WIDE CHARACTERS
|
|
|
|
Some unicode characters, such as C<婧> (C<U+5A67>) are wider than others. These
|
|
will render just fine if you C<use utf8;> as necessary, and
|
|
L<Unicode::GCString> is installed, however if the module is not installed there
|
|
will be anomalies in the table:
|
|
|
|
+-----+-----+---+
|
|
| a | b | c |
|
|
+-----+-----+---+
|
|
| 婧 | x | y |
|
|
| x | y | z |
|
|
| x | 婧 | z |
|
|
+-----+-----+---+
|
|
|
|
=head1 SOURCE
|
|
|
|
The source code repository for Term-Table can be found at
|
|
F<http://github.com/exodist/Term-Table/>.
|
|
|
|
=head1 MAINTAINERS
|
|
|
|
=over 4
|
|
|
|
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
|
|
|
=back
|
|
|
|
=head1 AUTHORS
|
|
|
|
=over 4
|
|
|
|
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
|
|
|
=back
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
|
|
|
|
This program is free software; you can redistribute it and/or
|
|
modify it under the same terms as Perl itself.
|
|
|
|
See F<http://dev.perl.org/licenses/>
|
|
|
|
=cut
|