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

package Test::Stream::Table;
use strict;
use warnings;

use Test::Stream::Table::LineBreak;

use List::Util qw/min max sum/;
use Scalar::Util qw/blessed/;

use Test::Stream::Util qw/term_size/;

use Test::Stream::Exporter;
exports qw/table/;
no Test::Stream::Exporter;

sub BORDER_SIZE() { 4 }    # '| ' and ' |' borders
sub DIV_SIZE()    { 3 }    # ' | ' column delimiter
sub PAD_SIZE()    { 4 }    # Extra arbitrary padding

my %CHAR_MAP = (
    "\a" => '\\a',
    "\b" => '\\b',
    "\e" => '\\e',
    "\f" => '\\f',
    "\n" => '\\n',
    "\r" => '\\r',
    "\t" => '\\t',
    " "  => ' ',
);

sub char_id {
    my $char = shift;
    return "\\N{U+" . sprintf("\%X", ord($char)) . "}";
}

sub show_char {
    my ($char) = @_;
    return $CHAR_MAP{$char} || char_id($char);
}

sub sanitize {
    for (@_) {
        next unless defined $_;
        s/([\s\t\p{Zl}\p{C}\p{Zp}])/show_char($1)/ge; # All whitespace except normal space
    }
    return @_;
}

sub mark_tail {
    for (@_) {
        next unless defined $_;
        s/([\s\t\p{Zl}\p{C}\p{Zp}])$/$1 eq ' ' ? char_id($1) : show_char($1)/e;
    }
    return @_;
}

sub resize {
    my ($max, $show, $lengths) = @_;

    my $fair = int($max / @$show); # Fair size for all rows

    my $used = 0;
    my @resize;
    for my $i (@$show) {
        my $size = $lengths->[$i];
        if ($size <= $fair) {
            $used += $size;
            next;
        }

        push @resize => $i;
    }

    my $new_max = $max - $used;
    my $new_fair = int($new_max / @resize);
    $lengths->[$_] = $new_fair for @resize;
}

sub table {
    my %params = @_;
    my $header      = $params{header};
    my $rows        = $params{rows};
    my $collapse    = $params{collapse};
    my $maxwidth    = $params{max_width} || term_size();
    my $sanitize    = $params{sanitize};
    my $mark_tail   = $params{mark_tail};
    my $no_collapse = $params{no_collapse} || [];

    $no_collapse = { map {($_ => 1)} @$no_collapse };

    my $last = ($header ? scalar @$header : max(map { scalar @{$_} } @$rows)) - 1;
    my @all = 0 .. $last;

    my $uniwarn = 0;
    my @lengths;
    for my $row (@$rows) {
        $uniwarn ||= m/[^\x00-\x7F]/ for grep { defined($_) } @$row;
        sanitize(@$row)  if $sanitize;
        mark_tail(@$row) if $mark_tail;
        @$row = map { Test::Stream::Table::LineBreak->new(string => defined($row->[$_]) ? "$row->[$_]" : '') } @all;
        $lengths[$_] = max($row->[$_]->columns, $lengths[$_] || 0) for @all;
    }

    # How many columns are we showing?
    my @show = $collapse ? (grep { $lengths[$_] || $no_collapse->{$_} } @all) : (@all);

    # Titles should fit
    if ($header) {
        @$header = map {Test::Stream::Table::LineBreak->new(string => "$_")} @$header;
        for my $i (@all) {
            next if $collapse && !$lengths[$i] && !$no_collapse->{$i};
            $lengths[$i] = max($header->[$i]->columns, $lengths[$i] || 0);
        }
    }

    # Figure out size of screen, and a fair size for each column.
    my $divs     = @show * DIV_SIZE();    # size of the dividers combined
    my $max_size = $maxwidth              # initial terminal size
                 - BORDER_SIZE()          # Subtract the border
                 - PAD_SIZE()             # subtract the padding
                 - $divs;                 # Subtract dividers

    # Make sure we do not spill off the screen
    resize($max_size, \@show, \@lengths) if sum(@lengths) > $max_size;

    # Put together borders and row template
    my $border   = join '-', '+', map { '-' x $lengths[$_], "+" } @show;
    my $row_tmpl = join ' ', '|', map { "\%s |" } @show;

    for my $row ($header ? ($header) : (), @$rows) {
        for my $i (@show) {
            $row->[$i]->break($lengths[$i]);
        }
    }

    my @new_rows;
    my $span = 0;
    while (@$rows) {
        my @new;
        my $row = $rows->[0];
        my $found = 0;
        $span++;

        for my $i (@show) {
            my $item = $row->[$i];
            my $part = $item->next;

            if (defined($part)) {
                $found++;
                push @new => $part;
            }
            else {
                push @new => ' ' x $lengths[$i];
            }
        }

        if ($found || $span > 2) {
            push @new_rows => \@new;
        }

        unless ($found) {
            shift @$rows;
            $span = 0;
        }
    }

    # Remove trailing row padding
    pop @new_rows if @new_rows && !grep { m/\S/ } @{$new_rows[-1]};

    return (
        $uniwarn && !$INC{'Unicode/GCString.pm'} ? (
            "Unicode::GCString is not installed, table may not display all unicode characters properly",
        ) : (),

        $header ? (
            $border,
            sprintf($row_tmpl, map { $_->next } @$header[@show]),
        ) : (),

        $border,

        (map {sprintf($row_tmpl, @{$_})} @new_rows),

        $border,
    );
}

1;

__END__