# -*- perl -*-
#
# DBI::Format - a package for displaying result tables
#
# Copyright (c) 1998 Jochen Wiedmann
# Copyright (c) 1998 Tim Bunce
#
# The DBI::Shell:Result module is free software; you can redistribute
# it and/or modify it under the same terms as Perl itself.
#
# Author: Jochen Wiedmann
# Am Eisteich 9
# 72555 Metzingen
# Germany
#
# Email: joe@ispsoft.de
# Phone: +49 7123 14881
#
use strict;
package DBI::Format;
use Text::Abbrev;
$DBI::Format::VERSION = $DBI::Format::VERSION = substr(q$Revision: 1.1 $, 10)+0;
sub available_formatters {
my ($use_abbrev) = @_;
my @fmt;
my @dir = grep { -d "$_/DBI" } @INC;
foreach my $dir (@dir) {
opendir DIR, "$dir/DBI" or warn "Unable to read $dir/DBI: $!\n";
push @fmt, map { m/^Fmt(\w+)\.pm$/i ? ($1) : () } readdir DIR;
closedir DIR;
}
my %fmt = map { (lc($_) => "DBI::Fmt$_") } @fmt;
$fmt{box} = "DBI::Format::Box";
$fmt{neat} = "DBI::Format::Neat";
$fmt{raw} = "DBI::Format::Raw";
my $formatters = \%fmt;
if ($use_abbrev) {
$formatters = abbrev(keys %fmt);
foreach my $abbrev (keys %$formatters) {
$formatters->{$abbrev} = $fmt{ $formatters->{$abbrev} } || die;
}
}
return $formatters;
}
sub formatter {
my ($class, $mode, $use_abbrev) = @_;
$mode = lc($mode);
my $formatters = available_formatters($use_abbrev);
my $fmt = $formatters->{$mode};
if (!$fmt) {
$formatters = available_formatters(0);
die "Format '$mode' unavailable. Available formats: ".
join(", ", sort keys %$formatters)."\n";
}
no strict 'refs';
unless (%{$class."::"}) {
eval "require $fmt";
die "$@\n" if $@;
}
return $fmt;
}
package DBI::Format::Base;
sub new {
my $class = shift;
my $self = (@_ == 1) ? { %{shift()} } : { @_ };
bless ($self, (ref($class) || $class));
$self;
}
sub setup_fh {
my ($self, $fh) = @_;
if (ref($fh) =~ m/glob/i) {
return $fh;
}
$fh ||= \*STDOUT;
if ($fh !~ /=/) { # not blessed
require FileHandle;
bless $fh => "FileHandle";
}
return $fh;
}
sub trailer {
my($self) = @_;
my $fh = delete $self->{'fh'};
my $sth = delete $self->{'sth'};
my $rows = delete $self->{'rows'};
print $fh ("[$rows rows of $sth->{NUM_OF_FIELDS} fields returned]\n");
delete $self->{'sep'};
}
package DBI::Format::Neat;
@DBI::Format::Neat::ISA = qw(DBI::Format::Base);
sub header {
my($self, $sth, $fh, $sep) = @_;
$self->{'fh'} = $self->setup_fh($fh);
$self->{'sth'} = $sth;
$self->{'rows'} = 0;
$self->{'sep'} = $sep;
print $fh (join($sep, @{$sth->{'NAME'}}), "\n");
}
sub row {
my($self, $rowref) = @_;
my @row = @$rowref;
# XXX note that neat/neat_list output is *not* ``safe''
# in the sense the it does not escape any chars and
# may truncate the string and may translate non-printable chars.
# We only deal with simple escaping here.
foreach(@row) {
next unless defined;
s/'/\\'/g;
s/\n/ /g;
}
my $fh = $self->{'fh'};
print $fh (DBI::neat_list(\@row, 9999, $self->{'sep'}),"\n");
++$self->{'rows'};
}
package DBI::Format::Box;
@DBI::Format::Box::ISA = qw(DBI::Format::Base);
sub header {
my($self, $sth, $fh, $sep) = @_;
$self->{'fh'} = $self->setup_fh($fh);
$self->{'sth'} = $sth;
$self->{'data'} = [];
$self->{'sep'} = $sep;
my $types = $sth->{'TYPE'};
my @right_justify;
my @widths;
my $names = $sth->{'NAME'};
my $type;
for (my $i = 0; $i < $sth->{'NUM_OF_FIELDS'}; $i++) {
push(@widths, defined($names->[$i]) ? length($names->[$i]) : 0);
$type = $types->[$i];
push(@right_justify,
($type == DBI::SQL_NUMERIC() ||
$type == DBI::SQL_DECIMAL() ||
$type == DBI::SQL_INTEGER() ||
$type == DBI::SQL_SMALLINT() ||
$type == DBI::SQL_FLOAT() ||
$type == DBI::SQL_REAL() ||
$type == DBI::SQL_BIGINT() ||
$type == DBI::SQL_TINYINT()));
}
$self->{'widths'} = \@widths;
$self->{'right_justify'} = \@right_justify;
}
sub row {
my($self, $orig_row) = @_;
my $i = 0;
my $col;
my $widths = $self->{'widths'};
my @row = @$orig_row; # don't mess with the original row
map {
if (!defined($_)) {
$_ = ' (NULL) ';
} else {
$_ =~ s/\n/\\n/g;
$_ =~ s/\t/\\t/g;
$_ =~ s/[\000-\037\177-\237]/./g;
}
if (length($_) > $widths->[$i]) {
$widths->[$i] = length($_);
}
++$i;
} @row;
push @{$self->{data}}, \@row;
}
sub trailer {
my $self = shift;
my $widths = delete $self->{'widths'};
my $right_justify = delete $self->{'right_justify'};
my $sth = $self->{'sth'};
my $data = $self->{'data'};
$self->{'rows'} = @$data;
my $format_sep = '+';
my $format_names = '|';
my $format_rows = '|';
for (my $i = 0; $i < $sth->{'NUM_OF_FIELDS'}; $i++) {
$format_sep .= ('-' x $widths->[$i]) . '+';
$format_names .= sprintf("%%-%ds|", $widths->[$i]);
$format_rows .= sprintf("%%"
. ($right_justify->[$i] ? "" : "-") . "%ds|",
$widths->[$i]);
}
$format_sep .= "\n";
$format_names .= "\n";
$format_rows .= "\n";
my $fh = $self->{'fh'};
print $fh ($format_sep);
print $fh (sprintf($format_names, @{$sth->{'NAME'}}));
foreach my $row (@$data) {
print $fh ($format_sep);
print $fh (sprintf($format_rows, @$row));
}
print $fh ($format_sep);
$self->SUPER::trailer(@_);
}
package DBI::Format::Raw;
@DBI::Format::Raw::ISA = qw(DBI::Format::Base);
sub header {
my($self, $sth, $fh, $sep) = @_;
$self->{'fh'} = $self->setup_fh($fh);
$self->{'sth'} = $sth;
$self->{'rows'} = 0;
$self->{'sep'} = $sep;
print $fh (join(',', @{$sth->{'NAME'}}), "\n");
}
sub row {
my($self, $rowref) = @_;
local( $^W = 0 );
my @row = @$rowref;
my $fh = $self->{'fh'};
print $fh (join($self->{'sep'}, @row), "\n");
++$self->{'rows'};
}
1;
=head1 NAME
DBI::Format - A package for displaying result tables
=head1 SYNOPSIS
# create a new result object
$r = DBI::Format->new('var1' => 'val1', ...);
# Prepare it for output by creating a header
$r->header($sth, $fh);
# In a loop, display rows
while ($ref = $sth->fetchrow_arrayref()) {
$r->row($ref);
}
# Finally create a trailer
$r->trailer();
=head1 DESCRIPTION
THIS PACKAGE IS STILL VERY EXPERIMENTAL. THINGS WILL CHANGE.
This package is used for making the output of DBI::Shell configurable.
The idea is to derive a subclass for any kind of output table you might
create. Examples are
=over 8
=item *
a very simple output format as offered by DBI::neat_list().
L<"AVAILABLE SUBCLASSES">.
=item *
a box format, as offered by the Data::ShowTable module.
=item *
HTML format, as used in CGI binaries
=item *
postscript, to be piped into lpr or something similar
=back
In the future the package should also support interactive methods, for
example tab completion.
These are the available methods:
=over 8
=item new(@attr)
=item new(\%attr)
(Class method) This is the constructor. You'd rather call a subclass
constructor. The construcor is accepting either a list of key/value
pairs or a hash ref.
=item header($sth, $fh)
(Instance method) This is called when a new result table should be
created to display the results of the statement handle B<$sth>. The
(optional) argument B<$fh> is an IO handle (or any object supporting
a I<print> method), usually you use an IO::Wrap object for STDIN.
The method will query the B<$sth> for its I<NAME>, I<NUM_OF_FIELDS>,
I<TYPE>, I<SCALE> and I<PRECISION> attributes and typically print a
header. In general you should not assume that B<$sth> is indeed a DBI
statement handle and better treat it as a hash ref with the above
attributes.
=item row($ref)
(Instance method) Prints the contents of the array ref B<$ref>. Usually
you obtain this array ref by calling B<$sth-E<gt>fetchrow_arrayref()>.
=item trailer
(Instance method) Once you have passed all result rows to the result
package, you should call the I<trailer> method. This method can, for
example print the number of result rows.
=back
=head1 AVAILABLE SUBCLASSES
First of all, you can use the DBI::Format package itself: It's
not an abstract base class, but a very simple default using
DBI::neat_list().
=head2 Ascii boxes
This subclass is using the I<Box> mode of the I<Data::ShowTable> module
internally. L<Data::ShowTable(3)>.
=head2 Raw
Row is written without formating. Columns returned in comma | user defined
separated list.
=head1 AUTHOR AND COPYRIGHT
This module is Copyright (c) 1997, 1998
Jochen Wiedmann
Am Eisteich 9
72555 Metzingen
Germany
Email: joe@ispsoft.de
Phone: +49 7123 14887
The DBD::Proxy module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 SEE ALSO
L<DBI::Shell(3)>, L<DBI(3)>, L<dbish(1)>