File Coverage

blib/lib/HTML/Table/FromDatabase.pm

Criterion	Covered	Total	%
statement	18	115	15.6
branch	0	56	0.0
condition	0	27	0.0
subroutine	6	12	50.0
pod	1	1	100.0
total	25	211	11.8

package HTML::Table::FromDatabase;

use 5.005000;
use strict;
no warnings 'uninitialized';
use base qw(HTML::Table);
use vars qw($VERSION);
use HTML::Table;

$VERSION = '1.10';

# $Id$

=head1 NAME

HTML::Table::FromDatabase - a subclass of HTML::Table to easily generate a HTML table from the result of a database query

=head1 SYNOPSIS

 my $sth = $dbh->prepare('select * from my_table')
    or die "Failed to prepare query - " . $dbh->errstr;
 $sth->execute() or die "Failed to execute query - " . $dbh->errstr;

 my $table = HTML::Table::FromDatabase->new( -sth => $sth );
 $table->print;

=head1 DESCRIPTION

Subclasses L, providing a quick and easy way to produce HTML
tables from the result of a database query.

I often find myself writing scripts which fetch data from a database and
present it in a HTML table; often resulting in pointlessly repeated code
to take the results and turn them into a table.

L itself helps here, but this module makes it even simpler.

Column headings are taken from the field names returned by the query, unless
overridden with the I<-override_headers> or I<-rename_headers> options.

All options you pass to the constructor will be passed through to HTML::Table,
so you can use all the usual L features.


=head1 INTERFACE

=over 4

=item new

Constructor method - consult L's documentation, the only
difference here is the addition of the following parameters:

=over 4

=item C<-sth>

(required) a DBI statement handle which has been executed and is ready
to fetch data from

=item C<-callbacks>

(optional) specifies callbacks/transformations which should be applied as the
table is built up (see the L section below).

=item C<-html>

(optional) can be I or I if you want HTML to be escaped
(angle brackets replaced with < and >) or stripped out with HTML::Strip.

=item C<-override_headers>

(optional) provide a list of names to be used as the column headings, instead of
using the names of the columns returned by the SQL query.  This should be an
arrayref containing the heading names, and the number of heading names must
match the number of columns returned by the query.

=item C<-rename_headers>

(optional) provide a hashref of oldname => newname pairs to rename some or all
of the column names returned by the query when generating the table headings.

=item C<-auto_pretty_headers>

(optional, boolean) - automatically make column names nicer for headings,
using titlecase and swapping underscores for spaces etc (e.g. C
becomes C)

=item C<-pad_empty_cells>

(optional, default 1) pad empty cells with an C< > to ensure they're
rendered with borders appropriately.  Many browsers "skip" empty cells, leading
to missing borders around them, which many people consider broken.  To stop
this, by default empty cells receive a non-breaking space as their content.  If
you don't want this behaviour, set this option to a false value.

=back

=cut

sub new {
    my $class = shift;

    my %flags = @_;
    my $sth = delete $flags{-sth};

    if (!$sth || !ref $sth || !$sth->isa('DBI::st')) {
        warn "HTML::Table::FromDatabase->new requires the -sth argument,"
            ." which must be a valid DBI statement handle.";
        return;
    }

    my $callbacks = delete $flags{-callbacks};
    if ($callbacks && ref $callbacks ne 'ARRAY') {
        warn "Unrecognised -callbacks parameter; "
            ."expected a arrayref of hashrefs";
        return;
    }

    my $row_callbacks = delete $flags{-row_callbacks};
    if ($row_callbacks && ref $row_callbacks ne 'ARRAY') {
        warn "Unrecognised -row_callbacks parameter; "
            . "expected an arrayref of coderefs";
        return;
    }

    my $override_headers = delete $flags{-override_headers};
    if ($override_headers && ref $override_headers ne 'ARRAY') {
        warn "Unrecognised -override_headers parameter; "
            ."expected an arrayref";
        return;
    }

    my $rename_headers = delete $flags{-rename_headers};
    if ($rename_headers && ref $rename_headers ne 'HASH') {
        warn "Unrecognised -rename_headers parameter; "
            ."expected a hashref";
        return;
    }

    $flags{-pad_empty_cells} = 1 unless exists $flags{-pad_empty_cells};

    my $auto_pretty_headers = delete $flags{-auto_pretty_headers};


    # if we're going to encode or escape HTML, prepare to do so:
    my $preprocessor;
    if (my $handle_html = delete $flags{-html}) {
        if ($handle_html eq 'strip') {
            eval "require HTML::Strip;";
            if ($@) {
                warn "Failed to load HTML::Strip - cannot strip HTML";
                return;
            }
            my $hs = new HTML::Strip;
            $preprocessor = sub { $hs->eof; return $hs->parse(shift) };
        } elsif ($handle_html eq 'encode' || $handle_html eq 'escape') {
            eval "require HTML::Entities;";
            if ($@) {
                warn "Failed to load HTML::Entities - cannot encode HTML";
                return;
            }
            $preprocessor = sub { HTML::Entities::encode_entities(shift); };
        } else {
            warn "Unrecognised -html option.";
            return;
        }
    }

    # Create a HTML::Table object, passing along any other options we were
    # given:
    my $self = HTML::Table->new(%flags);

    # Find the names;
    my @columns = @{ $sth->{NAME} };

    # Default to using the column names as headings, unless we've been given
    # an -override_headers or -rename_headers option (if we got the
    # -auto_pretty_headers option, prettify them somewhat):
    my @heading_names = @columns;
    for (@heading_names) {
        if (exists $rename_headers->{$_}) {
            $_ = $rename_headers->{$_};
        } elsif ($auto_pretty_headers) {
            $_ = _prettify($_);
        }
    }

    if ($override_headers) {
        if (@$override_headers != @heading_names) {
            warn "Incorrect number of header names in -override_headers option"
                ." - got " . @$override_headers . ", needed " .  @heading_names;
        }
        @heading_names = @$override_headers;
    }

    $self->addSectionRow('thead', 0, @heading_names);
    $self->setSectionRowHead('thead', 0, 1);

    # Add all the rows:
    row:
    while (my $row = $sth->fetchrow_hashref) {
        # First, if there are any row callbacks, call them:
        for my $callback (@$row_callbacks) {
            $callback->($row);
        }

        # If the callback undefined $row, we should skip it:
        next row if !defined $row;

        # Now, work through each field
        my @fields;
        for my $column (@columns) {
            my $value = $row->{$column};

            if ($preprocessor) {
                $value = $preprocessor->($value);
            }


            # If we have a callback to perform for this field, do it:
            for my $callback (@$callbacks) {
                # See what we need to match against, and if it matches, call
                # the specified transform callback to potentially change the
                # value.
                if (exists $callback->{column}) {
                    if (_callback_matches($callback->{column}, $column)) {
                        $value = _perform_callback(
                           $callback, $column, $value, $row
                        );
                    }
                }
                if (exists $callback->{value}) {
                    if (_callback_matches($callback->{value}, $value)) {
                        $value = _perform_callback(
                            $callback, $column, $value, $row
                        );
                    }
                }
            }

            # If the value is empty, turn it into a non-breaking space to make
            # the cell still display correctly (otherwise it looks ugly):
            $value = ' ' if $value eq '' && $flags{-pad_empty_cells};

            # Add this field to the list to deal with:
            push @fields, $value;
        }

        $self->addRow(@fields);
    }

    # All done, re-bless into our class and return
    bless $self, $class;
    return $self;
};

# Abstract out the different kind of matches (regexp, coderef or straight
# scalar)
sub _callback_matches {
    my ($match, $against) = @_;
    if (ref $match eq 'Regexp') {
        return $against =~ /$match/;
    } elsif (ref $match eq 'CODE') {
        return $match->($against);
    } elsif (ref $match) {
        # A reference to something we don't understand:
        warn "Unrecognised callback match [$match]";
        return;
    } else {
        # Must be a straight scalar
        return $match eq $against;
    }
}

# A callback spec matched, so perform any callback it requests, and apply
# any transformation it described:
sub _perform_callback {
    my ($callback, $column, $value,$row) = @_;

    # Firstly, if there's a callback to perform, we call it (but don't
    # care what it returns):
    if (exists $callback->{callback} and ref $callback->{callback} eq 'CODE')
    {
        $callback->{callback}->($value, $row);
    }

    # Now, look for a transformation we might have to perform:
    if (!exists $callback->{transform}) {
        # We don't have a transform to perform, so just return the value
        # unchanged:
        return $value;
    }
    if (ref $callback->{transform} ne 'CODE') {
        warn "Unrecognised transform action";
        return $value;
    }

    # OK, apply the transformation to the value:
    return $callback->{transform}->($value, $row);
}

sub _prettify {
    s{_}{ }g; s{\b(\w)}{\u$1}g; $_;
}

1;
__END__;