File Coverage

blib/lib/Data/Dumper/Table.pm

Criterion	Covered	Total	%
statement	86	88	97.7
branch	29	34	85.2
condition	9	9	100.0
subroutine	9	9	100.0
pod	1	1	100.0
total	134	141	95.0

package Data::Dumper::Table;

use strict;
use warnings;
use 5.018;
use utf8;

use Scalar::Util qw( reftype refaddr blessed );
use Text::Table;

use Exporter qw( import );
our @EXPORT = qw( Tabulate );

our $VERSION = '0.012';

our %seen;

sub Tabulate ($) {
    my ($thing) = @_;
    my $run = \do { my $o };
    $run = refaddr($run);
    $seen{ $run } = { };
    my $rv = _tblize($thing, $run);
    delete $seen{ $run };
    return $rv;
}

sub _tblize {
    my ($thing, $run) = @_;
    return 'undef()' unless defined $thing;
    my $r = reftype($thing) || '';
    my $addr = lc sprintf('%x', refaddr($thing) || 0);
    my $circular;
    if ($r and defined($seen{ $run }->{ $addr })) {
        $circular++;
    }
    my $alias
        = $r
        ? $r . '(' . ($seen{ $run }->{ $addr } //= scalar keys %{$seen{ $run }}) . ')'
        : '( scalar )'
        ;
    if (my $b = blessed($thing)) {
        $alias = $b . '=' . $alias unless $b eq 'Regexp';
    }
    if ($circular) {
        return '-> ' . $alias;
    }
    my $container = Text::Table->new(($alias)x($alias ne '( scalar )'));
    my $inner = $thing;
    my $snidge = '+';
    if ($r eq 'ARRAY') {
        my %header;
        my @v = grep {
            ref($_) eq 'HASH' ?
            do {
                for my $k (keys %$_) {
                    undef $header{ $k };
                }
                1;
            } : undef
        } @$thing;
        if (@v == @$thing) {
            $alias =~ s/ARRAY/ARRAY/;
            $container = Text::Table->new($alias);
            my @cols = sort keys %header;
            my @head = map { \' | ', defined($_) ? q{'} . quotemeta($_) . q{'} : 'undef()' } @cols;
            shift @head;
            unshift @head, \' ';
            push @head, \' ';
            $inner = Text::Table->new(@head);
            for my $row (@$thing) {
                my @body;
                for my $k (@cols) {
                    push @body, (exists($row->{ $k }) ? _tblize($row->{ $k }, $run) : '-');
                }
                $inner->add(@body);
            }
        }
        else {
            $inner = Text::Table->new();
            my $n = 0;
            my $index = "$alias [" . $n++ . "]";
            for my $row (@$thing) {
                $inner->add($index, _tblize($row, $run));
                $index = (' ' x (2 + length($alias) - length($n))) . '[' . $n++ . ']';
            }
            return $inner;
        }
    }
    elsif ($r eq 'HASH') {
        my @keys = sort keys %$thing;
        $inner = Text::Table->new();
        for my $k (@keys) {
            $inner->add((defined($k) ? q{'} . quotemeta($k) . q{'} : 'undef()'), '=>', _tblize($thing->{ $k }, $run));
            $snidge = '-';
        }
    }
    elsif ($r eq 'CODE') {
        $inner = 'sub DUMMY { }'; # TODO for now
    }
    elsif (uc $r eq 'REGEXP') {
        return "/$thing/";
    }
    elsif ($r) {
        $inner = _tblize("\\do { " . $$thing . "}", $run); # TODO for now
    }
    else {
        $inner = "'" . quotemeta($inner) . "'";
    }
    if (ref $inner) {
        $container->add($inner->title . $inner->rule('-', $snidge) . $inner->body);
        return $container->title . $container->body;
    }
    $container->add($inner);
    return $container->title . $container->body;
}

1;

__END__