package Data::Dataset::HTMLtable;

use strict;
use warnings;
use base qw(Data::Dataset::Colmap);

use CGI qw(escapeHTML);


=head1 NAME

Data::Dataset::HTMLtable - format a Dataset into a table

=head1 DESCRIPTION

This is a specialisation of Colmap for the purpose of producing an
HTML table showing Dataset cell values.

Normal use is to construct an instance, call the C<htmlgen> method to
return the HTML, then discard the object.

There is a convenience method for construction, the C<htmltable>
method on any Dataset.


=head2 new(%args)

This constructor also accepts any option that works with Colmap.

=over 4

=item -showcols => \@showcols

XXX:

Each of @showcols may be the $colId to use, as a simple string, or a
two or three element ARRAYref containing ($colId, $text, $noquote).
For the string, the displayed heading will be the colId name.  With
the ARRAYref, $text will be displayed.  If $noquote is missing or
false the text will be HTML-encoded for you.

If no colIds are provided, the default will be used, defined as "all
columns in $dataset which don't contain a E<gt> character".

The E<gt> exclusion fits with the incremental and overridable mapping
B<value> to B<html text> to B<table cell> to B<table row>, and the
provision of a column named "E<gt>rowhead" to allow labels per row.
This use of the E<gt> character is (currently) a convention local to
this piece of source.

=item -rowheads => $flag

Default is false.  If true, an extra column named C<E<gt>rowhead> is
inserted at the left.  Name is chosen to avoid being included in the
default C<-showcols> set.  Generators for the value, html and td are
also provided by default, and can be overridden like any other column.

=item -def => \@def

Defined as for Colmap, but optional.  Additional columns are defined
to make the HTML generator, these are prepended to the list (before
the C<-src> Dataset) so they may be shadowed by the caller's
definitions or C<-src>.

=item -src => $dataset

Defined as for Colmap.  Required, to figure out the default set of
columns for display and the set of columns for which html or td
generators may be needed.

=item -colformat => CODE

Often not required.  If defined, it is a CODE ref to generate the HTML
for any column, except as overridden in C<-def>.  Called for each
cell:

 $f->($dataset, $rowId, $colId)

(same call signature as a colmap column generator).  The C<$colId>
given is the name of the HTML column being generated; its default
source column must be reconstructed with

 s/>html$//

XXX: this is a bodge for multi-column or any-column colmap generators

This affects the column definitions generated by C<_mkdefs_cells>.

=item -colid2th => $c2th

Optional CODE ref, called with ($obj, $colId) and expected to return a
TH element to head up the column.  The default is to call C<colid2th>
on $obj,

=item -colid2html => $c2html

Optional CODE ref. XXX:DOC working, but no doc.  -showcols => [ [colId, txt] ...] is a better solution.

#### changed my mind
#
#   =item -th_text => \%map
#   
#   =item -th_html => \%map
#   
#   Optional, ignored if C<-colid2html> or C<-colid2th> are overridden.
#   
#   Pass HASHref(s) mapping $colId to the title to display.  Column $colId
#   values are as found in the C<-showcols> parameter, these are used as
#   keys to C<-th_text> and C<-th_html>.
#   
#   C<-th_html> values takes precedence over C<-th_text>, and if neither
#   is present the colId is used as the text.  Text values are quoted to
#   make HTML.

=back

Missing: control over table, tr, th, td attributes; colgroup
definitions; rowspan and colspan or any way to use them [but see _mkdefs_* POD]; control over
formatting of column names (e.g. extra links to do sorting).

Solutions: colmap filter definitions to turn each cell values into
html; columns to generate TR and TD tags (either uniform TD, or TD
definition per column); a column to concatenate the lot.
Prefix/suffix generators to provide table and row of th, then close.
Default code to provide "normal" formatting for these, with some way
to override parts as needed.

=cut

sub _init {
    my ($self, %args) = @_;

    my $src = delete $args{-src};
    die "$self->new: -src => Dataset is required" unless UNIVERSAL::isa($src, "Data::Dataset");
    $self->{srccols} = [ $src->colnames ];

    # Provide default column set, if necessary
    my $colIds = delete $args{-showcols};
    $colIds = [ grep { ! />/ } @{ $self->{srccols} } ]
      if !$colIds ||  @$colIds == 0;
    # Copy list contents & extract first element of nested lists
    $self->{showcols} = [ map { ref($_) ? $$_[0] : $_ } @$colIds ];

    # Build column headings
    my %th_text;
    foreach my $th (@$colIds) {
	next unless ref($th);
	my ($colId, $text, $noquote) = @$th;
	$th_text{$colId} = $noquote ? $text : escapeHTML($text);
    }
    $self->{th_html} = \%th_text;

    # Rowheads flag just inserts the extra column (with a funny name,
    # so it isn't included as a default column)
    unshift @{ $self->{showcols} }, ">rowhead"
      if delete $args{-rowheads};


    # We're going to cook up an almighty Colmap definition, based on
    # what the user gave us
    my @def;
    if ($args{-def}) {
	die "$self->new: -def parameter was not a list"
	  unless ref($args{-def}) eq 'ARRAY';
	@def = @{ $args{-def} };
    }
    $args{-def} = \@def;

    # Columns in -def and -src take precedence: user can override any
    # of the extra defs we generate, simply by defining the column in
    # the usual ways.

    unshift @def, ($self->_mkdefs_cells(delete $args{-colformat}),
		   $self->_mkdefs_row(),
		   $src);


    # Column header formatting options
    $self->{"colid2html"} = delete $args{-colid2html};
    $self->{"colid2th"}   = delete $args{-colid2th};


    return $self->SUPER::_init(%args);
}


=head2 _mkdefs_cells($colFormat)

Object method, for internal callers but documented for API users.
Returns a list of C<colId =E<gt> CODE> pairs for use as Colmap column
generators.

Generates the default set of necessary Dataset columns for formatting
contents of Dataset cells into HTML table cells.  Any of these
definitions can be replaced during construction of the object.

=over 4

=item fooE<gt>html

Dataset cell which is fetched when the HTML-encoded format of column
C<foo> is required.  The default does

 Data::Dataset::HTMLtable object	call ->htmlgen()
 Data::Dataset objects		call ->htmltable()->htmlgen()
 anything else			call L<CGI>::escapeHTML

Except when C<$colFormat> is defined, as may be done via C<new(-colformat =E<gt> ...)>, when that CODE is used instead.

=item fooE<gt>td

Dataset cell contains exactly one HTML table cell.  The default simply
fetches the C<fooE<gt>html> column and wraps it in

 <td>...</td>

XXX: HTML colspan is not yet supported, but this may be a place to add
it.  Probably need to mash C<tableE<gt>cols> too.

=back

These columns are generated for C<foo> being any of input Dataset
columns or output columns requested via the C<-showcols> parameter to
C<new()>.

=cut

sub _mkdefs_cells {
    my ($self, $colFormat) = @_;
    my @def;

    # For each column requested for display, or that might be used to
    # generate display data, in no particular order,
    my %manyCols;
    @manyCols{($self->showcols)} = ();
    @manyCols{@{ $self->{srccols} }} = ();

    foreach my $colId (sort keys %manyCols) {
	# Define HTML that goes in table cell
	my $code = sub {
	    my ($o, $rowId) = @_;
	    my $val = $o->get($colId => $rowId);
	    if (ref($val) && UNIVERSAL::isa($val, 'Data::Dataset')) {
		my $table = $val;
		if (not $val->isa(__PACKAGE__)) {
# XXX: could usefully put Data::Dataset->htmlgen object method, to be overridden by HTMLtable: would avoid this bodge
		    # Plain Dataset, display all columns.  Default
		    # skips colname =~ />/
		    $table = $val->htmltable(-showcols => [ $val->colnames ]);
		}
		return $table->htmlgen;
	    } else {
# XXX: could provide generic dispatch to format by class of $val, per $self instance?  possibly a generalisation of the colFormat hack too
		return (defined $val
			? escapeHTML($val)
			: '<em>[undef]</em>');
	    }
	};

	# Backwards support for the colFormat hack, still useful as an
	# any-column fetcher; but need to watch confusion between
	# "$colId" and "$colId>html" - possible infinite recursion
	$code = $colFormat if $colFormat;

	push @def, "${colId}>html" => $code;

	# Define whole table cell element
	push @def, "${colId}>td" => sub {
	    my ($o, $rowId) = @_;
	    my $hval = $o->get("${colId}>html" => $rowId);
	    return qq{<td>$hval</td>};
	};
    }

    return @def;
}


=head2 _mkdefs_row()

Object method, for internal callers but documented for API users.
Returns a list of C<colId =E<gt> CODE> pairs for use as Colmap column
generators.

Generates the default set of necessary Dataset columns for formatting
one HTML table row.  Any of these definitions can be replaced during
construction of the object.

=over 4

=item tableE<gt>cols

Dataset cells in this column contain ARRAYref which defines the colIds
to display on the output and their order, e.g.

 [ "id", "name", "description" ]

Normally this will have the same value for each row, but it can change
if the layout still works.

=item E<gt>rowhead

Cells contain the raw value for the row heading, the default supplied
is just $rowId.

=item E<gt>rowheadE<gt>td

The HTML table row header cell C<TH>.  Replaces the definition from
C<_mkdefs_cells>, but uses the C<E<gt>rowheadE<gt>html> defined there.

Whether this is displayed depends on the C<-rowheads> configuration or
other cause for inclusion of this colId in C<tableE<gt>cols>.

=item rowE<gt>zebra

Dataset column returns an alternating (0, 1) for use in the HTML table
row styling, to make stripes.

=item rowE<gt>tr and rowE<gt>/tr

Define the opening and closing HTML TR tags.  Defaults are

 <tr class=zeb$row_zebra>...</tr>\n

=item rowE<gt>html

The Dataset column from which a complete HTML table row is fetched.
The default fetches the following columns and returns them as a string
of HTML,

 row>tr
 foo>td		for each foo, under the control of table>cols
 row>/tr

As described in C<_mkdefs_cells>, normally C<fooE<gt>td> will in turn
fetch C<fooE<gt>html> and C<foo> to build each cell.

=back

=cut

sub _mkdefs_row {
    my ($self) = @_;
    return
      (
       # What goes in each row (normally the requested set of columns)
       "table>cols" => sub { return [ $self->showcols ] },

       # Generation of row header (may be unused or overridden).
       ">rowhead" => sub { my ($o, $rowId) = @_; return $rowId; },
       ">rowhead>td" => sub {
	   my ($o, $rowId) = @_;
	   my $hval = $o->get(">rowhead>html", $rowId);
	   return qq{<th scope=row>$hval</th>};
       },

       # The TR tags
       "row>zebra" => $self->_zeb_gen,
       "row>tr" => sub {
	   my ($o, $rowId) = @_;
	   my $zeb = $o->get("row>zebra", $rowId);
	   return qq{<tr class=zeb$zeb>};
       },
       "row>/tr" => sub { "</tr>\n" },

       # Assembly of all TR and TD values into the text of one table row
       "row>html" => sub {
	   my ($o, $rowId) = @_;
	   my $colIds = $o->get("table>cols", $rowId);
	   die $o->description." [table>cols, $rowId] is $colIds, wanted ARRAY ref"
	     unless ref($colIds) eq 'ARRAY';
	   return join "", $o->getcols
	     ($rowId,
	      "row>tr", (map {"$_>td"} @$colIds), "row>/tr");
       });
}


# Returns a CODE which returns zebra-stripe numbers 0, 1, 0, 1...
sub _zeb_gen {
    my $zebra = 1;
    return sub { return $zebra = (1,0)[$zebra] };
}


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


=head2 htmlgen(%params)

Returns HTML the entire table, as one string (in scalar context) or a
list of strings which should be concatenated (list context).

XXX: may need more configurability...  parameters?  config on new()?  configuration method on object, to which spare new() params are passed?

Parameter are key/value pairs.  Acceptable keys are

=over 4

=item rowList => ARRAYref

Use the given list of rowId values, instead of querying the underlying
object.

=item table

=item tr4th

Each may be a string (open tag) or ARRAYref of two strings (open and
close tags).

If tr4th is undef, this disables column heading generation.  (Possibly
not the neatest solution)

=back

Defaults are shown below.

String contents:

 <table border=1 class=report_result>		or C<table> param

 <tr>						or C<tr4th> param

 colid2th values as defined by C<-colid2th> parameter,
   for each column as defined by C<-showcols> parameter,
     generated by the C<th_row> method which could be replaced by subclassing

 </tr>

 the value of C<rowE<gt>html> for each row of the Dataset/table,
   for each row as defined by C<rowList> method,
     therefore containing all HTML cells as described in C<_mkdefs_row>

 </table>

=cut

sub htmlgen {
    my ($self, %params) = @_;

    # Grab params
    my @rowList = (exists $params{rowList}
		   ? @{ delete $params{rowList} }
		   : $self->rowList);
    my %tag =
      ( table => ["<table border=1 class=report_result>", "</table>\n"],
	tr4th => ["<tr>", "</tr>\n"]
      );
    foreach my $key (keys %tag) {
	next unless exists $params{$key}; # keep default

	my @tag = delete $params{$key}; # one item!

	if (!defined $tag[0]) {
	    $tag{$key} = undef; # no column headings
	} elsif (ref($tag[0]) eq 'ARRAY' && 2 == @{$tag[0]}) {
	    $tag{$key} = $tag[0];
	} else {
	    $tag[1] = $tag{$key}->[1];
	    $tag[0] = $tag{$key}->[0] if !defined $tag[0];
	    $tag{$key} = \@tag;
	}
    }
    {
	my @k = sort keys %params;
	die "Unknown parameters (@k) to htmlgen" if @k;
    }

    my @out = ($tag{table}[0]);

    # Generate row of column heads, unless disabled
    push @out, $self->th_row($tag{tr4th})
      if defined $tag{tr4th};

    # Generate table rows
    foreach my $rowId (@rowList) {
	push @out, $self->get("row>html", $rowId); # XXX: trouble if you have a column called "row"
    }

    push @out, $tag{table}[1];

    return wantarray ? @out : join "", @out;
}

sub th_row {
    my ($self, $tagpair) = @_;
    my @out;

    # XXX: $col2th + $col2html look suspiciously like per-object method specialisation ie. subclass
    my $col2th   = $self->{colid2th}   ? $self->{colid2th}   : $self->can('colid2th');

    foreach my $colId ($self->showcols) {
	push @out, $col2th->($self, $colId);
    }
    return ($$tagpair[0], @out, $$tagpair[1]);
}

# XXX: methods below have unfortunate blurring of object-method vs. colmap-generator, potentially could be either but this should be made clear (when I know)

sub colid2html {
    my ($self, $colId) = @_;
    if (defined $self->{th_html}->{$colId}) {
	return $self->{th_html}->{$colId};
    } else {
	my $txt = ($colId eq ">rowhead" ? "" : $colId);
	return escapeHTML($txt);
    }
}

sub colid2th {
    my ($self, $colId) = @_;
    my $col2html = $self->{colid2html} ? $self->{colid2html} : $self->can('colid2html');
    my $colId_html = $col2html->($self, $colId);
    return $colId_html eq "" ? qq{<td></td>} : qq{<th scope=col>$colId_html</th>};
}



=head1 AUTHOR

mca@sanger.ac.uk

$Id: HTMLtable.pm,v 1.10 2007/01/08 17:33:17 mca Exp $

=cut

1;
