Term-Table-0.015/ 0000755 0001750 0001750 00000000000 13564630040 013374 5 ustar exodist exodist Term-Table-0.015/lib/ 0000755 0001750 0001750 00000000000 13564630040 014142 5 ustar exodist exodist Term-Table-0.015/lib/Term/ 0000755 0001750 0001750 00000000000 13564630040 015051 5 ustar exodist exodist Term-Table-0.015/lib/Term/Table/ 0000755 0001750 0001750 00000000000 13564630040 016100 5 ustar exodist exodist Term-Table-0.015/lib/Term/Table/CellStack.pm 0000644 0001750 0001750 00000004257 13564630040 020313 0 ustar exodist exodist package Term::Table::CellStack;
use strict;
use warnings;
our $VERSION = '0.015';
use Term::Table::HashBase qw/-cells -idx/;
use List::Util qw/max/;
sub init {
my $self = shift;
$self->{+CELLS} ||= [];
}
sub add_cell {
my $self = shift;
push @{$self->{+CELLS}} => @_;
}
sub add_cells {
my $self = shift;
push @{$self->{+CELLS}} => @_;
}
sub sanitize {
my $self = shift;
$_->sanitize(@_) for @{$self->{+CELLS}};
}
sub mark_tail {
my $self = shift;
$_->mark_tail(@_) for @{$self->{+CELLS}};
}
my @proxy = qw{
border_left border_right border_color value_color reset_color
border_left_width border_right_width
};
for my $meth (@proxy) {
no strict 'refs';
*$meth = sub {
my $self = shift;
$self->{+CELLS}->[$self->{+IDX}]->$meth;
};
}
for my $meth (qw{value_width width}) {
no strict 'refs';
*$meth = sub {
my $self = shift;
return max(map { $_->$meth } @{$self->{+CELLS}});
};
}
sub next {
my $self = shift;
my ($cw) = @_;
while ($self->{+IDX} < @{$self->{+CELLS}}) {
my $cell = $self->{+CELLS}->[$self->{+IDX}];
my $lw = $cell->border_left_width;
my $rw = $cell->border_right_width;
my $vw = $cw - $lw - $rw;
my $it = $cell->break->next($vw);
return ($it, $vw) if $it;
$self->{+IDX}++;
}
return;
}
sub break { $_[0] }
sub reset {
my $self = shift;
$self->{+IDX} = 0;
$_->reset for @{$self->{+CELLS}};
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Term::Table::CellStack - Combine several cells into one (vertical)
=head1 DESCRIPTION
This package is used to represent a merged-cell in a table (vertical).
=head1 SOURCE
The source code repository for Term-Table can be found at
F.
=head1 MAINTAINERS
=over 4
=item Chad Granum Eexodist@cpan.orgE
=back
=head1 AUTHORS
=over 4
=item Chad Granum Eexodist@cpan.orgE
=back
=head1 COPYRIGHT
Copyright 2016 Chad Granum Eexodist@cpan.orgE.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F
=cut
Term-Table-0.015/lib/Term/Table/LineBreak.pm 0000644 0001750 0001750 00000005217 13564630040 020277 0 ustar exodist exodist package Term::Table::LineBreak;
use strict;
use warnings;
our $VERSION = '0.015';
use Carp qw/croak/;
use Scalar::Util qw/blessed/;
use Term::Table::Util qw/uni_length/;
use Term::Table::HashBase qw/string gcstring _len _parts idx/;
sub init {
my $self = shift;
croak "string is a required attribute"
unless defined $self->{+STRING};
}
sub columns { uni_length($_[0]->{+STRING}) }
sub break {
my $self = shift;
my ($len) = @_;
$self->{+_LEN} = $len;
$self->{+IDX} = 0;
my $str = $self->{+STRING} . ""; # Force stringification
my @parts;
my @chars = split //, $str;
while (@chars) {
my $size = 0;
my $part = '';
until ($size == $len) {
my $char = shift @chars;
$char = '' unless defined $char;
my $l = uni_length("$char");
last unless $l;
last if $char eq "\n";
if ($size + $l > $len) {
unshift @chars => $char;
last;
}
$size += $l;
$part .= $char;
}
# If we stopped just before a newline, grab it
shift @chars if $size == $len && @chars && $chars[0] eq "\n";
until ($size == $len) {
$part .= ' ';
$size += 1;
}
push @parts => $part;
}
$self->{+_PARTS} = \@parts;
}
sub next {
my $self = shift;
if (@_) {
my ($len) = @_;
$self->break($len) if !$self->{+_LEN} || $self->{+_LEN} != $len;
}
else {
croak "String has not yet been broken"
unless $self->{+_PARTS};
}
my $idx = $self->{+IDX}++;
my $parts = $self->{+_PARTS};
return undef if $idx >= @$parts;
return $parts->[$idx];
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Term::Table::LineBreak - Break up lines for use in tables.
=head1 DESCRIPTION
This is meant for internal use. This package takes long lines of text and
splits them so that they fit in table rows.
=head1 SYNOPSIS
use Term::Table::LineBreak;
my $lb = Term::Table::LineBreak->new(string => $STRING);
$lb->break($SIZE);
while (my $part = $lb->next) {
...
}
=head1 SOURCE
The source code repository for Term-Table can be found at
F.
=head1 MAINTAINERS
=over 4
=item Chad Granum Eexodist@cpan.orgE
=back
=head1 AUTHORS
=over 4
=item Chad Granum Eexodist@cpan.orgE
=back
=head1 COPYRIGHT
Copyright 2016 Chad Granum Eexodist@cpan.orgE.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F
=cut
Term-Table-0.015/lib/Term/Table/HashBase.pm 0000644 0001750 0001750 00000031642 13564630040 020122 0 ustar exodist exodist package Term::Table::HashBase;
use strict;
use warnings;
our $VERSION = '0.015';
#################################################################
# #
# This is a generated file! Do not modify this file directly! #
# Use hashbase_inc.pl script to regenerate this file. #
# The script is part of the Object::HashBase distribution. #
# Note: You can modify the version number above this comment #
# if needed, that is fine. #
# #
#################################################################
{
no warnings 'once';
$Term::Table::HashBase::HB_VERSION = '0.008';
*Term::Table::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS;
*Term::Table::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST;
*Term::Table::HashBase::VERSION = \%Object::HashBase::VERSION;
*Term::Table::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE;
}
require Carp;
{
no warnings 'once';
$Carp::Internal{+__PACKAGE__} = 1;
}
BEGIN {
# these are not strictly equivalent, but for out use we don't care
# about order
*_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub {
no strict 'refs';
my @packages = ($_[0]);
my %seen;
for my $package (@packages) {
push @packages, grep !$seen{$_}++, @{"$package\::ISA"};
}
return \@packages;
}
}
my %SPEC = (
'^' => {reader => 1, writer => 0, dep_writer => 1, read_only => 0, strip => 1},
'-' => {reader => 1, writer => 0, dep_writer => 0, read_only => 1, strip => 1},
'>' => {reader => 0, writer => 1, dep_writer => 0, read_only => 0, strip => 1},
'<' => {reader => 1, writer => 0, dep_writer => 0, read_only => 0, strip => 1},
'+' => {reader => 0, writer => 0, dep_writer => 0, read_only => 0, strip => 1},
);
sub import {
my $class = shift;
my $into = caller;
# Make sure we list the OLDEST version used to create this class.
my $ver = $Term::Table::HashBase::HB_VERSION || $Term::Table::HashBase::VERSION;
$Term::Table::HashBase::VERSION{$into} = $ver if !$Term::Table::HashBase::VERSION{$into} || $Term::Table::HashBase::VERSION{$into} > $ver;
my $isa = _isa($into);
my $attr_list = $Term::Table::HashBase::ATTR_LIST{$into} ||= [];
my $attr_subs = $Term::Table::HashBase::ATTR_SUBS{$into} ||= {};
my %subs = (
($into->can('new') ? () : (new => \&_new)),
(map %{$Term::Table::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]),
(
map {
my $p = substr($_, 0, 1);
my $x = $_;
my $spec = $SPEC{$p} || {reader => 1, writer => 1};
substr($x, 0, 1) = '' if $spec->{strip};
push @$attr_list => $x;
my ($sub, $attr) = (uc $x, $x);
$attr_subs->{$sub} = sub() { $attr };
my %out = ($sub => $attr_subs->{$sub});
$out{$attr} = sub { $_[0]->{$attr} } if $spec->{reader};
$out{"set_$attr"} = sub { $_[0]->{$attr} = $_[1] } if $spec->{writer};
$out{"set_$attr"} = sub { Carp::croak("'$attr' is read-only") } if $spec->{read_only};
$out{"set_$attr"} = sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer};
%out;
} @_
),
);
no strict 'refs';
*{"$into\::$_"} = $subs{$_} for keys %subs;
}
sub attr_list {
my $class = shift;
my $isa = _isa($class);
my %seen;
my @list = grep { !$seen{$_}++ } map {
my @out;
if (0.004 > ($Term::Table::HashBase::VERSION{$_} || 0)) {
Carp::carp("$_ uses an inlined version of Term::Table::HashBase too old to support attr_list()");
}
else {
my $list = $Term::Table::HashBase::ATTR_LIST{$_};
@out = $list ? @$list : ()
}
@out;
} reverse @$isa;
return @list;
}
sub _new {
my $class = shift;
my $self;
if (@_ == 1) {
my $arg = shift;
my $type = ref($arg);
if ($type eq 'HASH') {
$self = bless({%$arg}, $class)
}
else {
Carp::croak("Not sure what to do with '$type' in $class constructor")
unless $type eq 'ARRAY';
my %proto;
my @attributes = attr_list($class);
while (@$arg) {
my $val = shift @$arg;
my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor");
$proto{$key} = $val;
}
$self = bless(\%proto, $class);
}
}
else {
$self = bless({@_}, $class);
}
$Term::Table::HashBase::CAN_CACHE{$class} = $self->can('init')
unless exists $Term::Table::HashBase::CAN_CACHE{$class};
$self->init if $Term::Table::HashBase::CAN_CACHE{$class};
$self;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Term::Table::HashBase - Build hash based classes.
=head1 SYNOPSIS
A class:
package My::Class;
use strict;
use warnings;
# Generate 3 accessors
use Term::Table::HashBase qw/foo -bar ^baz ban +boo/;
# Chance to initialize defaults
sub init {
my $self = shift; # No other args
$self->{+FOO} ||= "foo";
$self->{+BAR} ||= "bar";
$self->{+BAZ} ||= "baz";
$self->{+BAT} ||= "bat";
$self->{+BAN} ||= "ban";
$self->{+BOO} ||= "boo";
}
sub print {
print join ", " => map { $self->{$_} } FOO, BAR, BAZ, BAT, BAN, BOO;
}
Subclass it
package My::Subclass;
use strict;
use warnings;
# Note, you should subclass before loading HashBase.
use base 'My::Class';
use Term::Table::HashBase qw/bub/;
sub init {
my $self = shift;
# We get the constants from the base class for free.
$self->{+FOO} ||= 'SubFoo';
$self->{+BUB} ||= 'bub';
$self->SUPER::init();
}
use it:
package main;
use strict;
use warnings;
use My::Class;
# These are all functionally identical
my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar');
my $two = My::Class->new({foo => 'MyFoo', bar => 'MyBar'});
my $three = My::Class->new(['MyFoo', 'MyBar']);
# Readers!
my $foo = $one->foo; # 'MyFoo'
my $bar = $one->bar; # 'MyBar'
my $baz = $one->baz; # Defaulted to: 'baz'
my $bat = $one->bat; # Defaulted to: 'bat'
# '>ban' means setter only, no reader
# '+boo' means no setter or reader, just the BOO constant
# Setters!
$one->set_foo('A Foo');
#'-bar' means read-only, so the setter will throw an exception (but is defined).
$one->set_bar('A bar');
# '^baz' means deprecated setter, this will warn about the setter being
# deprecated.
$one->set_baz('A Baz');
# '{+FOO} = 'xxx';
=head1 DESCRIPTION
This package is used to generate classes based on hashrefs. Using this class
will give you a C method, as well as generating accessors you request.
Generated accessors will be getters, C setters will also be
generated for you. You also get constants for each accessor (all caps) which
return the key into the hash for that accessor. Single inheritance is also
supported.
=head1 THIS IS A BUNDLED COPY OF HASHBASE
This is a bundled copy of L. This file was generated using
the
C
script.
=head1 METHODS
=head2 PROVIDED BY HASH BASE
=over 4
=item $it = $class->new(%PAIRS)
=item $it = $class->new(\%PAIRS)
=item $it = $class->new(\@ORDERED_VALUES)
Create a new instance.
HashBase will not export C if there is already a C method in your
packages inheritance chain.
B you just have to
declare it before loading L.
package My::Package;
# predeclare new() so that HashBase does not give us one.
sub new;
use Term::Table::HashBase qw/foo bar baz/;
# Now we define our own new method.
sub new { ... }
This makes it so that HashBase sees that you have your own C method.
Alternatively you can define the method before loading HashBase instead of just
declaring it, but that scatters your use statements.
The most common way to create an object is to pass in key/value pairs where
each key is an attribute and each value is what you want assigned to that
attribute. No checking is done to verify the attributes or values are valid,
you may do that in C if desired.
If you would like, you can pass in a hashref instead of pairs. When you do so
the hashref will be copied, and the copy will be returned blessed as an object.
There is no way to ask HashBase to bless a specific hashref.
In some cases an object may only have 1 or 2 attributes, in which case a
hashref may be too verbose for your liking. In these cases you can pass in an
arrayref with only values. The values will be assigned to attributes in the
order the attributes were listed. When there is inheritance involved the
attributes from parent classes will come before subclasses.
=back
=head2 HOOKS
=over 4
=item $self->init()
This gives you the chance to set some default values to your fields. The only
argument is C<$self> with its indexes already set from the constructor.
B Term::Table::HashBase checks for an init using C<< $class->can('init') >>
during construction. It DOES NOT call C on the created object. Also note
that the result of the check is cached, it is only ever checked once, the first
time an instance of your class is created. This means that adding an C
method AFTER the first construction will result in it being ignored.
=back
=head1 ACCESSORS
=head2 READ/WRITE
To generate accessors you list them when using the module:
use Term::Table::HashBase qw/foo/;
This will generate the following subs in your namespace:
=over 4
=item foo()
Getter, used to get the value of the C field.
=item set_foo()
Setter, used to set the value of the C field.
=item FOO()
Constant, returns the field C's key into the class hashref. Subclasses will
also get this function as a constant, not simply a method, that means it is
copied into the subclass namespace.
The main reason for using these constants is to help avoid spelling mistakes
and similar typos. It will not help you if you forget to prefix the '+' though.
=back
=head2 READ ONLY
use Term::Table::HashBase qw/-foo/;
=over 4
=item set_foo()
Throws an exception telling you the attribute is read-only. This is exported to
override any active setters for the attribute in a parent class.
=back
=head2 DEPRECATED SETTER
use Term::Table::HashBase qw/^foo/;
=over 4
=item set_foo()
This will set the value, but it will also warn you that the method is
deprecated.
=back
=head2 NO SETTER
use Term::Table::HashBase qw/ method is defined at all.
=head2 NO READER
use Term::Table::HashBase qw/>foo/;
Only gives you a write (C), no C method is defined at all.
=head2 CONSTANT ONLY
use Term::Table::HashBase qw/+foo/;
This does not create any methods for you, it just adds the C constant.
=head1 SUBCLASSING
You can subclass an existing HashBase class.
use base 'Another::HashBase::Class';
use Term::Table::HashBase qw/foo bar baz/;
The base class is added to C<@ISA> for you, and all constants from base classes
are added to subclasses automatically.
=head1 GETTING A LIST OF ATTRIBUTES FOR A CLASS
Term::Table::HashBase provides a function for retrieving a list of attributes for an
Term::Table::HashBase class.
=over 4
=item @list = Term::Table::HashBase::attr_list($class)
=item @list = $class->Term::Table::HashBase::attr_list()
Either form above will work. This will return a list of attributes defined on
the object. This list is returned in the attribute definition order, parent
class attributes are listed before subclass attributes. Duplicate attributes
will be removed before the list is returned.
B This list is used in the C<< $class->new(\@ARRAY) >> constructor to
determine the attribute to which each value will be paired.
=back
=head1 SOURCE
The source code repository for HashBase can be found at
F.
=head1 MAINTAINERS
=over 4
=item Chad Granum Eexodist@cpan.orgE
=back
=head1 AUTHORS
=over 4
=item Chad Granum Eexodist@cpan.orgE
=back
=head1 COPYRIGHT
Copyright 2017 Chad Granum Eexodist@cpan.orgE.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F
=cut
Term-Table-0.015/lib/Term/Table/Spacer.pm 0000644 0001750 0001750 00000000271 13564630040 017653 0 ustar exodist exodist package Term::Table::Spacer;
use strict;
use warnings;
our $VERSION = '0.015';
sub new { bless {}, $_[0] }
sub width { 1 }
sub sanitize { }
sub mark_tail { }
sub reset { }
1;
Term-Table-0.015/lib/Term/Table/Cell.pm 0000644 0001750 0001750 00000005616 13564630040 017325 0 ustar exodist exodist package Term::Table::Cell;
use strict;
use warnings;
our $VERSION = '0.015';
use Term::Table::LineBreak();
use Term::Table::Util qw/uni_length/;
use List::Util qw/sum/;
use Term::Table::HashBase qw/value border_left border_right _break _widths border_color value_color reset_color/;
my %CHAR_MAP = (
# Special case, \n should render as \n, but also actually do the newline thing
"\n" => "\\n\n",
"\a" => '\\a',
"\b" => '\\b',
"\e" => '\\e',
"\f" => '\\f',
"\r" => '\\r',
"\t" => '\\t',
" " => ' ',
);
sub init {
my $self = shift;
# Stringify
$self->{+VALUE} = defined $self->{+VALUE} ? "$self->{+VALUE}" : '';
}
sub char_id {
my $class = shift;
my ($char) = @_;
return "\\N{U+" . sprintf("\%X", ord($char)) . "}";
}
sub show_char {
my $class = shift;
my ($char, %props) = @_;
return $char if $props{no_newline} && $char eq "\n";
return $CHAR_MAP{$char} || $class->char_id($char);
}
sub sanitize {
my $self = shift;
$self->{+VALUE} =~ s/([\s\t\p{Zl}\p{C}\p{Zp}])/$self->show_char($1)/ge; # All whitespace except normal space
}
sub mark_tail {
my $self = shift;
$self->{+VALUE} =~ s/([\s\t\p{Zl}\p{C}\p{Zp}])$/$1 eq ' ' ? $self->char_id($1) : $self->show_char($1, no_newline => 1)/se;
}
sub value_width {
my $self = shift;
my $w = $self->{+_WIDTHS} ||= {};
return $w->{value} if defined $w->{value};
my @parts = split /(\n)/, $self->{+VALUE};
my $max = 0;
while (@parts) {
my $text = shift @parts;
my $sep = shift @parts || '';
my $len = uni_length("$text");
$max = $len if $len > $max;
}
return $w->{value} = $max;
}
sub border_left_width {
my $self = shift;
$self->{+_WIDTHS}->{left} ||= uni_length($self->{+BORDER_LEFT} || '');
}
sub border_right_width {
my $self = shift;
$self->{+_WIDTHS}->{right} ||= uni_length($self->{+BORDER_RIGHT} || '');
}
sub width {
my $self = shift;
$self->{+_WIDTHS}->{all} ||= sum(map { $self->$_ } qw/value_width border_left_width border_right_width/);
}
sub break {
my $self = shift;
$self->{+_BREAK} ||= Term::Table::LineBreak->new(string => $self->{+VALUE});
}
sub reset {
my $self = shift;
delete $self->{+_BREAK};
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Term::Table::Cell - Representation of a cell in a table.
=head1 DESCRIPTION
This package is used to represent a cell in a table.
=head1 SOURCE
The source code repository for Term-Table can be found at
F.
=head1 MAINTAINERS
=over 4
=item Chad Granum Eexodist@cpan.orgE
=back
=head1 AUTHORS
=over 4
=item Chad Granum Eexodist@cpan.orgE
=back
=head1 COPYRIGHT
Copyright 2016 Chad Granum Eexodist@cpan.orgE.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F
=cut
Term-Table-0.015/lib/Term/Table/Util.pm 0000644 0001750 0001750 00000010235 13564630040 017354 0 ustar exodist exodist package Term::Table::Util;
use strict;
use warnings;
use Config qw/%Config/;
our $VERSION = '0.015';
use Importer Importer => 'import';
our @EXPORT_OK = qw/term_size USE_GCS USE_TERM_READKEY USE_TERM_SIZE_ANY uni_length/;
sub DEFAULT_SIZE() { 80 }
my $IO;
BEGIN {
open($IO, '>&', STDOUT) or die "Could not clone STDOUT";
}
sub try(&) {
my $code = shift;
local ($@, $?, $!);
my $ok = eval { $code->(); 1 };
my $err = $@;
return ($ok, $err);
}
my ($tsa) = try { require Term::Size::Any; Term::Size::Any->import('chars') };
my ($trk) = try { require Term::ReadKey };
$trk &&= Term::ReadKey->can('GetTerminalSize');
if (!-t $IO) {
*USE_TERM_READKEY = sub() { 0 };
*USE_TERM_SIZE_ANY = sub() { 0 };
*term_size = sub {
return $ENV{TABLE_TERM_SIZE} if $ENV{TABLE_TERM_SIZE};
return DEFAULT_SIZE;
};
}
elsif ($tsa) {
*USE_TERM_READKEY = sub() { 0 };
*USE_TERM_SIZE_ANY = sub() { 1 };
*_term_size = sub {
my $size = chars($IO);
return DEFAULT_SIZE if !$size;
return DEFAULT_SIZE if $size < DEFAULT_SIZE;
return $size;
};
}
elsif ($trk) {
*USE_TERM_READKEY = sub() { 1 };
*USE_TERM_SIZE_ANY = sub() { 0 };
*_term_size = sub {
my $total;
try {
my @warnings;
{
local $SIG{__WARN__} = sub { push @warnings => @_ };
($total) = Term::ReadKey::GetTerminalSize($IO);
}
@warnings = grep { $_ !~ m/Unable to get Terminal Size/ } @warnings;
warn @warnings if @warnings;
};
return DEFAULT_SIZE if !$total;
return DEFAULT_SIZE if $total < DEFAULT_SIZE;
return $total;
};
}
else {
*USE_TERM_READKEY = sub() { 0 };
*USE_TERM_SIZE_ANY = sub() { 0 };
*term_size = sub {
return $ENV{TABLE_TERM_SIZE} if $ENV{TABLE_TERM_SIZE};
return DEFAULT_SIZE;
};
}
if (USE_TERM_READKEY() || USE_TERM_SIZE_ANY()) {
if (index($Config{sig_name}, 'WINCH') >= 0) {
my $changed = 0;
my $polled = -1;
$SIG{WINCH} = sub { $changed++ };
my $size;
*term_size = sub {
return $ENV{TABLE_TERM_SIZE} if $ENV{TABLE_TERM_SIZE};
unless ($changed == $polled) {
$polled = $changed;
$size = _term_size();
}
return $size;
}
}
else {
*term_size = sub {
return $ENV{TABLE_TERM_SIZE} if $ENV{TABLE_TERM_SIZE};
_term_size();
};
}
}
my ($gcs, $err) = try { require Unicode::GCString };
if ($gcs) {
*USE_GCS = sub() { 1 };
*uni_length = sub { Unicode::GCString->new($_[0])->columns };
}
else {
*USE_GCS = sub() { 0 };
*uni_length = sub { length($_[0]) };
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Term::Table::Util - Utilities for Term::Table.
=head1 DESCRIPTION
This package exports some tools used by Term::Table.
=head1 EXPORTS
=head2 CONSTANTS
=over 4
=item $bool = USE_GCS
True if L is installed.
=item $bool = USE_TERM_READKEY
True if L is installed.
=back
=head2 UTILITIES
=over 4
=item $width = term_size()
Get the width of the terminal.
If the C<$TABLE_TERM_SIZE> environment variable is set then that value will be
returned.
This will default to 80 if there is no good way to get the size, or if the size
is unreasonably small.
If L is installed it will be used.
=item $width = uni_length($string)
Get the width (in columns) of the specified string. When L
is installed this will work on unicode strings, otherwise it will just use
C.
=back
=head1 SOURCE
The source code repository for Term-Table can be found at
F.
=head1 MAINTAINERS
=over 4
=item Chad Granum Eexodist@cpan.orgE
=back
=head1 AUTHORS
=over 4
=item Chad Granum Eexodist@cpan.orgE
=back
=head1 COPYRIGHT
Copyright 2016 Chad Granum Eexodist@cpan.orgE.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F
=cut
Term-Table-0.015/lib/Term/Table.pm 0000644 0001750 0001750 00000031321 13564630040 016436 0 ustar exodist exodist 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 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) are wider than others. These
will render just fine if you C