File Coverage

blib/lib/HTML/QuickTable.pm

Criterion	Covered	Total	%
statement	147	203	72.4
branch	92	122	75.4
condition	50	80	62.5
subroutine	11	14	78.5
pod	2	2	100.0
total	302	421	71.7

package HTML::QuickTable;

=head1 NAME

HTML::QuickTable - Quickly create fairly complex HTML tables

=head1 SYNOPSIS

    use HTML::QuickTable;

    my $qt = HTML::QuickTable->new(
                   table_width  => '95%',       # opt method 1
                   td => {bgcolor => 'gray'},   # opt method 2
                   font_face => 'arial',        # set font
                   font => {face => 'arial'},   # same thing
                   labels => 1,                 # make top
                   stylesheet => 1,             # use stylesheet?
                   styleclass => 'mytable',     # class to use
                   useid  => 'results',         # id="results_r1c2" etc
                   header => 0,                 # print header?
             );

    my $table1 = $qt->render(\@array_of_data);

    my $table2 = $qt->render(\%hash_of_keys_and_values);

    my $table3 = $qt->render($object_with_param_method);

=cut

use Carp;
use strict;
use vars qw($VERSION %INDENT);

$VERSION = do { my @r=(q$Revision: 1.12 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
%INDENT  = (
   table => 0,
   tr    => 1,
   th    => 2,
   td    => 2,
);

sub _expopts {
    # This is a general-purpose option-parsing routine that
    # puts stuff down one level if it has a _ in it; this
    # allows stuff like "td_height => 50" and "td => {height => 50}"
    my $lev = shift || 0;
    my %opt = ();
    $lev++;
    while (@_) {
        my $key = shift;
        my $val = shift;
        if ($key =~ /^([a-zA-Z0-9]+)_(.*)/) {
            # looks like "td_height" or "font_face"
            $opt{$1}{$2} = $val;
        } elsif (ref $val eq 'HASH') {
            # this allows "table => {width => '95%'}"
            $opt{$key} = _expopts($lev, %$val);
        } elsif ($key eq 'font' && $lev == 1) {
            # special catch for two options to be FormBuilder-like
            $opt{font}{face} = $val;
        } elsif ($key eq 'lalign' && $lev == 1) {
            $opt{th}{align} = $val;
        } elsif ($key eq 'border' && $lev == 1) {
            # useful shortcut
            $opt{table}{border} = $val;
        } else {
            # put regular options in the top-level space
            $opt{$key} = $val;
        }
    }
    $lev--;
    return wantarray ? %opt : \%opt;
}

sub new {
    my $self = shift;
    my $class = ref($self) || $self;
    my %opt = _expopts(0, @_);

    # counters
    $opt{_level} = 0;
    $opt{_sentheader} = 0;

    # special options
    $opt{table}{border} = delete $opt{border} if exists $opt{border};  # legacy
    $opt{body} ||= {bgcolor => 'white'};
    $opt{null} ||= '';      # prevents warnings

    # stylesheet handling
    if ($opt{stylesheet}) {
        $opt{styleclass} ||= 'qt';
        delete $opt{font};  # kill font
    }

    # setup our font tag separately
    # do this here or else every call to render() must do it
    ($opt{_fo}, $opt{_fc}) = $opt{font}
                                ? (_tag('font', %{$opt{font}}), '')
                                : ('','');

    return bless \%opt, $class;
}

# Internal tag routines stolen from CGI::FormBuilder, which
# in turn stole them from CGI.pm

sub _escapeurl ($) {
    # minimalist, not 100% correct, URL escaping
    my $toencode = shift || return undef;
    $toencode =~ s!([^a-zA-Z0-9_,.-/])!sprintf("%%%02x",ord($1))!eg;
    return $toencode;
}

sub _escapehtml ($) {
    defined(my $toencode = shift) or return '';
    eval { require  HTML::Entities };
    if ($@) {
        # not found; use very basic built-in HTML escaping
        $toencode =~ s!&!&!g;
        $toencode =~ s!
        $toencode =~ s!>!>!g;
        $toencode =~ s!"!"!g;
        return $toencode;
    } else {
        # dispatch to HTML::Entities
        return HTML::Entities::encode($toencode);
    }
    return $toencode;
}

sub _tag ($;@) {
    # called as _tag('tagname', %attr)
    # creates an HTML tag on the fly, quick and dirty
    my $name = shift || return;
    my @tag;
    my %saw = ();   # prevent dups
    while (@_) {
        # this cleans out all the internal junk kept in each data
        # element, returning everything else (for an html tag)
        my $key = lc shift;
        my $val = _escapehtml shift;    # minimalist HTML escaping
        push @tag, qq($key="$val") unless $saw{$key}++;
    }
    return '<' . join(' ', $name, sort @tag) . '>';
}

sub _tohtml ($) {
    defined(my $text = shift) or return;

    # Need to catch the < and > commonly used in emails
    $text = _escapehtml($text);

    # A couple little catches
    $text =~ s!\*([^\*]+)\*!$1!g;
    $text =~ s!\_([^\_]+)\_!$1!g;

    # Also catch links - remember there are a LOT of assumptions here!!!
    $text =~ s!(http[s]?://[\=\.\-\/\w+\?]+)(\s+)!$1$2!g;
    $text =~ s!([\w\.\-\+\_]+\@[\w\-\.]+)!$1!g;       # email addrs

    return $text;
}

sub _toname ($) {
    # creates a name from a var/file name (like file2name)
    my $name = shift;
    $name =~ s!\.\w+$!!;        # lose trailing ".cgi" or whatever
    $name =~ s![^a-zA-Z0-9.-/]+! !g;
    $name =~ s!\b(\w)!\u$1!g;
    return $name;
}

# These handle styleclass and id generation, if requested
sub _getclass {
    my $self = shift;
    return '' unless $self->{stylesheet};
    my $row  = shift || 0;  # is a row

    # if styleclass is an array, alternate between
    my $class = '';
    if (ref $self->{styleclass} eq 'ARRAY') {
        if ($row && $self->{_notfirstrow}) {   # only alternate rows
            push @{$self->{_tmpclass}||=[]}, shift @{$self->{styleclass}};
            unless (@{$self->{styleclass}}) {
                # have pushed thru all, so start over
                $self->{styleclass} = delete $self->{_tmpclass};
            }
        }
        $class = $self->{styleclass}[0];
    } else {
        $class = $self->{styleclass};
    }
    return $class;
}

# Generate a unique id for each element
sub _getid {
    my $self = shift;
    return '' unless $self->{useid};
    my $base = join '', @_;  # rest is 'r', 42, 'c', 15, etc
    return $base ? "$self->{useid}_$base" : $self->{useid};
}

# Keep track of the appropriate indent
sub _indent {
    local $^W = 0;
    my $self = shift;
    my $what = shift;   # element name
    return '  ' x $INDENT{$what};
    my $last = $self->{_lastidt} || '';
    if (! $last) {
        # first layer
        $self->{_indent} = 0;
    } elsif ($what eq $last) {
        # nothing, same
        $self->{_indent} ||= 0
    } elsif ($INDENT{$what} > $INDENT{$last}) {
        # use it as a base
        $self->{_indent}++;
    } elsif ($INDENT{$what} < $INDENT{$last}) {
        # we're nesting
        $self->{_indent}--;
    }
    $self->{_lastidt} = $what;
    return '  ' x ($self->{_indent} * $INDENT{$last});
}

# This recursively renders a data structure into a table
sub render {
    # Do the work and return as a scalar
    my $self = shift;
    my($data, $html) = ('','');
    my $ref = ref $_[0];
    if (@_ > 1) {
        # assume that it's an array
        $ref = 'ARRAY';
        $data = [ @_ ];
    } elsif ($ref) {
        # shift it
        $data = shift;
    } elsif (! $self->{_level}) {
        croak '[HTML::QuickTable] Argument to render() must be \@array, \%hash, or $object';
    } else {
        $ref = 'ARRAY';
        $data = [ @_ ];
    }

    # We expand data differently depending on what type of structure it is
    # Truthfully, all this sub can handle is arrayrefs. Everything else
    # is converted on the fly by the "else" statement to an arrayref and
    # this sub is recursively called.

    if ($ref eq 'ARRAY') {

        # create our opening table tag
        my $tab = $self->{_level} ? {width => '100%'} : $self->{table};
        $tab->{id}    = $self->_getid    if $self->{useid};
        $tab->{class} = $self->_getclass if $self->{stylesheet};
        $html .= _tag('table', %$tab) . "\n" unless ++$self->{_level} == 2;

        my @tmprow = ();
        if ($self->{vertical} && ref $data->[0] eq 'ARRAY') {
            # Whole different algorithm, here we must iterate in a column-
            # based manner, not a row-based one. This means walking the
            # array "backwards". Notice the for loops iterate inside-out.
            for (my $ci=0; $ci < @{$data->[0]}; $ci++) {
                $tmprow[$ci] = [];
                for (my $ri=0; $ri < @$data; $ri++) {
                    push @{$tmprow[$ci]}, $data->[$ri][$ci];
                }
            }
        } else {
            # non-vertical or already expanded/rearranged
            @tmprow = @$data;
        }

        # Now, walk all arrays in the same manner, since vert's were rearranged
        my $colnum = 0;
        $self->{_rownum} ||= 0;
        for my $row (@tmprow) {
            unless ($self->{_level} == 2) {
                $self->{tr}{id}    = $self->_getid('r', ++$self->{_rownum}) if $self->{useid};
                $self->{tr}{class} = $self->_getclass(1) if $self->{stylesheet};
                $html .= ' ' . _tag('tr', %{$self->{tr}}) . "\n";
            }
            if ($self->{_level} == 1) {
                $html .= $self->render($row);
            }
            else {
                # For an array, we do not generate
                # time per the row/column
                my $td = 'td';
                if (my $l = $self->{labels}) {
                    if (($l =~ /[1T]/i && ! $self->{_notfirstrow})
                      || ($l =~ /L/i && ! $colnum)
                      || ($l =~ /R/i && $colnum == (@tmprow-1))
                    ) {
                        $td = 'th';
                    } elsif ($l =~ /B/i) {
                        croak "[HTML::QuickTable] Sorry, labels => 'B' is broken - want to patch it?";
                    }
                }

                # Catch td class stuff
                $self->{$td}{id}    = $self->_getid('r', $self->{_rownum}, 'c', $colnum+1) if $self->{useid};
                $self->{$td}{class} = $self->_getclass if $self->{stylesheet};

                # Recurse data structures
                if (ref $row) {
                    $html .= '  ' . _tag($td, %{$self->{$td}}) . $self->{_fo}
                                  . $self->render($row) . $self->{_fc} . "\n";
                }
                else {
                    $row = _toname($row) if $self->{nameopts} && $td eq 'th';
                    $row = _tohtml($row) if $self->{htmlize};
                    my $tdptr = $self->{$td};
                    unless (defined $row) {
                        # "null", so alter HTML accordingly
                        $row = $self->{null};
                        $tdptr = $self->{nulltags} if $self->{nulltags};
                        $tdptr->{id}    = $self->_getid('r', $self->{_rownum}, 'c', $colnum+1) if $self->{useid};
                        $tdptr->{class} ||= $self->_getclass if $self->{stylesheet};
                    }
                    $html .= '  ' . _tag($td, %{$tdptr}) . $self->{_fo}
                                  . $row . $self->{_fc} . "\n";
                }
            }
            unless ($self->{_level} == 2) {
                $html .= "
            }
            $colnum++;
        }
        $html .= '