HTML::Tabulate - HTML table rendering class

    use HTML::Tabulate qw(render);

    # Setup a simple table definition hashref
    $table_defn = { 
        table => { border => 0, cellpadding => 0, cellspacing => 3 },
        th => { class => 'foobar' },
        null => ' ',
        labels => 1,
        stripe => '#cccccc',
    };

    # Render a dataset using this table definition (procedural version)
    print render($dataset, $table_defn);

    # Object-oriented version
    $t = HTML::Tabulate->new($table_defn);
    print $t->render($dataset);

    # Setup some dataset specific settings
    $table_defn2 = {
        fields => [ qw(emp_id name title edit new_flag) ],
        field_attr => {
            # format employee ids, add a link to employee page
            emp_id => {
                format => '%-05d',
                link => "emp.html?id=%s",
                link_target => '_blank',
                align => 'right',
            },
            # uppercase all names
            qr/name$/ => { format => sub { uc(shift) } },
            # highlight new employees
            new_flag => {
                class => sub { 
                    my ($data, $row, $field) = @_;
                    $data =~ m/^y$/i ? 'new' : 'old';
                },
            },
        },
    };

    # Render the table using the original and additional settings
    print $t->render($data, $table_defn2);

    package My::Tabulate;
    use base qw(HTML::Tabulate);

    sub new {
        my $class = shift;
        my $defn = shift || {};
        my %defaults = (
            # define table defaults here e.g.
            table => { border => 1 },
            labels => { foo => 'FOO', bar => 'BAR' },
        );
        my $self = $class->SUPER::new(\%defaults);
        $self->merge($defn);
        return $self;
    }

    1;

package HTML::Tabulate;

use 5.005;
use Carp;
use URI::Escape;
use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $TITLE_HEADING_LEVEL);

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw(&render);

$VERSION = '0.35';
my $DEFAULT_TEXT_FORMAT = "<p>%s</p>\n";
my %DEFAULT_DEFN = (
    style       => 'down', 
    table       => {},
    title       => { format => "<h2>%s</h2>\n" },
    text        => { format => $DEFAULT_TEXT_FORMAT },
    caption     => { type => 'caption', format => $DEFAULT_TEXT_FORMAT },
    field_attr  => { -defaults => {}, },
);
my %VALID_ARG = (
    table => 'HASH/SCALAR',
    thead => 'HASH/SCALAR',
    tbody => 'HASH/SCALAR',
    tr => 'HASH/CODE', 
    thtr => 'HASH',
    th => 'HASH',
    td => 'HASH',
    fields => 'ARRAY',
    fields_add => 'HASH',
    fields_omit => 'ARRAY',
    in_fields => 'ARRAY',
    labels => 'SCALAR/HASH',
    label_links => 'HASH',
    stripe => 'ARRAY/SCALAR/HASH',
    null => 'SCALAR',
    trim => 'SCALAR',
    style => 'SCALAR',
#   limit => 'SCALAR',
#   output => 'SCALAR',
#   first => 'SCALAR',
#   last => 'SCALAR',
    field_attr => 'HASH',
    # xhtml: boolean indicating whether to use xhtml-style tagging
    xhtml => 'SCALAR',
    # title: title/heading to be rendered above table
    title => 'SCALAR/HASH/CODE',
    # text: text to be rendered above table, after title
    text => 'SCALAR/HASH/CODE',
    # caption: text to be rendered below table
    caption => 'SCALAR/HASH/CODE',
    # data_append: data rows to appended to main dataset
    data_append => 'ARRAY',
);
my %VALID_FIELDS = (
    -defaults => 'HASH',
);
my %FIELD_ATTR = (
    escape => 'SCALAR',
    value => 'SCALAR/CODE',
    format => 'SCALAR/CODE',
    link => 'SCALAR/CODE',
    label => 'SCALAR/CODE',
    label_format => 'SCALAR/CODE',
    label_link => 'SCALAR/CODE',
    label_escape => 'SCALAR',
    default => 'SCALAR',
    composite => 'ARRAY',
    composite_join => 'SCALAR/CODE',
);
my %MINIMISED_ATTR = map { $_ => 1 } qw(
    checked compact declare defer disabled ismap multiple 
    nohref noresize noshade nowrap readonly selected 
);
my $URI_ESCAPE_CHARS = "^A-Za-z0-9\-_.!~*'()?&;:/=";
$TITLE_HEADING_LEVEL = 'h2';   # TODO: deprecated

# -------------------------------------------------------------------------
# Provided for subclassing
sub get_valid_arg
{
    return wantarray ? %VALID_ARG : \%VALID_ARG;
}

# Provided for subclassing
sub get_valid_fields
{
    return wantarray ? %VALID_FIELDS : \%VALID_FIELDS;
}

# Provided for subclassing
sub get_field_attributes
{
    return wantarray ? %FIELD_ATTR : \%FIELD_ATTR;
}

#
# Check $self->{defn} for invalid arguments or types
#
sub check_valid
{
    my ($self, $defn) = @_;

    # Check top-level args
    my %valid = $self->get_valid_arg();
    my (@invalid, @badtype);
    for (sort keys %$defn) {
        if (! exists $valid{$_}) {
            push @invalid, $_;
            next;
        }
        my $type = ref $defn->{$_};
        push @badtype, $_ 
            if $type && $type ne 'SCALAR' && $valid{$_} !~ m/$type/;
        push @badtype, $_ 
            if ! $type && $valid{$_} !~ m/SCALAR/;
    }
    croak "[check_valid] invalid argument found: " . join(',',@invalid) 
        if @invalid;
    croak "[check_valid] invalid types for argument: " . join(',',@badtype)
        if @badtype;

    # Check special fields
    %valid = $self->get_valid_fields();
    @invalid = ();
    @badtype = ();
    for (sort grep(/^-/, keys(%{$defn->{field_attr}})) ) {
        if (! exists $valid{$_}) {
            push @invalid, $_;
            next;
        }
        my $type = ref $defn->{field_attr}->{$_};
        push @badtype, $_ 
            if $type && $type ne 'SCALAR' && $valid{$_} !~ m/$type/;
        push @badtype, $_ 
            if ! $type && $valid{$_} !~ m/SCALAR/;
    }
    croak "[check_valid] invalid field argument found: " . join(',',@invalid) 
        if @invalid;
    croak "[check_valid] invalid types for field argument: " . join(',',@badtype)
        if @badtype;

    # Check field attributes
    $self->{field_attr} ||= $self->get_field_attributes();
    %valid = %{$self->{field_attr}};
    @badtype = ();
    for my $field (keys %{$defn->{field_attr}}) {
        croak "[check_valid] invalid field argument entry '$field': " . 
            $defn->{field_attr}->{$field} 
                if ref $defn->{field_attr}->{$field} ne 'HASH';
        for (sort keys %{$defn->{field_attr}->{$field}}) {
            next if ! exists $valid{$_};
            next if ! $valid{$_};
            my $type = ref $defn->{field_attr}->{$field}->{$_};
            if (! ref $valid{$_}) {
                push @badtype, $_ 
                    if $type && $type ne 'SCALAR' && $valid{$_} !~ m/$type/;
                push @badtype, $_ 
                    if ! $type && $valid{$_} !~ m/SCALAR/;
            }
            elsif (ref $valid{$_} eq 'ARRAY') {
                if ($type) {
                    push @badtype, $_;
                }
                else {
                    my $val = $defn->{field_attr}->{$field}->{$_};
                    push @badtype, "$_ ($val)" if ! grep /^$val$/, @{$valid{$_}};
                }
            }
            else {
                croak "[check_valid] invalid field attribute entry for '$_': " . 
                    ref $valid{$_};
            }
        }
        croak "[check_valid] invalid type for '$field' field attribute: " . 
            join(',',@badtype) if @badtype;
    }
}

#
# Merge $hash1 and $hash2 together, returning the result (or, in void 
#   context, merging into $self->{defn}). Performs a shallow (one-level deep)
#   hash merge unless the field is defined in the @recurse_keys array, in 
#   which case we do a full recursive merge.
#
sub merge
{
    my $self = shift;
    my $hash1 = shift || {};
    my $hash2 = shift;
    my $arg = shift;

    croak "[merge] invalid hash1 '$hash1'" if ref $hash1 ne 'HASH';
    croak "[merge] invalid hash2 '$hash2'" if $hash2 && ref $hash2 ne 'HASH';

    my $single_arg = ! $hash2;

    # Use $self->{defn} as $hash1 if only one argument
    if ($single_arg) {
        $hash2 = $hash1;
        $hash1 = $self->{defn};
    }

    # Check hash2 for valid args (except when recursive)
    my $sub = (caller(1))[3] || '';
    $self->check_valid($hash2) unless substr($sub, -7) eq '::merge';

    my $merge = $self->deepcopy($hash1);

    # Add hash2 to $merge 
    my @recurse_keys = qw(field_attr);
    for my $key (keys %$hash2) {
        # If this value is a hashref on both sides, do a shallow hash merge
        #   unless we need to do a proper recursive merge
        if (ref $hash2->{$key} eq 'HASH' && ref $merge->{$key} eq 'HASH') {
            # Recursive merge
            if (grep /^$key$/, @recurse_keys) {
                $merge->{$key} = $self->merge($hash1->{$key}, $hash2->{$key});
            }
            # Shallow hash merge
            else {
                @{$merge->{$key}}{ keys %{$hash1->{$key}}, keys %{$hash2->{$key}} } = (values %{$hash1->{$key}}, values %{$hash2->{$key}});
            }
        }
        # Otherwise (scalars, arrayrefs etc) just copy the value
        else {
            $merge->{$key} = $hash2->{$key};
        }
    }

    # In void context update $self->{defn}
    if (! defined wantarray) {
        $self->{defn} = $merge;
        # Must invalidate transient $self->{defn_t} when $self->{defn} changes
        delete $self->{defn_t} if exists $self->{defn_t};
    }
    else {
        return $merge;
    }
}

sub defn
{
    my $self = shift;
    return $self->{defn};
}

# Initialisation
sub init
{
    my $self = shift;
    my $defn = shift || {};
    croak "[init] invalid defn '$defn'" if $defn && ref $defn ne 'HASH';

    # Map $defn table => 1 to table => {} for cleaner merging
    $defn->{table} = {} if $defn->{table} && ! ref $defn->{table};

    # Initialise $self->{defn} by merging defaults and $defn
    $self->{defn} = $self->merge(\%DEFAULT_DEFN, $defn);

    return $self;
}

sub new 
{
    my $class = shift;
    my $self = {};
    bless $self, $class;
    $self->init(@_);
}

# -------------------------------------------------------------------------
#
# If deriving field names, also derive labels (if not already defined)
#
sub derive_label
{
    my ($self, $field) = @_;
    $field =~ s/_+/ /g;
    $field = join ' ', map { ucfirst($_) } split(/\s+/, $field);
    $field =~ s/(Id)$/\U$1/;
    return $field;
}

#
# Try and derive a reasonable field list from $self->{defn_t} using the set data.
#   Croaks on failure.
#
sub derive_fields
{
    my ($self, $set) = @_;
    my $defn = $self->{defn_t};

    # For iterators, prefetch the first row and use its keys
    croak "invalid Tabulate data type '$set'" unless ref $set;
    if (ref $set eq 'CODE') {
        my $row = $set->();
        $self->{prefetch} = $row;
        $defn->{fields} = [ sort keys %$row ] if eval { keys %$row };
    }
    elsif (UNIVERSAL::isa($set,'UNIVERSAL') &&
            $set->can('First') && $set->can('Next')) {
        my $row = $set->First;
        $self->{prefetch} = $row;
        $defn->{fields} = [ sort keys %$row ] if eval { keys %$row };
    }
    elsif (UNIVERSAL::isa($set,'UNIVERSAL') &&
            $set->can('first') && $set->can('next')) {
        my $row = $set->first;
        $self->{prefetch} = $row;
        $defn->{fields} = [ sort keys %$row ] if eval { keys %$row };
    }
    # For arrays
    elsif (ref $set eq 'ARRAY') {
        if (! @$set) {
            $defn->{fields} = [];
            return;
        }
        my $obj = $set->[0];
        # Arrayref of hashrefs
        if (ref $obj eq 'HASH') {
            $defn->{fields} = [ sort keys %$obj ];
        }
        # Arrayref of arrayrefs - access via subscripts unless labels are defined
        elsif (ref $obj eq 'ARRAY') {
            if ($defn->{labels}) {
                croak "[derive_fields] no fields found and cannot derive fields from data arrayrefs";
            }
            # Arrayref of arrayrefs, labels off
            else {
                $defn->{fields} = [ 0 .. $#$obj ];
            }
        }
        # For Class::DBI objects, derive via columns groups
        elsif ($obj->isa('Class::DBI')) {
            my @col = $obj->columns('Tabulate');
            @col = ( $obj->columns('Essential'), $obj->columns('Others') ) 
                if ! @col && $obj->columns('Essential');
            @col = $obj->columns('All') if ! @col;
            $defn->{fields} = [ @col ] if @col;
        }
        # If all else fails, try treating as a hash
        unless (ref $defn->{fields} && @{$defn->{fields}}) {
            if (! defined eval { $defn->{fields} = [ sort keys %$obj ] }) {
                croak "[derive_fields] no fields found and initial object '$obj' is strange type";
            }
        }
    }
    # Else looks like a single object - check for Class::DBI
    elsif (ref $set && ref $set ne 'HASH' && $set->isa('Class::DBI')) {
        my @col = $set->columns('Tabulate');
        @col = ( $set->columns('Essential'), $set->columns('Others') ) 
            if ! @col && $set->columns('Essential');
        @col = $set->columns('All') if ! @col;
        $defn->{fields} = [ @col ] if @col;
    }
    # Otherwise try treating as a hash
    elsif (defined eval { keys %$set }) {
        my $first = (sort keys %$set)[0];
        my $ref = ref $set->{$first} if defined $first;
        # Check whether first value is reference
        if ($ref) {
            # Hashref of hashrefs
            if ($ref eq 'HASH') {
                $defn->{fields} = [ sort keys %{$set->{$first}} ];
            }
            elsif (ref $set->[0] ne 'ARRAY') {
                croak "[derive_fields] no fields found and first row '" . $set->[0] . "' is strange type";
            }
            # Hashref of arrayrefs - fatal only if labels => 1
            elsif ($defn->{labels}) {
                croak "[derive_fields] no fields found and cannot derive fields from data arrayrefs";
            }
            # Hashref of arrayrefs, labels off
            else {
                $defn->{fields} = [ 0 .. $#{$set->[$first]} ];
            }
        }
        else {
            $defn->{fields} = [ sort keys %$set ];
        }
    }
    else {
        croak "[derive_fields] no fields found and set '$set' is strange type: $@";
    }
    
    croak sprintf "[derive_fields] field derivation failed (fields: %s)", 
            $defn->{fields} 
        unless ref $defn->{fields} eq 'ARRAY';
}

# Derive a fields list if none is defined
sub check_fields
{
    my $self = shift;
    my ($set) = @_;
    $self->derive_fields($set) 
        if ! $self->{defn_t}->{fields} ||
         ref $self->{defn_t}->{fields} ne 'ARRAY' || 
         ! @{$self->{defn_t}->{fields}};
}

# Splice additional fields into the fields array
sub splice_fields
{
    my $self = shift;
    my $defn = $self->{defn_t};
    my $add = $defn->{fields_add};
    return unless ref $defn->{fields} eq 'ARRAY' && ref $add eq 'HASH';

    for (my $i = $#{$defn->{fields}}; $i >= 0; $i--) {
        my $f = $defn->{fields}->[$i];
        next unless $add->{$f};
        if (ref $add->{$f} eq 'ARRAY') {
            splice @{$defn->{fields}}, $i+1, 0, @{$add->{$f}};
        }
        else {
            splice @{$defn->{fields}}, $i+1, 0, $add->{$f};
        }
    }
}

# Omit/remove fields from the fields array
sub omit_fields
{
    my $self = shift;
    my $defn = $self->{defn_t};
    my %omit = map { $_ => 1 } @{$defn->{fields_omit}};
    $defn->{fields} = [ grep { ! exists $omit{$_} } @{$defn->{fields}} ];
}

#
# Deep copy routine, originally swiped from a Randal Schwartz column
#
sub deepcopy 
{
    my ($self, $this) = @_;
    if (! ref $this) {
        return $this;
    } elsif (ref $this eq "ARRAY") {
        return [map $self->deepcopy($_), @$this];
    } elsif (ref $this eq "HASH") {
        return {map { $_ => $self->deepcopy($this->{$_}) } keys %$this};
    } elsif (ref $this eq "CODE") {
        return $this;
    } elsif (sprintf $this) {
        # Object! As a last resort, try copying the stringification value
        return sprintf $this;
    } else {
        die "what type is $_? (" . ref($this) . ")";
    }
}

#
# Create a transient presentation definition (defn_t) by doing a set of one-off 
#   or dataset-specific mappings on the current table definition e.g. deriving 
#   a field list if none is set, setting up a field map for arrayref-of-
#   arrayref sets, and mapping top-level shortcuts into their field 
#   attribute equivalents.
#
sub prerender_munge
{
    my $self = shift;
    my ($set, $defn) = @_;

    # Use $self->{defn} if $defn not passed
    $defn ||= $self->{defn};

    # If already done, return unless we require any dataset-specific mappings
#   if ($self->{defn_t}) {
#       return unless 
#           ref $defn->{fields} ne 'ARRAY' || 
#           ! @{$defn->{fields}} ||
#           (ref $set eq 'ARRAY' && @$set && ref $set->[0] eq 'ARRAY');
#   }

    # Copy $defn to $self->{defn_t}
    $self->{defn_t} = $self->deepcopy($defn);

    # Try to derive field list if not set
    $self->check_fields($set);

    # Set up a field map in case we have arrayref based data
    my $defn_t = $self->{defn_t};
    my $pos = 0;
    my $fields = ref $defn_t->{in_fields} eq 'ARRAY' ? $defn_t->{in_fields} : $defn_t->{fields};
    $defn_t->{field_map} = { map  { $_ => $pos++; } @$fields };

    # Splice any additional fields into the fields array
    $self->splice_fields if $defn_t->{fields_add};
    $self->omit_fields if $defn_t->{fields_omit};

    # Map top-level 'labels' and 'label_links' hashrefs into fields
    if (ref $defn_t->{labels} eq 'HASH') {
        for (keys %{$defn_t->{labels}}) {
            $defn_t->{field_attr}->{$_} ||= {};
            $defn_t->{field_attr}->{$_}->{label} = $defn_t->{labels}->{$_};
        }
    }
    if (ref $defn_t->{label_links} eq 'HASH') {
        for (keys %{$defn_t->{label_links}}) {
            $defn_t->{field_attr}->{$_} ||= {};
            $defn_t->{field_attr}->{$_}->{label_link} = $defn_t->{label_links}->{$_};
        }
    }

    # If style across, map top-level 'thtr' hashref into -defaults label_ attributes
    if ($self->{defn_t}->{style} eq 'across' && ref $defn_t->{thtr} eq 'HASH') {
        for (keys %{$defn_t->{thtr}}) {
            $defn_t->{field_attr}->{-defaults}->{"label_$_"} = $defn_t->{thtr}->{$_}
                if ! exists $defn_t->{field_attr}->{-defaults}->{"label_$_"};
        }
    }
    # Map top-level 'th' hashref into -defaults label_ attributes
    if (ref $defn_t->{th} eq 'HASH') {
        for (keys %{$defn_t->{th}}) {
            $defn_t->{field_attr}->{-defaults}->{"label_$_"} = $defn_t->{th}->{$_}
                if ! exists $defn_t->{field_attr}->{-defaults}->{"label_$_"};
        }
    }
    # Map top-level 'td' hashref into -defaults
    if (ref $defn_t->{td} eq 'HASH') {
        $defn_t->{field_attr}->{-defaults} = { %{$defn_t->{td}}, %{$defn_t->{field_attr}->{-defaults}} };
    }

    # Move regex field_attr definitions into a -regex hash
    $defn_t->{field_attr}->{-regex} = {};
    for (keys %{$defn_t->{field_attr}}) {
        # The following test is an ugly hack, but the regex is stringified now
        next unless m/^\(\?.*\)$/;
        $defn_t->{field_attr}->{-regex}->{$_} = $defn_t->{field_attr}->{$_};
        delete $defn_t->{field_attr}->{$_};
    }

    # Force a non-array stripe to be a binary array
    if ($defn_t->{stripe} && ref $defn_t->{stripe} ne 'ARRAY') {
        $defn_t->{stripe} = [ undef, $defn_t->{stripe} ];
    }

    # thead implies tbody
    if ($defn_t->{thead}) {
        $defn_t->{tbody} ||= 1;
        $defn_t->{thead} = {} if ! ref $defn_t->{thead};
    }

    # Setup tbody attributes hash for hashref tbodies
    if ($defn_t->{tbody}) {
        if (ref $defn_t->{tbody}) {
            $defn_t->{tbody_attr} = $self->deepcopy($defn_t->{tbody});
            for (keys %{$defn_t->{tbody_attr}}) {
                delete $defn_t->{tbody_attr}->{$_} if m/^-/;
            }
        }
        else {
            $defn_t->{tbody_attr} = {};
        }
    }

}

# -------------------------------------------------------------------------
#
# Return the given HTML $tag with attributes from the $attr hashref.
#   An attribute with a non-empty value (i.e. not '' or undef) is rendered
#   attr="value"; one with a value of '' is rendered as a 'bare' attribute
#   (i.e. no '=') in non-xhtml mode; one with undef is simply ignored 
#   (e.g. allowing unset CGI parameters to be ignored).
#
sub start_tag
{
    my ($self, $tag, $attr, $close) = @_;
    my $xhtml = $self->{defn_t}->{xhtml};
    my $str = "<$tag";
    if (ref $attr eq 'HASH') {
        for my $a (sort keys %$attr) {
            next if ! defined $attr->{$a};
            if ($attr->{$a} ne '') {
                $str .= qq( $a="$attr->{$a}");
            }
            else {
                if ($MINIMISED_ATTR{$a}) {
                    $str .= $xhtml ? qq( $a="$a") : qq( $a);
                }
                else {
                    $str .= qq( $a="");
                }
            }
        }
    }
    $str .= ' /' if $close && $xhtml;
    $str .= ">";
    return $str;
}

sub end_tag
{
    my ($self, $tag) = @_;
    return "</$tag>";
}

# ------------------------------------------------------------------------
# Pre- and post-table content

# Title, text, and caption elements may be:
#   - hashref, containing 'value' (scalar) and 'format' (scalar or subref)
#     elements that are rendered like table cells
#   - scalar, that is treated as a scalar 'value' as above with a default 
#     'format'
#   - subref, that is executed and the results used verbatim (i.e. no default
#     'format' applies
sub text_element
{
    my $self = shift;
    my ($type, $dataset) = @_;
    return '' unless grep /^$type$/, qw(title text caption);

    my $elt = $self->{defn_t}->{$type};

    # Subref - execute and return results
    if (ref $elt eq 'CODE') {
        return $elt->($dataset, $type);
    }

    # Scalar - convert to hashref
    elsif (! ref $elt) {
        my $value = $elt;
        $elt = {};
        # If there's a DEFAULT_DEFN $elt entry, use that as defaults
        if ($DEFAULT_DEFN{$type} && ref $DEFAULT_DEFN{$type} eq 'HASH') {
            $elt = { %{$DEFAULT_DEFN{$type}} };
        }
        $elt->{value} = $value;
    }

    # Hashref - render and return
    if (ref $elt eq 'HASH') {
        return '' unless defined $elt->{value} or defined $elt->{title};

        # Omit formatting if tag-wrapped
        return $elt->{value}
            if defined $elt->{value} && $elt->{value} =~ m/^\s*\<.*\>\s*$/s;
        return $elt->{title} 
            if defined $elt->{title} && $elt->{title} =~ m/^\s*\<.*\>\s*$/s;

        # sprintf format pattern
        return sprintf $elt->{format}, $elt->{value}
            if defined $elt->{value} && defined $elt->{format} && 
                ! ref $elt->{format};

        # subref format pattern
        return $elt->{format}->($elt->{value}, $dataset, $type)
            if defined $elt->{value} && defined $elt->{format} && 
                ref $elt->{format} eq 'CODE';
        
        # Deprecated formatting style
        if ($elt->{title}) {
            my $title = $elt->{title};
            my $tag = $elt->{tag} || 'h2';
            delete $elt->{title};
            delete $elt->{tag};
            delete $elt->{format};
            return $self->start_tag($tag, $elt) . $title .
                   $self->end_tag($tag, $elt) . "\n";
        }

        # fallthru: return 'value'
        return $elt->{value};
    }

    return '';
}

# unchomp: ensure (non-empty) elements end with a newline
sub unchomp
{
    my $self = shift;
    my $data = shift;
    $data .= "\n" if defined $data && $data ne '' && substr($data,-1) ne "\n";
    $data
}

# title: title/heading preceding the table
sub title   { my $self = shift; $self->unchomp($self->text_element('title', @_)) }
# text: text preceding begin table tag (after title, if any)
sub text    { my $self = shift; $self->unchomp($self->text_element('text', @_)) }

# caption: either new-style <caption> text, or legacy text after end table tag
sub caption { 
  my $self = shift; 
  my ($set, $post_table) = @_;
  my $defn_t = $self->{defn_t};

  # Legacy text must have a 'format' element
  if ($post_table && 
       (ref $defn_t->{caption} ne 'HASH' ||
          ! $defn_t->{caption}->{type} ||
            $defn_t->{caption}->{type} ne 'caption_caption')) {
    $self->unchomp($self->text_element('caption', $set));
  }
  elsif (! $post_table && 
          (ref $defn_t->{caption} eq 'HASH' &&
               $defn_t->{caption}->{type} &&
               $defn_t->{caption}->{type} eq 'caption_caption')) {
    delete $defn_t->{caption}->{format} 
      if ($defn_t->{caption}->{format} || '') eq $DEFAULT_TEXT_FORMAT;
    $self->unchomp(
      $self->start_tag('caption') . 
      $self->text_element('caption', $set) . 
      $self->end_tag('caption')
    )
  }
}

# ------------------------------------------------------------------------
# Content before begin table tag
sub pre_table
{
    my $self = shift;
    my ($set) = @_;
    my $content = '';
    $content .= $self->title($set) if $self->{defn_t}->{title};
    $content .= $self->text($set)  if $self->{defn_t}->{text};
    return $content;
}

# Provided for subclassing
sub start_table 
{
    my $self = shift;
    return '' if exists $self->{defn_t}->{table} && ! $self->{defn_t}->{table};
    return $self->start_tag('table',$self->{defn_t}->{table}) . "\n";
}

# Provided for subclassing
sub end_table 
{
    my $self = shift;
    return '' if exists $self->{defn_t}->{table} && ! $self->{defn_t}->{table};
    return $self->end_tag('table') . "\n";
}

# Content after end table tag
sub post_table
{
    my $self = shift;
    my ($set) = @_;
    my $content = '';
    $content .= $self->caption($set, 'post_table');
    return $content;
}

# ------------------------------------------------------------------------
# Apply 'format' formatting
sub cell_format_format
{
    my ($self, $data, $fattr, $row, $field) = @_;
    my $ref = ref $fattr->{format};
    croak "[cell_format] invalid '$field' format: $ref" if $ref && $ref ne 'CODE';
    $data = &{$fattr->{format}}($data, $row || {}, $field) if $ref eq 'CODE';
    $data = sprintf $fattr->{format}, $data if ! $ref;
    return $data;
}

# Simple tag escaping
sub cell_format_escape
{
    my ($self, $data) = @_;
    $data =~ s/</&lt;/g;
    $data =~ s/>/&gt;/g;
    return $data;
}

# Link formatting
sub cell_format_link
{
    my ($self, $data, $fattr, $row, $field, $data_unformatted) = @_;
    my $ldata;
    my $ref = ref $fattr->{link};
    croak "[cell_format] invalid '$field' link: $ref"
        if $ref && $ref ne 'CODE';
    $ldata = &{$fattr->{link}}($data_unformatted, $row || {}, $field) 
        if $ref eq 'CODE';
    $ldata = sprintf $fattr->{link}, $data_unformatted 
        if ! $ref;
    if ($ldata) {
#       $data = sprintf qq(<a href="%s">%s</a>), 
#           uri_escape($ldata, $URI_ESCAPE_CHARS), $data;
        my $link_attr = { href => uri_escape($ldata, $URI_ESCAPE_CHARS)};
        for my $attr (keys %$fattr) {
          if ($attr =~ m/^link_/) {
            my $val = $fattr->{$attr};
            $attr =~ s/^link_//;
            $link_attr->{$attr} = ref $val eq 'CODE' ? 
              $val->($data_unformatted, $row || {}, $field) :
              $val;
          }
        }
        $data = $self->start_tag('a', $link_attr) . $data . $self->end_tag('a');
    }
    return $data;
}

#
# Format the given data item using formatting field attributes (e.g. format, 
#   link, escape etc.)
#
sub cell_format
{
    my $self = shift;
    my ($data, $fattr, $row, $field) = @_;
    my $defn = $self->{defn_t};

    # Trim
    $data =~ s/^\s*(.*?)\s*$/$1/ if $defn->{trim};

    if ($data ne '') {
        my $data_unformatted = $data;

        # 'escape' boolean for simple tag escaping (defaults to on)
        $data = $self->cell_format_escape($data) 
            if $fattr->{escape} || ! exists $fattr->{escape};

        # 'format' subroutine or sprintf pattern
        $data = $self->cell_format_format(@_) 
            if $fattr->{format};

        # 'link' subroutine or sprintf pattern
        $data = $self->cell_format_link($data, $fattr, $row, $field, $data_unformatted)
            if $fattr->{link};
    }

    # 'null' defaults
    $data = $defn->{null} if defined $defn->{null} && $data eq '';

    return $data;
}

sub label
{
    my ($self, $label, $field) = @_;

    # Use first label if arrayref
    my $l;
    if (ref $label eq 'CODE') {
        $l = $label->($field);
    }
    else {
        $l = $label;
    }
    $l = $self->derive_label($field) unless defined $l;
    $l = $self->{defn_t}->{null} if $l eq '' && defined $self->{defn_t}->{null};
    return $l;
}

#
# Add in any extra (conditional) defaults for this field. 
# Provided for subclassing.
#
sub cell_merge_extras
{
    return ();
}

#
# Merge default and field attributes once each for labels and data
#
sub cell_merge_defaults
{
    my ($self, $row, $field) = @_;
    $self->{defn_t}->{field_attr}->{$field} ||= {};

    # Create a temp $fattr hash merging defaults, regexes, and field attrs
    my $fattr = { %{$self->{defn_t}->{field_attr}->{-defaults}},
                  $self->cell_merge_extras($row, $field) };
    for my $regex (sort keys %{$self->{defn_t}->{field_attr}->{-regex}}) {
        next unless $field =~ $regex;
        @$fattr{ keys %{$self->{defn_t}->{field_attr}->{-regex}->{$regex}} } = 
            values %{$self->{defn_t}->{field_attr}->{-regex}->{$regex}};
    }
    @$fattr{ keys %{$self->{defn_t}->{field_attr}->{$field}} } = 
        values %{$self->{defn_t}->{field_attr}->{$field}};
   
    # For labels, keep only label_ attributes
    if (! defined $row) {
        my $fattr_l = {};
        for (keys %$fattr) {
            next if substr($_,0,6) ne 'label_';
            $fattr_l->{substr($_,6)} = $fattr->{$_};
        }

        # Set 'value' from 'label'
        $fattr_l->{value} = $self->label($fattr->{label}, $field);
        # Update fattr
        $fattr = $fattr_l;
    }

    # For data, merge defaults and the field attributes, discarding label_ ones
    else {
        # Remove all label_ attributes
        for (keys %$fattr) { delete $fattr->{$_} if substr($_,0,6) eq 'label_'; }
    }

    # Create tx_attr by removing all $fattr attributes in $field_attr
    my %tx_attr = %$fattr;
    for (keys %tx_attr) { 
      delete $tx_attr{$_} if exists $self->{field_attr}->{$_};
      delete $tx_attr{$_} if m/^link_/;
    }

    # If data, save for subsequent rows
    if ($row) {
        $fattr->{td_attr} = \%tx_attr;
        $self->{defn_t}->{field_attr}->{$field} = $fattr;
    }

    # Check %tx_attr for code values
    my $tx_code = 0;
    for my $v (values %tx_attr) {
         if (ref $v eq 'CODE') {
             $tx_code = 1;
             $self->{defn_t}->{field_attr}->{$field}->{td_code} = 1 if $row;
             last;
         }
    }

    return ($fattr, \%tx_attr, $tx_code);
}

#
# Set and format the data for a single (data) cell or item
#
sub cell_value
{
    my $self = shift;
    my ($row, $field, $fattr) = @_;
    my $defn = $self->{defn_t};

    # Get value from $row
    my $value;
    if (ref $row eq 'ARRAY') {
        my $i = keys %{$defn->{field_map}} ? $defn->{field_map}->{$field} : $field;
        $value = $row->[ $i ] if defined $i;
    }
    # Allow field-methods e.g. Class::DBI
    elsif (ref $row && ref $row ne 'HASH' && ref $row ne 'SCALAR' && $row->can($field)) {
        $value = eval "\$row->$field()";
    }
    elsif (ref $row && exists $row->{$field}) {
        $value = $row->{$field};
    }
    # 'value' literal or subref takes precedence over row
    if (exists $fattr->{value}) {
        my $ref = ref $fattr->{value};
        if (! $ref) {
            # $value = sprintf $fattr->{value}, $value;
            $value = $fattr->{value};
        }
        elsif ($ref eq 'CODE') {
            $value = &{$fattr->{value}}($value, $row, $field);
        }
        else {
            croak "[cell_value] invalid '$field' value: $ref";
        };
    }

    $value = $fattr->{default} if ! defined $value && exists $fattr->{default};

    return defined $value ? $value : '';
}

# 
# Return a cell value created from one or more other cells
#
sub cell_composite
{
    my $self = shift;
    my ($row, $field, $fattr) = @_;

    my $composite = $fattr->{composite} 
        or die "Missing composite field attribute";
    my @composite = ();
    for my $f (@$composite) {
        push @composite, $self->cell($row, $f, undef, undef, tags => 0);
    }

    my $composite_join = $fattr->{composite_join} || ' ';
    if (ref $composite_join eq 'CODE') {
        return $composite_join->(\@composite, $row, $field);
    }
    else {
        return join ' ', @composite;
    }
}

#
# Set and format the data for a single (data) cell or item
#
sub cell_content
{
    my $self = shift;
    my ($row, $field, $fattr) = @_;
    my $value;

    # Composite fields - concatenate members together
    if ($fattr->{composite}) {
        $value = $self->cell_composite(@_);
    }

    # Standard field - get value from $row
    else {
        $value = $self->cell_value(@_);
    }

    # Format
    my $fvalue = $self->cell_format($value, $fattr, $row, $field);

    return wantarray ? ($fvalue, $value) : $fvalue;
}

#
# Wrap cell in <th> or <td> table tags
#
sub cell_tags 
{
    my ($self, $data, $row, $field, $tx_attr) = @_;

    my $tag = ! defined $row ? 'th' : 'td';
    $data = '' unless defined $data;
    return $self->start_tag($tag, $tx_attr) . $data . $self->end_tag($tag);
}

#
# Execute any th or td attribute subrefs
#
sub cell_tx_execute 
{
    my $self = shift;
    my ($tx_attr, $value, $row, $field) = @_;
    my %tx2 = ();
    while (my ($k,$v) = each %$tx_attr) {
        if (ref $v eq 'CODE') {
            $tx2{$k} = $v->($value, $row, $field);
        } 
        else {
            $tx2{$k} = $v;
        }
    }
    return \%tx2;
}

#
# Render a single table cell or item
#
sub cell_wantarray
{
    my ($self, $row, $field, $fattr, $tx_attr, %opts) = @_;
    my $tags = delete $opts{tags};
    $tags = 1 unless defined $tags;

    # Merge default and field attributes first time through (labels + data)
    my $tx_code = 0;
    unless ($fattr && $tx_attr) {
        if (! defined $row || ! $self->{defn_t}->{field_attr}->{$field}->{td_attr}) {
            ($fattr, $tx_attr, $tx_code) = $self->cell_merge_defaults($row, $field);
        }
        else {
            $fattr = $self->{defn_t}->{field_attr}->{$field};
            $tx_attr = $fattr->{td_attr};
            $tx_code = $fattr->{td_code};
        }
    }

    # Standard (non-composite) fields
    my ($fvalue, $value) = $self->cell_content($row, $field, $fattr);

    # If $tx_addr includes coderefs, execute them
    $tx_attr = $self->cell_tx_execute($tx_attr, $value, $row, $field) 
        if $tx_code;

    # Generate tags
    my $cell = $tags ? $self->cell_tags($fvalue, $row, $field, $tx_attr) : $fvalue;
    return $cell unless wantarray;
    my $skip_count = $tx_attr->{colspan} ? ($tx_attr->{colspan}-1) : 0;
    return ( $cell, $skip_count );
}

# 
# Render a single table cell, returning cell and a field skip count
#
sub cell
{
    my $self = shift;
    my ($cell, $skip_count) = $self->cell_wantarray(@_);
    return $cell;
}

#
# Modify the $tr hashref for striping. If $type is 'SCALAR', the stripe is
#   a HTML colour string for a bgcolor attribute for the relevant row; if
#   $type is 'HASH' the stripe is a set of attributes to be merged.
#   $stripe has already been coerced to an arrayref if something else.
#
sub stripe
{
    my ($self, $tr, $rownum) = @_;
    my $stripe = $self->{defn_t}->{stripe};
    return $tr unless $stripe;
             
    my $r = int($rownum % scalar(@$stripe)) - 1;
    if (defined $stripe->[$r]) {
        if (! ref $stripe->[$r]) {
            # Set bgcolor to stripe (exception: header where bgcolor already set)
            $tr->{bgcolor} = $stripe->[$r]
                unless $rownum == 0 && exists $tr->{bgcolor};
        }
        elsif (ref $stripe->[$r] eq 'HASH') {
            # Existing attributes take precedence over stripe ones for header
            if ($rownum == 0) {
                for (keys %{$stripe->[$r]}) {
                    $tr->{$_} = $stripe->[$r]->{$_} unless exists $tr->{$_};
                }
            }
            # For non-header rows, merge attributes straight into $tr
            else {
                @$tr{keys %{$stripe->[$r]}} = values %{$stripe->[$r]};
            }
        }
        # Else silently ignore
    }
    return $tr;
}

#
# Return tbody close and/or open tags if appropriate, '' otherwise
#
sub tbody
{
    my $self = shift;
    my ($row, $rownum) = @_;
    my $generate = 0;

    return '' unless $self->{defn_t}->{tbody};

    # Scalar tbody - generate once only
    if (! ref $self->{defn_t}->{tbody}) {
        $generate++ if ! $self->{defn_t}->{tbody_open};
    }
        
    # tbody with -field - generate when field value changes
    elsif ($self->{defn_t}->{tbody}->{'-field'}) {
        my $value = $self->cell_value($row, $self->{defn_t}->{tbody}->{'-field'});
        if (exists $self->{defn_t}->{tbody_field_value}) {
            if ($value eq $self->{defn_t}->{tbody_field_value} ||
                (! defined $value &&
                 ! defined $self->{defn_t}->{tbody_field_value})) {
                return '';
            }
            else {
                $generate++;
            }
        }
        else {
            $generate++;
        }
        $self->{defn_t}->{tbody_field_value} = $value;
    }

    # tbody with -rows - generate when $rownum == $r ** n + 1
    elsif (my $r = $self->{defn_t}->{tbody}->{'-rows'}) {
        $generate++ if int(($rownum-1) % $r) == 0;
    }

    # else a hashref - treat like a scalar
    else {
        $generate++ if ! $self->{defn_t}->{tbody_open};
    }

    my $tbody = '';
    if ($generate) {
        if ($self->{defn_t}->{tbody_open}) {
            $tbody .= $self->end_tag('tbody') . "\n";
        }
        $tbody .= $self->start_tag('tbody', $self->{defn_t}->{tbody_attr}) . "\n";
        $self->{defn_t}->{tbody_open} = 1;
    }
    return $tbody;
}

#
# Return an attribute hash for table rows
#
sub tr_attr
{
    my ($self, $rownum, $row, $dataset) = @_;
    my $defn_t = $self->{defn_t};
    my $tr = undef;
    if ($rownum == 0) {
        $tr = $defn_t->{thtr} if $defn_t->{thtr};
        $tr ||= $self->deepcopy($defn_t->{tr_base});
    }
    else {
        if (ref $defn_t->{tr} eq 'CODE' && $row) {
            $tr = $defn_t->{tr}->($row, $dataset);
        }
        else {
            $defn_t->{tr} = {} unless ref $defn_t->{tr} eq 'HASH';
            $tr = $self->deepcopy($defn_t->{tr});
            # Evaluate any code attributes
            $tr ||= {};
            while (my ($k,$v) = each %$tr) {
                $tr->{$k} = $v->($row, $dataset) if ref $v eq 'CODE';
            }
        }
    }
    # Stripe and return
    return $self->stripe($tr, $rownum);
}

#
# Render a single table row (style 'down')
#
sub row_down 
{
    my ($self, $row, $rownum) = @_;

    # Render cells
    my @cells = ();
    my $skip_count = 0;
    for my $f (@{$self->{defn_t}->{fields}}) {
        if ($skip_count > 0) {
            $skip_count--;
        }
        else {
            (my ($cell), $skip_count) = $self->cell_wantarray($rownum == 0 ? undef : $row, $f);
            push @cells, $cell;
        }
    }

    # Build the row
    my $out = '';
    $out .= $self->start_tag('tr', $self->tr_attr($rownum, $row));
    $out .= join('',@cells);
    $out .= $self->end_tag('tr');
    $out .= "\n";
    return $out;
}

#
# Return a generalised iterator function to walk the set, returning undef at eod
#
sub data_iterator 
{
    my ($self, $set, $fields) = @_;
    my $row = 0;

    croak "invalid Tabulate data type '$set'" unless ref $set;
    if (ref $set eq 'CODE') {
        return sub {
          $row = $row ? $set->() : ($self->{prefetch} || $set->());
        };
    }
    elsif (UNIVERSAL::isa($set,'UNIVERSAL') &&
            $set->can('First') && $set->can('Next')) {
        return sub {
          $row = $row ? $set->Next : ($self->{prefetch} || $set->First);
        };
    }
    elsif (UNIVERSAL::isa($set,'UNIVERSAL') &&
            $set->can('first') && $set->can('next')) {
        return sub {
          $row = $row ? $set->next : ($self->{prefetch} || $set->first);
        };
    }
    elsif (ref $set eq 'ARRAY') {
        return sub {
            return undef if $row > $#$set;
            $set->[$row++];
        };
    }
    elsif (ref $set eq 'HASH' || eval { keys %$set }) {
        # Check first value - drill down further unless non-reference
        my $k = $fields->[0] || (sort keys %$set)[0];
        # For hashes of scalars, just return the hash once-only
        if (! ref $set->{$k}) {
            return sub {
                return undef if $row++;
                $set;
            };
        }
        # For hashes of refs, return the refs in key order
        else {
            return sub {
                my @k = sort keys %$set;
                return undef if $row > $#k;
                return $k[$row++];
            };
        }
    }
    else {
        croak "invalid Tabulate data type '$set'";
    }
}

#
# Render the table body with successive records down the page
#
sub body_down 
{
    my ($self, $set) = @_;
    my $body = '';

    # Get data_iterator
    my @fields = @{$self->{defn_t}->{fields}} 
        if ref $self->{defn_t}->{fields} eq 'ARRAY';
    my $data_next = $self->data_iterator($set, \@fields);

    # Labels/headings
    if ($self->{defn_t}->{labels} && @fields) {
        $body .= $self->start_tag('thead', $self->{defn_t}->{thead}) . "\n" 
            if $self->{defn_t}->{thead};
        $body .= $self->row_down(undef, 0);
        if ($self->{defn_t}->{thead}) {
          $body .= $self->end_tag('thead') . "\n";
          $self->{defn_t}->{thead} = 0;
        }
    }
    elsif ($self->{defn_t}->{thead}) {
        # If thead set and labels isn't, use the first data row
        my $row = $data_next->();
        if ($row) {
            $body .= $self->start_tag('thead', $self->{defn_t}->{thead}) . "\n";
            $body .= $self->row_down($row, 1);
            $body .= $self->end_tag('thead') . "\n";
        }
    }

    # Table body
    my $rownum = 1;
    while (my $row = $data_next->()) {
        $body .= $self->tbody($row, $rownum);
        $body .= $self->row_down($row, $rownum);
        $rownum++;
    }
    if (my $data_append = $self->{defn_t}->{data_append}) {
        for my $row (@$data_append) {
            $body .= $self->tbody($row, $rownum);
            $body .= $self->row_down($row, $rownum);
            $rownum++;
        } 
    }

    $body .= $self->end_tag('tbody') . "\n" if $self->{defn_t}->{tbody_open};

    return $body;
}

#
# Render a single table row (style 'across')
#
sub row_across
{
    my ($self, $data, $rownum, $field) = @_;
    my @cells = ();
    my @across_row = ();

    # Label/heading
    if ($self->{defn_t}->{labels}) {
        push @cells, $self->cell(undef, $field);
        push @across_row, $self->cell(undef, $field, undef, undef, tags => 0);
    }

    # Data
    for my $row (@$data) {
        push @cells, $self->cell($row, $field);
        push @across_row, $self->cell_value($row, $field);
    }

    # Build row
    my $out = $self->start_tag('tr', $self->tr_attr($rownum, $data, \@across_row));
    $out .= join('', @cells);
    $out .= $self->end_tag('tr') . "\n";
}

sub get_dataset
{
    my ($self, $set) = @_;

    # Fetch the full data set
    my @data = ();
    croak "invalid Tabulate data type '$set'" unless ref $set;
    if (ref $set eq 'CODE') {
        while (my $row = $set->()) {
            push @data, $row;
        }
    }
    elsif (UNIVERSAL::isa($set,'UNIVERSAL') &&
            $set->can('First') && $set->can('Next')) {
        my $row = $set->First;
        if (ref $row) {
            do {
                push @data, $row;
            }
            while ($row = $set->Next);
        }
    }
    elsif (UNIVERSAL::isa($set,'UNIVERSAL') &&
            $set->can('first') && $set->can('next')) {
        my $row = $set->first;
        if (ref $row) {
            do {
                push @data, $row;
            }
            while ($row = $set->next);
        }
    }
    elsif (ref $set eq 'ARRAY') {
        @data = @$set;
    }
    elsif (ref $set eq 'HASH' || eval { keys %$set }) {
        @data = ( $set );
    }
    else {
        croak "[body_across] invalid Tabulate data type '$set'";
    }

    return @data;
}

#
# Render the table body with successive records across the page 
#   (i.e. fields down the page)
#
sub body_across 
{
    my ($self, $set) = @_;

    # Iterate over fields (instead of data rows)
    my @data = $self->get_dataset($set);
    my $rownum = 1;
    my $body = '';
    for my $field (@{$self->{defn_t}->{fields}}) {
        $body .= $self->row_across(\@data, $rownum, $field);
        $rownum++;
    }

    return $body;
}

# -------------------------------------------------------------------------
sub render_table
{
    my ($self, $set) = @_;
    my $defn_t = $self->{defn_t};

    # Style-specific bodies (default is 'down')
    my $body;
    if ($defn_t->{style} eq 'down') {
        $body .= $self->body_down($set);
    }
    elsif ($defn_t->{style} eq 'across') {
        $body .= $self->body_across($set);
    }
    else {
        croak sprintf "[render] invalid style '%s'", $defn_t->{style};
    }

    # Build table
    my $table = '';
    $table .= $self->pre_table($set);
    $table .= $self->start_table();
    $table .= $self->caption($set);
    $table .= $body;
    $table .= $self->end_table();
    $table .= $self->post_table($set);
  
    return $table;
}

#
# Render the data set $set using the settings in $self->{defn} + $defn,
#   returning the resulting string.
#
sub render
{
    my ($self, $set, $defn) = @_;
    $set = {} unless ref $set;

    # If $self is not blessed, this is a procedural call, $self is $set
    if (ref $self eq 'HASH' || ref $self eq 'ARRAY') {
      $defn = $set;
      $set = $self;
      $self = __PACKAGE__->new($defn);
      undef $defn;
    }
 
    # If $defn defined, merge with $self->{defn} for this render only
    if (ref $defn eq 'HASH' && keys %$defn) {
        $defn = $self->merge($self->{defn}, $defn);
        $self->prerender_munge($set, $defn);
    }
    else {
        $self->prerender_munge($set);
    }

    $self->render_table($set);
}

# -------------------------------------------------------------------------

1;

__END__

# vim:sw=4