File Coverage

blib/lib/Text/Table/Tiny.pm

Criterion	Covered	Total	%
statement	98	98	100.0
branch	39	42	92.8
condition	18	20	90.0
subroutine	18	18	100.0
pod	1	1	100.0
total	174	179	97.2

package Text::Table::Tiny;
$Text::Table::Tiny::VERSION = '1.02';
use 5.010;
use strict;
use warnings;
use utf8;
use parent 'Exporter';
use Carp                    qw/ croak /;
use Ref::Util         0.202 qw/ is_arrayref /;
use String::TtyLength 0.02  qw/ tty_width /;

our @EXPORT_OK = qw/ generate_table /;

# Legacy package globals, that can be used to customise the look.
# These are only used in the "classic" style.
# I wish I could drop them, but I don't want to break anyone's code.
our $COLUMN_SEPARATOR     = '|';
our $ROW_SEPARATOR        = '-';
our $CORNER_MARKER        = '+';
our $HEADER_ROW_SEPARATOR = '=';
our $HEADER_CORNER_MARKER = 'O';

my %arguments = (
    rows => "the rows, including a possible header row, of the table",
    header_row => "if true, indicates that the first row is a header row",
    separate_rows => "if true, a separate rule will be drawn between each row",
    top_and_tail => "if true, miss out top and bottom edges of table",
    align => "either single alignment, or an array per of alignments per col",
    style => "styling of table, one of classic, boxrule, or norule",
    indent => "indent every row of the table a certain number of spaces",
    compact => "narrow columns (no space either side of content)",
);

my %charsets = (
    classic => { TLC => '+', TT => '+', TRC => '+', HR => '-', VR => '|', FHR => '=', LT => '+', RT => '+', FLT => 'O', FRT => 'O', HC => '+', FHC => 'O', BLC => '+', BT => '+', BRC => '+' },
    boxrule => { TLC => '┌', TT => '┬', TRC => '┐', HR => '─', VR => '│', FHR => '═', LT => '├', RT => '┤', FLT => '╞', FRT => '╡', HC => '┼', FHC => '╪', BLC => '└', BT => '┴', BRC => '┘' },
    norule  => { TLC => ' ', TT => ' ', TRC => ' ', HR => ' ', VR => ' ', FHR => ' ', LT => ' ', RT => ' ', FLT => ' ', FRT => ' ', HC => ' ', FHC => ' ', BLC => ' ', BT => ' ', BRC => ' ' },
);

sub generate_table
{
    my %param   = @_;

    foreach my $arg (keys %param) {
        croak "unknown argument '$arg'" if not exists $arguments{$arg};
    }

    my $rows    = $param{rows} or croak "you must pass the 'rows' argument!";
    my @rows    = @$rows;
    my @widths  = _calculate_widths($rows);

    $param{style}  //= 'classic';

    $param{indent} //= '';
    $param{indent} = ' ' x $param{indent} if $param{indent} =~ /^[0-9]+$/;

    my $style   = $param{style};
    croak "unknown style '$style'" if not exists($charsets{ $style });
    my $char    = $charsets{$style};

    if ($style eq 'classic') {
        $char->{TLC} = $char->{TRC} = $char->{TT} = $char->{LT} = $char->{RT} = $char->{HC} = $char->{BLC} = $char->{BT} = $char->{BRC} = $CORNER_MARKER;
        $char->{HR}  = $ROW_SEPARATOR;
        $char->{VR}  = $COLUMN_SEPARATOR;
        $char->{FLT} = $char->{FRT} = $char->{FHC} = $HEADER_CORNER_MARKER;
        $char->{FHR} = $HEADER_ROW_SEPARATOR;
    }

    my $header;
    my @align;
    if (defined $param{align}) {
        @align = is_arrayref($param{align})
               ? @{ $param{align} }
               : ($param{align}) x int(@widths)
               ;
    }
    else {
        @align = ('l') x int(@widths);
    }

    $header = shift @rows if $param{header_row};

    my $table = _top_border(\%param, \@widths, $char)
                ._header_row(\%param, $header, \@widths, \@align, $char)
                ._header_rule(\%param, \@widths, $char)
                ._body(\%param, \@rows, \@widths, \@align, $char)
                ._bottom_border(\%param, \@widths, $char);
    chop($table);

    return $table;
}

sub _top_border
{
    my ($param, $widths, $char) = @_;

    return '' if $param->{top_and_tail};
    return _rule_row($param, $widths, $char->{TLC}, $char->{HR}, $char->{TT}, $char->{TRC});
}

sub _bottom_border
{
    my ($param, $widths, $char) = @_;

    return '' if $param->{top_and_tail};
    return _rule_row($param, $widths, $char->{BLC}, $char->{HR}, $char->{BT}, $char->{BRC});
}

sub _rule_row
{
    my ($param, $widths, $le, $hr, $cross, $re) = @_;
    my $pad = $param->{compact} ? '' : $hr;

    return $param->{indent}
           .$le
           .join($cross, map { $pad.($hr x $_).$pad } @$widths)
           .$re
           ."\n"
           ;
}

sub _header_row
{
    my ($param, $row, $widths, $align, $char) = @_;
    return '' unless $param->{header_row};

    return _text_row($param, $row, $widths, $align, $char);
}

sub _header_rule
{
    my ($param, $widths, $char) = @_;
    return '' unless $param->{header_row};
    my $fancy = $param->{separate_rows} ? 'F' : '';

    return _rule_row($param, $widths, $char->{"${fancy}LT"}, $char->{"${fancy}HR"}, $char->{"${fancy}HC"}, $char->{"${fancy}RT"});
}

sub _body
{
    my ($param, $rows, $widths, $align, $char) = @_;
    my $divider = $param->{separate_rows} ? _rule_row($param, $widths, $char->{LT}, $char->{HR}, $char->{HC}, $char->{RT}) : '';

    return join($divider, map { _text_row($param, $_, $widths, $align, $char) } @$rows);
}

sub _text_row
{
    my ($param, $row, $widths, $align, $char) = @_;
    my @columns = @$row;
    my $text = $param->{indent}.$char->{VR};

    for (my $i = 0; $i < @$widths; $i++) {
        $text .= _format_column($columns[$i] // '', $widths->[$i], $align->[$i] // 'l', $param, $char);
        $text .= $char->{VR};
    }
    $text .= "\n";

    return $text;
}

sub _format_column
{
    my ($text, $width, $align, $param, $char) = @_;
    my $pad = $param->{compact} ? '' : ' ';

    if ($align eq 'r' || $align eq 'right') {
        return $pad.' ' x ($width - tty_width($text)).$text.$pad;
    }
    elsif ($align eq 'c' || $align eq 'center' || $align eq 'centre') {
        my $total_spaces = $width - tty_width($text);
        my $left_spaces  = int($total_spaces / 2);
        my $right_spaces = $left_spaces;
        $right_spaces++ if $total_spaces % 2 == 1;
        return $pad.(' ' x $left_spaces).$text.(' ' x $right_spaces).$pad;
    }
    else {
        return $pad.$text.' ' x ($width - tty_width($text)).$pad;
    }
}

sub _calculate_widths
{
    my $rows = shift;
    my @widths;
    foreach my $row (@$rows) {
        my @columns = @$row;
        for (my $i = 0; $i < @columns; $i++) {
            next unless defined($columns[$i]);

            my $width = tty_width($columns[$i]);

            $widths[$i] = $width if !defined($widths[$i])
                                 || $width > $widths[$i];
        }
    }
    return @widths;
}

# Back-compat: 'table' is an alias for 'generate_table', but isn't exported
*table = \&generate_table;

1;

__END__