1package Text::Table::TinyBorderStyle; 2 3our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY 4our $DATE = '2020-06-12'; # DATE 5our $DIST = 'Text-Table-TinyBorderStyle'; # DIST 6our $VERSION = '0.004'; # VERSION 7 8use 5.006; 9use strict; 10use warnings; 11 12use List::Util (); 13 14use Exporter qw(import); 15our @EXPORT_OK = qw/ generate_table /; 16 17sub generate_table { 18 19 my %params = @_; 20 my $rows = $params{rows} or die "Must provide rows!"; 21 22 my $border_style_name = $params{border_style} || 23 $ENV{TEXT_TABLE_TINY_BORDER_STYLE} || 24 $ENV{BORDER_STYLE} || 25 'BorderStyle::ASCII::SingleLine'; 26 27 require Module::Load::Util; 28 my $border_style_obj = Module::Load::Util::instantiate_class_with_optional_args($border_style_name); 29 30 # foreach col, get the biggest width 31 my $widths = _maxwidths($rows); 32 my $max_index = _max_array_index($rows); 33 34 # use that to get the field format and separators 35 my $row_format = _get_row_format ($border_style_obj, $widths); 36 my $header_row_format = _get_header_row_format ($border_style_obj, $widths); 37 my $top_border = _get_top_border ($border_style_obj, $widths); 38 my $head_row_sep = _get_header_row_separator($border_style_obj, $widths); 39 my $row_sep = _get_row_separator ($border_style_obj, $widths); 40 my $bottom_border = _get_bottom_border ($border_style_obj, $widths); 41 42 # here we go... 43 my @table; 44 push @table, $top_border; 45 46 # if the first row's a header: 47 my $data_begins = 0; 48 if ( $params{header_row} ) { 49 my $header_row = $rows->[0]; 50 $data_begins++; 51 push @table, sprintf( 52 $header_row_format, 53 map { defined($header_row->[$_]) ? $header_row->[$_] : '' } (0..$max_index) 54 ); 55 push @table, $head_row_sep; 56 } 57 58 # then the data 59 my $i = 0; 60 foreach my $row ( @{ $rows }[$data_begins..$#$rows] ) { 61 push @table, $row_sep if $params{separate_rows} && $i++; 62 push @table, sprintf( 63 $row_format, 64 map { defined($row->[$_]) ? $row->[$_] : '' } (0..$max_index) 65 ); 66 } 67 68 # this will have already done the bottom if called explicitly 69 push @table, $bottom_border; 70 return join("\n",grep {$_} @table); 71} 72 73sub _get_cols_and_rows ($) { 74 my $rows = shift; 75 return ( List::Util::max( map { scalar @$_ } @$rows), scalar @$rows); 76} 77 78sub _maxwidths { 79 my $rows = shift; 80 # what's the longest array in this list of arrays? 81 my $max_index = _max_array_index($rows); 82 my $widths = []; 83 for my $i (0..$max_index) { 84 # go through the $i-th element of each array, find the longest 85 my $max = List::Util::max(map {defined $$_[$i] ? length($$_[$i]) : 0} @$rows); 86 push @$widths, $max; 87 } 88 return $widths; 89} 90 91# return highest top-index from all rows in case they're different lengths 92sub _max_array_index { 93 my $rows = shift; 94 return List::Util::max( map { $#$_ } @$rows ); 95} 96 97# TODO: what if border character contains % 98sub _get_row_format { 99 my ($border_style_obj, $widths) = @_; 100 join( 101 "", 102 $border_style_obj->get_border_char(3, 0). " ", 103 join(" ".$border_style_obj->get_border_char(3, 1)." ", map { "%-${_}s" } @$widths), 104 " " . $border_style_obj->get_border_char(3, 2), 105 ); 106} 107 108# TODO: what if border character contains % 109sub _get_header_row_format { 110 my ($border_style_obj, $widths) = @_; 111 join( 112 "", 113 $border_style_obj->get_border_char(1, 0) . " ", 114 join(" ".$border_style_obj->get_border_char(1, 1)." ", map { "%-${_}s" } @$widths), 115 " " . $border_style_obj->get_border_char(1, 2), 116 ); 117} 118 119sub _get_top_border { 120 my ($border_style_obj, $widths) = @_; 121 join( 122 "", 123 $border_style_obj->get_border_char(0, 0) . $border_style_obj->get_border_char(0, 1), 124 join($border_style_obj->get_border_char(0, 1) . $border_style_obj->get_border_char(0, 2) . $border_style_obj->get_border_char(0, 1), map { $border_style_obj->get_border_char(0, 1, $_) } @$widths), 125 $border_style_obj->get_border_char(0, 1) . $border_style_obj->get_border_char(0, 3), 126 ); 127} 128 129sub _get_header_row_separator { 130 my ($border_style_obj, $widths) = @_; 131 join( 132 "", 133 $border_style_obj->get_border_char(2, 0) . $border_style_obj->get_border_char(2, 1), 134 join($border_style_obj->get_border_char(2, 1) . $border_style_obj->get_border_char(2, 2) . $border_style_obj->get_border_char(2, 1), map { $border_style_obj->get_border_char(2, 1, $_) } @$widths), 135 $border_style_obj->get_border_char(2, 1) . $border_style_obj->get_border_char(2, 3), 136 ); 137} 138 139sub _get_row_separator { 140 my ($border_style_obj, $widths) = @_; 141 join( 142 "", 143 $border_style_obj->get_border_char(4, 0) . $border_style_obj->get_border_char(4, 1), 144 join($border_style_obj->get_border_char(4, 1) . $border_style_obj->get_border_char(4, 2) . $border_style_obj->get_border_char(4, 1), map { $border_style_obj->get_border_char(4, 1, $_) } @$widths), 145 $border_style_obj->get_border_char(4, 1) . $border_style_obj->get_border_char(4, 3), 146 ); 147} 148 149sub _get_bottom_border { 150 my ($border_style_obj, $widths) = @_; 151 join( 152 "", 153 $border_style_obj->get_border_char(5, 0) . $border_style_obj->get_border_char(5, 1) , 154 join($border_style_obj->get_border_char(5, 1) . $border_style_obj->get_border_char(5, 2) . $border_style_obj->get_border_char(5, 1), map { $border_style_obj->get_border_char(5, 1, $_) } @$widths), 155 $border_style_obj->get_border_char(5, 1) . $border_style_obj->get_border_char(5, 3), 156 ); 157} 158 159# Back-compat: 'table' is an alias for 'generate_table', but isn't exported 160{ 161 no warnings 'once'; 162 *table = \&generate_table; 163} 164 1651; 166# ABSTRACT: Text::Table::Tiny + support for border styles 167 168__END__ 169 170=pod 171 172=encoding UTF-8 173 174=head1 NAME 175 176Text::Table::TinyBorderStyle - Text::Table::Tiny + support for border styles 177 178=head1 VERSION 179 180This document describes version 0.004 of Text::Table::TinyBorderStyle (from Perl distribution Text-Table-TinyBorderStyle), released on 2020-06-12. 181 182=head1 SYNOPSIS 183 184 use Text::Table::TinyBorderStyle qw/ generate_table /; 185 186 my $rows = [ 187 # header row 188 ['Name','Rank','Serial'], 189 # rows 190 ['alice', 'pvt', '123456'], 191 ['bob', 'cpl', '98765321'], 192 ['carol', 'brig gen', '8745'], 193 ]; 194 print generate_table(rows => $rows, header_row => 1, border_style => 'BorderStyle::ASCII::SingleLine'); 195 196=head1 DESCRIPTION 197 198This module is like L<Text::Table::Tiny> (0.04) with added support for using 199border styles. For more details about border styles, see L<BorderStyle> 200specification. The styles are in C<BorderStyle::*> modules. Try installing and 201using the border style modules to see what they look like. 202 203Interface, options, and format variables are the same as in Text::Table::Tiny. 204 205=for Pod::Coverage ^(.+)$ 206 207=head1 ENVIRONMENT 208 209=head2 BORDER_STYLE 210 211Set default for C<border_style> argument. See also 212L</TEXT_TABLE_TINY_BORDER_STYLE>. 213 214=head2 BORDER_STYLE 215 216Set default for C<border_style> argument. Takes precedence over 217L</BORDER_STYLE>. 218 219=head1 HOMEPAGE 220 221Please visit the project's homepage at L<https://metacpan.org/release/Text-Table-TinyBorderStyle>. 222 223=head1 SOURCE 224 225Source repository is at L<https://github.com/perlancar/perl-Text-Table-TinyBorderStyle>. 226 227=head1 BUGS 228 229Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Text-Table-TinyBorderStyle> 230 231When submitting a bug or request, please include a test-file or a 232patch to an existing test-file that illustrates the bug or desired 233feature. 234 235=head1 SEE ALSO 236 237L<Text::Table::Tiny> and other variants like L<Text::Table::TinyColor>, 238L<Text::Table::TinyWide>, L<Text::Table::TinyColorWide>. 239 240L<BorderStyle> and C<BorderStyle::*> modules, e.g. 241L<BorderStyle::ASCII::SingleLine> or L<BorderStyle::UTF8::DoubleLine>. 242 243L<Text::Table::Any> 244 245L<Text::ANSITable> which also supports border styles as well as color themes 246(including coloring the borders), aligning wide/colored text, and other 247features, but with larger footprint and slower rendering speed. 248 249=head1 AUTHOR 250 251perlancar <perlancar@cpan.org> 252 253=head1 COPYRIGHT AND LICENSE 254 255This software is copyright (c) 2020 by perlancar@cpan.org. 256 257This is free software; you can redistribute it and/or modify it under 258the same terms as the Perl 5 programming language system itself. 259 260=cut 261