Data-ShowTable
view release on metacpan or search on metacpan
ShowTable.pm view on Meta::CPAN
sub ShowBoxTable {
my @argv = @_;
local ($titles, $types, $col_widths, $row_sub, $fmt_sub, $max_width);
my $args =
get_params
\@argv,
{ titles => \$titles,
types => \$types,
widths => \$col_widths,
row_sub => \$row_sub,
fmtsub => \$fmt_sub,
max_width => \$max_width,
},
[qw(titles types widths row_sub fmtsub max_width)];
$titles ne '' or croak "Missing column names array.\n";
$types ne '' or croak "Missing column types array.\n";
$col_widths ne '' or croak "Missing column width array.\n";
$row_sub ne '' or croak "Missing row subroutine.\n";
$fmt_sub = \&ShowTableValue if !defined($fmt_sub) || $fmt_sub eq '';
$max_width = $Max_Table_Width if !defined($max_width) || $max_width eq '';
my $rewindable = &$row_sub(1); # see if data is rewindable
my ($num_cols, $widths, $precision, $max_widths) =
&calc_widths($col_widths, $titles, $rewindable,
$row_sub, $fmt_sub, $types, 'box', $max_width);
my $width = 1;
my $dashes = ' +';
my $title_line = ' |';
my $title;
my $fmt = ' |'; # initial format string
my $c;
# Compose the box header
for ($c = 0; $c < $num_cols; $c++) {
$width = $max_widths->[$c]; # get previously calculated max col width
$width += 2; # account for a blank on either
# side of each value
$dashes .= ('-' x $width);
$dashes .= '+';
$title = $#$titles >= 0 && defined($titles->[$c]) ? $titles->[$c] :
sprintf("Field_%d", $c+1);
$title_line .= center $title, $width;
$title_line .= '|';
}
out $dashes;
if ($#$titles >= 0) {
out $title_line;
out $dashes;
}
my @values;
my @prefix = (" ", "<");
my @suffix = (" |", ">|");
my @cell;
# loop over the data, formatting it into cells, one row at a time.
while ((@values = &$row_sub(0)), $#values >= $[) {
# first pass -- format each value into a string
@cell = ();
for ($c = 0; $c <= $#values; $c++) {
$cell[$c] = &$fmt_sub($values[$c], $types->[$c], $max_widths->[$c],
$widths->[$c], $precision->[$c], 'box');
}
# second pass -- output each cell, wrapping if necessary
my $will_wrap;
my $wrapped = 0;
do { $will_wrap = 0;
put " |"; # start a line
for ($c = 0; $c <= $#cell; $c++) {
$will_wrap |= &putcell(\@cell, $c, $max_widths->[$c],
\@prefix, \@suffix, $wrapped);
}
out "";
$wrapped++;
} while ($will_wrap);
}
out $dashes;
out "";
}
=head1 ShowSimpleTable
Display a table of data using a simple table format.
S< >B<ShowSimpleTable> I<\@titles>, I<\@types>, I<\@widths>, I<\&row_sub> [, I<\&fmt_sub>];
S< >B<ShowSimpleTable> { I<parameter> => I<values>, ... };
The B<ShowSimpleTable> subroutine formats data into a simple table of
aligned columns, in the following example:
Column1 Column2 Column3
------- ------- -------
Value1 Value2 Value3
Value12 Value22 Value32
Columns are auto-sized by the data's widths, plus two spaces between columns.
Values which are too long for the maximum colulmn width are wrapped within
the column.
=cut
sub ShowSimpleTable {
my @argv = @_;
local ($titles, $types, $col_widths, $row_sub, $fmt_sub, $max_width);
my $args =
get_params
\@argv,
{ titles => \$titles,
types => \$types,
widths => \$col_widths,
row_sub => \$row_sub,
fmtsub => \$fmt_sub,
max_width => \$max_width,
},
[qw(titles types widths row_sub fmtsub max_width)];
$titles ne '' or croak "Missing column names array.\n";
$types ne '' or croak "Missing column types array.\n";
$col_widths ne '' or croak "Missing column width array.\n";
$row_sub ne '' or croak "Missing row sub array.\n";
$fmt_sub = \&ShowTableValue if !defined($fmt_sub) || $fmt_sub eq '';
$max_width = $Max_Table_Width if !defined($max_width) || $max_width eq '';
my $rewindable = &$row_sub(1); # see if data is rewindable
my ($num_cols, $widths, $precision, $max_widths) =
&calc_widths($col_widths, $titles, $rewindable,
$row_sub, $fmt_sub, $types, 'table', $max_width);
my $width = 1;
my $dashes = ' ';
my $title_line = ' ';
my $title ;
my $postfix = shift;
my $c ;
# Calculate the maximum widths
for ($c = 0; $c < $num_cols; $c++) {
$width = $max_widths->[$c];
$dashes .= ('-' x $width);
$dashes .= ' ';
next if $#$titles < 0;
$title = center $titles->[$c], $width;
$title_line .= $title;
$title_line .= ' ';
}
out $title_line if $#$titles >= 0;
out $dashes;
my @values;
my @prefix = (" ", "<");
my @suffix = (" ", ">");
while ((@values = &$row_sub(0)), $#values >= $[) {
# first pass -- format each value into a string
my @cell;
for ($c = 0; $c <= $#values; $c++) {
$cell[$c] = &$fmt_sub($values[$c], $types->[$c], $max_widths->[$c],
$widths->[$c], $precision->[$c], 'table');
}
# second pass -- output each cell, wrapping if necessary
my $will_wrap;
my $wrapped = 0;
do { $will_wrap = 0;
for ($c = 0; $c <= $#cell; $c++) {
$will_wrap |= &putcell(\@cell, $c, $max_widths->[$c],
\@prefix, \@suffix, $wrapped);
}
out "";
$wrapped++;
} while ($will_wrap);
}
out "";
}
=head1 ShowHTMLTable
Display a table of data nicely using HTML tables.
S< >B<ShowHTMLTable> { I<parameter> => I<value>, ... };
S< >B<ShowHTMLTable> I<\@titles>, I<\@types>, I<\@widths>, I<\&row_sub>
[, I<\&fmt_sub> [, I<$max_width> [, I<\%URL_Keys> [, I<$no_escape>
[, I<\@title_formats> [, I<\@data_formats> [, I<$table_attrs> ] ] ] ] ] ] ];
The B<ShowHTMLTable> displays one or more rows of columns of data using
the HTML C<\<TABLE\>> feature. In addition to the usual parameter arguments
of L<"ShowTable">, the following parameter arguments are defined:
=over 10
=item C<url_keys> => I<\%URL_Keys>,
This is a hash array of column names (titles) and corresponding base
URLs. The values of any column names or indexes occuring as keys in
the hash array will be generated as hypertext anchors using the
associated I<printf>-like string as the base URL. Either the column name
or the column index (beginning with 1) may be used as the hash key.
In the string value, these macros can be substituted:
"C<%K>" is replaced with the column name.
"C<%V>" is replaced with the column value;
"C<%I>" is replaced with the column index.
For example, if we define the array:
$base_url = "http://www.$domain/cgi/lookup?col=%K?val=%V";
%url_cols = ('Author' => $base_url,
'Name' => $base_url);
Then, the values in the C<Author> column will be generated with the following
ShowTable.pm view on Meta::CPAN
$row_sub ne '' or croak "Missing row sub array.\n";
# Defaults
$fmt_sub = \&ShowTableValue if !defined($fmt_sub) || $fmt_sub eq '';
$max_width = $Max_Table_Width if !defined($max_width) || $max_width eq '';
$url_keys = \%URL_Keys if !defined($url_keys) || $url_keys eq '';
$title_formats = \@Title_Formats if !defined($title_formats) || $title_formats eq '';
$data_formats = \@Data_Formats if !defined($data_formats) || $data_formats eq '';
$no_escape = $No_Escape if !defined($no_escape);
my $rewindable = &$row_sub(1); # see if rewindable
my ($num_cols, $widths, $precision, $max_widths) =
&calc_widths($col_widths, $titles, $rewindable,
$row_sub, $fmt_sub, $types, 'html', $max_width);
my $width = 1;
my $total_width = 0;
my $title_line = '';
my $title;
my ($c,$x);
my ($tprefixes,$tsuffixes,$dprefixes,$dsuffixes);
# prepare the HTML prefixes and suffixes, if any
($tprefixes,$tsuffixes) = html_formats $title_formats
if defined($title_formats) && $title_formats ne '';
($dprefixes,$dsuffixes) = html_formats $data_formats
if defined($data_formats) && $data_formats ne '';
if ($table_attrs) { # any table attributes?
local($_) = $table_attrs;
$table_attrs .= ' BORDER=1' unless /\bBORDER=/i;
$table_attrs .= ' CELLPADDING=1' unless /\bCELLPADDING=/i;
$table_attrs .= ' CELLSPACING=1' unless /\bCELLSPACING=/i;
} else {
$table_attrs = 'BORDER=2 CELLPADDING=1 CELLSPACING=1';
}
out "<TABLE $table_attrs>\n<TR>" ;
map { $total_width += defined($_) ? $_ : 0; } @$max_widths;
for ($c = 0; $c < $num_cols; $c++) {
# If the user specified a width, then use it.
$width = defined($widths->[$c]) ? $widths->[$c] : $max_widths->[$c];
my $pct_width = int(100 * $width/$total_width);
$title_line .= " <TH ALIGN=CENTER WIDTH=$pct_width%%>";
if ($#$titles >= 0) {
if (($x = $#$tprefixes) >= 0) {
$title_line .= $tprefixes->[$c > $x ? $x : $c];
}
$title_line .= $no_escape ? $titles->[$c] : &htmltext($titles->[$c]);
if (($x = $#$tsuffixes) >= 0) {
$title_line .= $tsuffixes->[$c > $x ? $x : $c];
}
}
$title_line .= "</TH>\n";
}
out $title_line;
out "</TR>";
my ($href, $key, $val, $out);
while ((@values = &$row_sub(0)), $#values >= $[) {
out "<TR> ";
# Walk through the values
for ($c = 0; $c <= $#values; $c++) {
$out = "<TD";
if (defined($val = $values[$c])) { # only worry about defined values
# In HTML mode, all CHAR, TEXT, SYMBOL, or STRING data should
# be escaped to protect HTML syntax "<", ">", "\", and "&".
if ($types->[$c] =~ /char|text|symbol|string/i) {
$val = &htmltext($val) unless $no_escape;
$out .= " ALIGN=LEFT";
} else {
$out .= " ALIGN=RIGHT";
}
$out .= ">";
# Discover if either the column name or column index
# have been mapped to a URL.
$href = '';
foreach $key ( $#$titles >= 0 && &PlainText($titles->[$c]),
sprintf("%d", $c+1)) {
next unless $key ne '' && defined($url_keys->{$key});
$href = $url_keys->{$key};
last;
}
if ($href ne '') {
if ($href =~ /%K/) {
my $s = &htmltext(&PlainText($titles->[$c]), 1);
$href =~ s/%K/$s/g;
}
if ($href =~ /%V/) {
my $s = &htmltext($val, 1);
$href =~ s/%V/$s/g;
}
if ($href =~ /%I/) {
my $s = sprintf("%d", $c+1);
$href =~ s/%I/$s/g;
}
$out .= sprintf("<A HREF=\"%s\">",$href);
}
$val = &$fmt_sub($val, $types->[$c], 0, $widths->[$c],
$precision->[$c], 'html');
$val =~ s/^\s+//; # don't try to align
$val =~ s/\s+$//;
if (($x = $#$dprefixes) >= 0) {
$out .= $dprefixes->[$c > $x ? $x : $c];
}
$out .= $val;
if (($x = $#$dsuffixes) >= 0) {
$out .= $dsuffixes->[$c > $x ? $x : $c];
}
$out .= "</A>" if $href;
} else {
$out .= ">";
}
$out .= "</TD>";
out $out;
}
out "</TR>";
}
out "</TABLE>";
ShowTable.pm view on Meta::CPAN
Field2: blah blah blah
: blah blah blah
=item *
On a continuation, the null field is an arbitrary number of leading
white space, a colon ':', a single blank or tab, followed by the
continued text.
=item *
Embedded newlines are indicated by the escape mechanism "\n".
Similarly, embedded tabs are indicated with "\t", returns with "\r".
=item *
If the I<@titles> array is empty, the field names "C<Field_>I<NN>" are used
instead.
=back
=cut
sub ShowListTable {
my @argv = @_;
local ($titles, $types, $col_widths, $row_sub, $fmt_sub, $max_width,
$wrap_margin);
my $args =
get_params
\@argv,
{ titles => \$titles,
types => \$types,
widths => \$col_widths,
row_sub => \$row_sub,
fmtsub => \$fmt_sub,
max_width => \$max_width,
wrap_margin => \$wrap_margin,
},
[qw(titles types widths row_sub fmt_sub max_width wrap_margin)];
defined($titles) && $titles ne '' or croak "Missing column names array.\n";
defined($types) && $types ne '' or croak "Missing column types array.\n";
defined($col_widths) && $col_widths ne '' or croak "Missing column width array.\n";
defined($row_sub) && $row_sub ne '' or croak "Missing row sub array.\n";
$fmt_sub = \&ShowTableValue if !defined($fmt_sub) || $fmt_sub eq '';
$max_width = $Max_List_Width if !defined($max_width) || $max_width eq '';
$wrap_margin = $List_Wrap_Margin if !defined($wrap_margin) || $wrap_margin eq '';
my $rewindable = &$row_sub(1); # init the row pointer
my ($num_cols, $widths, $precision, $max_widths) =
&calc_widths($col_widths, $titles, $rewindable,
$row_sub, $fmt_sub, $types, 'list', '');
my $fmt = sprintf("%%-%ds : %%s\n", ($#$titles >= 0 ? &max_length($titles) : 8));
my @values;
my ($value, $c, $cut, $line);
my $col_limit = $max_width - 2;
while ((@values = &$row_sub(0)), $#values >= $[) {
for ($c = 0; $c <= $#values; $c++) {
# get this column's title
$title = $#$titles >= 0 ? $titles->[$c] : sprintf("Field_%d", $c+1);
my $type = $types->[$c];
my $width = 0;
my $prec = $precision->[$c];
$value = &$fmt_sub($values[$c], $type, 0, $width, $prec, 'list');
while (length($value)) {
if (length($value) > ($cut = $col_limit)) {
$line = substr($value, 0, $cut);
if ($line =~ m/([-,;? \t])([^-,;? \t]*)$/ &&
length($2) <= $wrap_margin) {
$cut = $col_limit - length($2);
$line = substr($value, 0, $cut);
}
($value = substr($value, $cut)) =~ s/^\s+//;
} else {
$line = $value;
$value = '';
}
out $fmt, $title, $line;
$title = '';
}
}
out "";
}
}
=head1 ShowRow
Fetch rows successively from one or more columns of data.
S< >B<ShowRow> I<$rewindflag>, I<\$index>, I<$col_array_1> [, I<$col_array_2>, ...;]
The B<ShowRow> subroutine returns a row of data from one or more
columns of data. It is designed to be used as a I<callback> routine,
within the B<ShowTable> routine. It can be used to select elements
from one or more array reference arguments.
If passed two or more array references as arguments, elements of the
arrays selected by I<$index> are returned as the "row" of data.
If a single array argument is passed, and each element of the array is
itself an array, the subarray is returned as the "row" of data.
If the I<$rewindflag> flag is set, then the I<$index> pointer is reset
to zero, and "true" is returned (a scalar 1). This indicates that the
data is rewindable to the B<ShowTable> routines.
When the I<$rewindflag> is not set, then the current row of data, as
determined by I<$index> is returned, and I<$index> will
have been incremented.
An actual invocation (from B<ShowColumns>) is:
ShowTable \@titles, \@types, \@lengths,
sub { &ShowRow( $_[0], \$current_row, $col_names, $col_types,
$col_lengths, \@col_attrs); };
In the example above, after each invocation, the I<$current_row> argument
ShowTable.pm view on Meta::CPAN
scaled down uniformly. If not set (null), no column width scaling is done.
=back
=cut
sub calc_widths {
my $widthspec = shift;
my $titles = shift;
my $rewindable = shift;
my $row_sub = shift;
my $fmt_sub = shift;
my $types = shift;
my $showmode = shift;
my $max_width = shift;
my @precision; # array of precision values
my @setprec; # array of flags to set default precision
my @widths; # array of widths
my @max_widths; # array of max widths
my @expandable; # flag if widths expandable
my $num_cols;
my $c;
if ($#$widthspec >= 0) {
@precision = @$widthspec;
foreach (@precision) { s/^.*\.(\d+)/$1/ || ($_ = ''); }
# The setprec array indicates which columns need a default precision
@setprec = map { !length } @precision;
# Get the integer portions
@widths = map { length($_) ? int : 0 } @$widthspec;
# Set @expandable if negative widths
@expandable = map { $_ < 0 } @widths;
# Convert widths to all positive values
@widths = map abs, @widths;
@max_widths = (0) x (1 + $#widths); # no maximums yet
$num_cols = 1 + $#widths;
} else {
# No widths given
@expandable = (1) x (1 + $#$titles);
@precision = ('') x (1 + $#$titles);
@setprec = @expandable;
@max_widths = map length, @$titles; # initialize maximums to title widths
$num_cols = 1 + $#$titles;
}
# If the data is rewindable, scan and accumulate *actual* widths for
# each column, using the title lengths as a minimum.
if ($rewindable) {
my @values;
my @prectype;
if (ref($types) eq 'ARRAY') {
@prectype = map {/float|num(eric|ber)|money|dec|real|precision|double/i } @$types;
}
# Scan the values
while ((@values = &$row_sub(0)), $#values >= $[) {
# If the new row is larger than the number of titles, adjust
# the info arrays..
if ($num_cols < 1 + $#values) { # new column?
$num_cols = 1 + $#values; # new # of columns
for ($c = $#expandable + 1; $c <= $#values; $c++) {
$expandable[$c] = 1;
$precision[$c] = '';
$setprec[$c] = 1;
$max_widths[$c] = 0;
}
}
my $len;
my $value;
for ($c = 0; $c < $num_cols; $c++) {
# Does this column's precision need setting?
if ($setprec[$c]) {
# Yes, is it a type of value which can use the precision?
if ($prectype[$c]) {
# yes, how much is the current value's default precision?
if ($values[$c] =~ /\.(.*)$/) {
$precision[$c] = length($1) if length($1) > $precision[$c];
}
} else {
# No, this column can't use the precision value -- don't
# do this check on this column again
$precision[$c] = $setprec[$c] = 0;
}
}
# Now, let's get the formatted value so we can guess the best
# default widths
$value =
# If a fmt_sub is available, use it to format the value
$fmt_sub ?
&$fmt_sub($values[$c], $types->[$c], 0, 0, $precision[$c], $showmode)
# If no fmt sub, then use Perl stringify
: length($showmode eq 'html' ? # in HTML mode?
&PlainText($values[$c]) # use plain text
: $values[$c]); # else, use raw text
$len = length($value);
$max_widths[$c] = $len if
$c > $#max_widths || $len > $max_widths[$c];
}
}
# okay -- maximums scanned.
# If the maximum table width set, scale the max_widths
$max_width = 0 unless
defined($max_width) && $max_width ne '';
if ($max_width > 0) {
# Start with the given maximum, but adjust it to account for
# the formatting and space characters.
my $max_width = $max_width;
$max_width -= $num_cols * 3 + 2 if $showmode eq 'box';
$max_width -= $num_cols * 2 - 1 if $showmode eq 'table';
my $total = 0;
# Calculate the total table width
for ($c = 0; $c <= $#max_widths; $c++) {
$total += $max_widths[$c];
}
( run in 1.120 second using v1.01-cache-2.11-cpan-5735350b133 )