package DBIx::XHTML_Table;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

use Exporter;

use DBI;
use Data::Dumper;
use Carp;

@ISA     = qw(Exporter AutoLoader);
@EXPORT  = qw();
$VERSION = '0.01';

my %ESCAPES = (
 '&' => '&',
 '<' => '&lt;',
 '>' => '&gt;',
 '"' => '&quot;',
);

sub add_colgroup {
 my ($self,$cols) = @_;
 $self->{global}->{colgroup} = {} unless $self->{colgroups};
 push @{$self->{colgroups}}, $cols;

}

sub calc_sums {
 my ($self,$cols,$mask) = @_;
 my %sums;

 croak "calc_sums called with no data" unless $self->{rows};

 # the mask will be used when the table footer is created
 $self->{mask} = $mask if $mask;

 $cols = [$cols] unless ref $cols eq 'ARRAY';

 # calculate the sums for requested columns
 foreach my $col (@$cols) {
  $col = lc $col;
  my $index = $self->{fields_hash}->{$col};
  foreach my $row(@{$self->{rows}}) {
   $sums{$col} += $row->[$index] if $row->[$index] =~ /^[-0-9\.]+$/;
  }
 }

 # store sums in the right order, used when footer is created
 $self->{sums} = [ 
  map   { $sums{$_} || '' }
  sort  { $self->{fields_hash}->{$a} <=> $self->{fields_hash}->{$b} }
  keys %{ $self->{fields_hash} }
 ];
}

sub exec_query {
 my ($self,$sql,$vars) = @_;
 my $i = 0;

 $self->{sth} = $self->{dbh}->prepare($sql) || croak $self->{dbh}->errstr;
 $self->{sth}->execute(@$vars)              || croak $self->{sth}->errstr;

 # need to store the names and indexes of the columns
 $self->{fields_arry} = [ map { lc }         @{$self->{sth}->{NAME}} ];
 $self->{fields_hash} = { map { $_ => $i++ } @{$self->{fields_arry}} };

 # encoded and copy the result set 
 $self->{rows} = [ map { [ map { $_ = $self->_xhtml_encode($_) } @$_ ] } @{$self->{sth}->fetchall_arrayref} ];
}

sub get_col_count {
 my ($self) = @_;
 my $count = scalar @{$self->{fields_arry}};
 return $count;
}

sub get_row_count {
 my ($self) = @_;
 my $count = scalar @{$self->{rows}};
 return $count;
}

sub get_table {
 my ($self,$suppress) = @_;
 croak "get_table called with no data" unless $self->{rows};

 $self->{suppress_titles} = $suppress;
 $self->_build_table;

 my $output = $self->{output};
 delete $self->{output};

 return $output || croak "Error: No output\n";
}

sub map_col {
 my ($self,$sub,$cols) = @_;

 $cols = [$cols] unless ref $cols eq 'ARRAY';

 # apply user's subroutine to specified columns
 foreach my $row(@{$self->{rows}}) {
  foreach my $col (@$cols) {
   $col = lc $col;
   my $index = $self->{fields_hash}->{$col};
   $row->[$index] = $sub->($row->[$index]);
  }
 }
}

sub modify_tag {
 my ($self,$tag,$args,$cols) = @_;
 $tag = lc $tag;

 # apply arguments to specified columns
 if (ref $args eq 'HASH') {
  $cols = [$cols = $cols || 'global'] unless ref $cols eq 'ARRAY';
  foreach my $arg (keys %$args) {
   foreach (@$cols) {
    $_ = lc $_;
    $self->{$_}->{$tag}->{$arg} = $args->{$arg};
   }
  }
 }
 # or assign a scalar to an appropriate tag (e.g. <CAPTION>)
 else {
  $self->{global}->{$tag} = $args;
 }
}

sub new {
 my $proto = shift;
 my $class = ref($proto) || $proto;
 my $self = {
  null_value => '&nbsp;',
 };
 bless $self, $class;

 # use user-supplied db handle or create my own?
 my $thingy = $_[0];
 if (ref $thingy eq 'DBI::db') {
  $self->{dbh} = $thingy;
  $self->{keep_alive} = 1;
 }
 else {
  $self->_connect(@_) || return undef;
 }

 return $self;
}

sub set_colors {
 my ($self,$colors,$cols) = @_;

 $cols = 'global' unless $cols;
 $cols = [$cols] unless ref $cols eq 'ARRAY';

 $colors = [$colors] unless ref $colors eq 'ARRAY';

 # assign each column or global a list of colors
 foreach (@$cols) {
  my @tmp = @$colors;
  $self->{lc $_}->{colors} = \@tmp;
 }

}

sub set_group {
 my ($self,$group,$nodup,$value) = @_;
 $self->{group} = lc $group;
 $self->{nodup} = $value || $self->{null_value} if $nodup;
}

sub set_null_value {
 my ($self,$value) = @_;
 $self->{null_value} = $value;
}


##################### PRIVATE ######################################

sub _build_table {

 my ($self) = @_;

 $self->_build_table_header;
 $self->_build_table_body;
 $self->_build_table_footer if $self->{sums};

 $self->{output} =
  _build_tagged_data( 'TABLE', 
   $self->{global}->{table}, 
   $self->{output}->{header} . $self->{output}->{body} . $self->{output}->{footer},
  ) . "\n";
}

sub _build_table_header {

 my ($self) = @_;

 $self->{output}->{header} = "\n";

 # build the caption if applicable
 if(my $caption = $self->{global}->{caption}) {
  $self->{output}->{header} .= "\t" 
   . _build_tagged_data('CAPTION', undef, 
   $self->_xhtml_encode($caption)) . "\n";
 }

 # build the colgroups if applicable
 if(my $attribs = $self->{global}->{colgroup}) {
  $self->{output}->{header} .= "\t" 
   . _build_tagged_data('COLGROUP', $attribs,
   $self->_build_col_tags()) . "\n";
 }

 return if $self->{suppress_titles};

 # build the THEAD
 $self->{output}->{header} .= "\t" 
   . _build_tagged_data('THEAD',$self->{global}->{thead}) . "\n";

 # build the TH rows
 $self->{output}->{header} .=  "\t" 
   . _build_tagged_data('TR',
    $self->{global}->{tr}, 
    $self->_build_table_header_row)
   . "\n";
}

sub _build_table_header_row {

 my ($self) = @_;

 my $output = "\n";

 foreach (@{$self->{fields_arry}}) {

  my $attribs = $self->{$_}->{th} || $self->{global}->{th};
  $output .= "\t\t" 
   . _build_tagged_data('TH', $attribs, ucfirst $_)
   . "\n";
 }

 return $output. "\t";
}


sub _build_col_tags {
 my ($self) = @_;
 my (@cols,$output);

 return undef unless @cols = @{$self->{colgroups}};

 foreach (@cols) {
  $output .= "\n\t\t" . _build_tagged_data('COL', $_);
 }
 $output .= "\n\t";

 return $output;
}

sub _build_table_body {
 my ($self) = @_;

 my $group = $self->{group};
 my $index = $self->{fields_hash}->{$group};
 my $last  = '';

 my $body = "\t" . _build_tagged_data('TBODY',$self->{global}->{tbody}) . "\n";

 $self->{output}->{body} = $body unless $group;

 foreach my $row (@{$self->{rows}}) {

  # handle groups
  if ($group) {
   my $tmp  = $row->[$index];
   unless ($last eq $tmp) {
    $self->{output}->{body} .= $body;
   }
   elsif ($self->{nodup}) {
    $row->[$index] = $self->{nodup};
   }
   $last = $tmp;
  }

  $self->{output}->{body} .= "\t" . _build_tagged_data('TR',
   $self->{global}->{tr}, $self->_build_table_body_rows($row)) . "\n";
 }
}

sub _build_table_body_rows {

 my ($self,$row) = @_;
 my $colors;
 my $output = "\n";

 for (0..$#$row) {
  my $name    = $self->{fields_arry}->[$_];
  my $attribs = $self->{$name}->{td} || $self->{global}->{td};

  # rotate colors if found
  if ($self->{$name}->{colors}) {
   $colors = $self->{$name}->{colors};
   $attribs->{bgcolor} = _rotate($colors);
  }
  elsif ($self->{global}->{colors}) {
   $colors = $self->{global}->{colors};
   $attribs->{bgcolor} = _rotate($colors);
  }

  $output .= "\t\t" . _build_tagged_data('TD', $attribs, $row->[$_]) . "\n";
 }
 return $output . "\t";
}

sub _build_table_footer {
 my ($self) = @_;

 $self->{output}->{footer} = "\t" . _build_tagged_data('TFOOT', $self->{global}->{tfoot}) 
  . "\n\t" . _build_tagged_data('TR', $self->{global}->{tr},
     $self->_build_table_footer_rows) . "\n";
}

sub _build_table_footer_rows {
 my ($self) = @_;

 my $output = "\n";
 my $row    = $self->{sums};

 for (0..$#$row) {
  my $name    = $self->{fields_arry}->[$_];
  my $attribs = $self->{$name}->{th} || $self->{global}->{th};
  my $sum     = ($row->[$_]);

  # use sprintf if mask was supplied
  if ($self->{mask} and $sum = $row->[$_]) {
   $sum = sprintf($self->{mask},$sum)
  }
  else {
   $sum = $sum || $self->{null_value};
  }

  $output .= "\t\t" 
   . _build_tagged_data('TH', $attribs, $sum) . "\n";
 }
 return $output . "\t";
}

# builds a tag and it's enclosed data
sub _build_tagged_data {
 my ($name,$attribs,$cdata) = @_;
 my $text  = "<$name";

 # build the attributes if any
 while(my ($k,$v) = each %{$attribs}) {
  if (ref $v eq 'ARRAY') {
   $v = _rotate($v);
  }
  $text .= ' ' . uc $k . '="' . $v . '"'
 }
 $text .= ($cdata) ? ">$cdata</$name>" : '/>';
}

# attempts to connect to database
# big thanks to Matt Sergant for this
sub _connect {
 my ($self,$dsource,$driver,$user,$pass,$dbname) = @_;
 $self->{datasource} = $dsource;

 $self->{dbh} = DBI->connect(
  "dbi:$driver:$dsource", $user, $pass
 );

 if (!$self->{dbh}) {
  carp "Connection failed:", $self->{dbh}->errstr, "\n";
  return 0;
 }

 if ($dbname) {
  if(!$self->{dbh}->do("use $dbname")) {
   carp "USE $dbname failed\n";
   return 0;
  }
 }

 return 1;
}

# uses %ESCAPES to convert the '5 rings' of XML
# another big thanks to Matt Sergant 
sub _xhtml_encode {
    my ($self,$str) = @_;
 return $str if $str eq '&nbsp;';
    $str =~ s/([&<>"])/$ESCAPES{$1}/ge;
 $str = $str || $self->{null_value};
}

# returns value of and moves first element to last
sub _rotate {
 my ($ref) = shift;
 my $next = shift @$ref;
 push @$ref, $next;
 return $next;
}

# disconnect database handle if i created it
sub DESTROY {
 my ($self) = @_;
 $self->{dbh}->disconnect unless $self->{keep_alive};
}

1;
__END__

=head1 NAME

DBIx::XHTML_Table - Display SQL queries in configurable XHTML tables.

=head1 SYNOPSIS

  use DBIx::XHTML_Table;

  my $table = XHTML_Table->new($datasource, $driver,
    $userid, $password, $dbname) || die "no table\n";

  $table->exec_query("
 SELECT TITLE,ALBUM,YEAR,GENRE
 FROM MP3.SONGS
 WHERE YEAR=? AND GENRE=?
 ORDER BY ARTIST
  ",[$year,$genre]);

  # get the simplelest table possible
  # title columns are automatically wrapped
  # in <TH>'s and belong to the <THEAD/> tag
  my $raw = $table->get_table;

  # start tweaking the table
  $table->modify_tag('TABLE',{
   border      => 1,
   cellspacing => 0,
  });

  # modify all <TH> tags - the names of the columns
  # will nested in <TH> tags, which belong to <THEAD/> 
  $table->modify_tag('TH',{
   bgcolor => '#C0C0C0",
  });

  # modify only <TD> tags for TITLE column
  $table->modify_tag('TD',{
   align   => 'right',
   bgcolor => 'green",
  },'title');

  # modify only <TD> tags for ALBUM and YEAR columns
  # in this case, each column will alternate colors
  $table->modify_tag('TD',{
   width   => 200,
   bgcolor => [qw(green blue red)],
  },[qw(album year)]);

  # impress the boss with rotating row colors
  # (this would override the above method)
  $table->set_colors(
 ["#D0D0D0", "#B0B0B0")],
 [qw(album year)],
  );

  # since we can, sum up the years column
  # sums will be wrapped in <TH>'s belonging to <TFOOT/>
  # optional sprintf mask can be used for formatting
  $table->calc_sums('year','%.02f');

  # suppress duplicates on a group
  $table->set_group('album',1);

  # or . . .
  # supress duplicates with a new 'null value'
  $table->set_group('album',nodups=>'--------');

  # print out the complete table
  print $table->get_table;

=head1 DESCRIPTION

This modules accepts a SQL query, executes it, stores the results
in an internal data structure, and provides methods to modify
the attributes of the XHTML tags that make the table, as well as
methods to tweak the contents of the table, and a method to return
the current state of the table as a single scalar.

This module was created to fill a need for a quick and easy way to
create on the fly XHTML tables from SQL queries, for the purpose
of 'quick and dirty' reporting. There is a method to calculate and
display totals for specified rows, but no methods are currently
available to calculate sub-totals for specifified groups. If you
find youself needing more power over the display of your report, 
you should look into tempating methods such as HTML::Template or
Template-Toolkit. Another viable substitution for this module is
to use DBIx::XML_RDB and XSL stylesheets, but some browsers are
still not XML compliant, and XHTML_Table has the advantage
of displaying at least something on browsers that are not XML or
XHTML compliant. At the worst, only the XHTML tags will be ignored,
and not the content of the report.

The user is highly recommened to become familiar with rules and
structure of XHTML tags. A good, terse reference can be found at
http://www.w3.org/TR/REC-html40/struct/tables.html

This module adopts a laise fair attitude on validation. It doesn't
care. This means that you can create attributes that are not valid
XHTML or even HTML. Since the browser does a good job of validated
the XHTML, the module should not have to bother to determine if
FOO or BAR are valid attributes for a <COLGROUP> tag. XHTML_Table
will happily insert them for you. This also means that new tags
will be supported in the future.

=over 4

=item C<new>


Construct a new XHTML_Table. The arguments can be a single
existing DBI::db object or 5 scalars that contain information
needed to connect to a database:
 $dsource,$driver,$user,$pass,$dbname

If XHTML_Table creates the DBI::db object for you, it will
destroy it when your XHTML_Table object is destroyed. If you
need to keep the database connection open after the XHTML_Table
object is destroyed, create your own and pass it as the single
argument to new.

=item C<exec_query>

Pass the query off to the database with hopes of data being 
returned. The first argument is scalar that contains the SQL
code, the second argument can either be a scalar for one
bind variable or an array reference for multiple bind variables.
You can use variable interpolation in the SQL scalar if you
would rather skip the bind variables. Consult DBI for more details
on bind vars.

After the query successfully exectutes, the results will be
stored interally as an array reference of array references (or
a two dimensional array if you will). The XHTML table tags will
not be generated until get_table is invoked, and the results
can be modified via map_column before they are used by get_table.

=item C<get_table>

Creates and returns the XHTML table. The only argument is a
non-zero defined value that suppresses the column titles. The
column footers can be suppressed by not calculating sums, and
the body can be suppressed by an appropriate SQL query. The
caption and colgroup cols can be suppressed by not modifying
them. The column titles are the only part that has to be
specifically told not to generate, and this is where you do that.

=item C<modify_tag>

Modify the attributes of a valid XHTML tag for specified columns
or the entire table in no columns are specified. The first argument
is a reference to hash containing name-value pairs for attributes.
The second is the column or columns to apply this modification to.
You can either specify one column with a scalar containing the
name of the column or you can specify a group of columns with an
array reference of scalars. If no columns are specified, this
modification will affect all tags that are not modified by some
column. The process can be thought of as a column owning the tag,
anytime a table cell is rendered in that column, it uses the
attributes 

It is your responsibility to adhear to the XHTML standard, and this
module will not even attempt to validate your attributes. You are
guaranteed that the following tags will be recognized when the
table is generated: TABLE CAPTION COLGROUP COL TR TH TD THEAD TBODY TFOOT 

The only magical attribute is bgcolor, if the value is an array
reference then the contents will be treated as alternating colors.
This alternation happens at the column level, not the row level. 
For row color alternation use set_color. You can specify as many
colors as you wish with either method.

The only tag that cannot be modified by this method is the <COL>
tag. Use add_colgroup to add these tags instead.

=item C<add_colgroup>

Add a new <COL> tag and attributes. The only argument is reference
to a hash that contains the attributes for this <COL> tag. Multiple
<COL> tags require multiple calls to this method. The <COLGROUP> tag
pair will be automagically generated if at least one <COL> tag is
added.

=item C<map_column>

Map a supplied subroutine to all body cells for specified columns.
The first argument is a reference to a subroutine. This subroutine
should shift off a single scalar at the beginning, munge it any
way thats fit, and then return it. The second argument is the column
or columns to apply this subroutine to. The body data will be
permanently changed by your subroutine.

=item C<set_colors>

Assign a list of colors to the body cells for specified columns
or the entire table if none specified.

=item C<set_group>

Assign one column as the main column. Every time a new row is
encountered for this column, a <TBODY> tag is written. An optional
second argument that contains a non-zero value will cause duplicates
to be permanantly eliminated for this row. An optional third argument
specifies what value to replace for duplicates, default is &nbsp;
Don't assign a column that has a different value each row, choose
one that is a super class to the rest of the data, for example,
pick artist over song, since an artist has several songs.

=item C<set_null_value>

Change to defualt null_value (&nbsp;) Usefull if you are dealing
with numbers - you can set this zero.

=item C<calc_sums>

Computes sums for specified columns. The first argument is the column
or columns to sum, again a scalar or array reference is the requirement.
Non-numbers will be ignored, negatives and floating points are supported,
but you have to supply an appropriate sprintf maks, which is the optional
second argument, in order for the sum to be correctly formatted. See the
documentation for sprintf for further details.  

=item C<get_col_count>

Returns the number of columns in the table.

=item C<get_row_count>

Returns the numbers of body rows in the table.

=back

=head1 BUGS

Becuase this module does not validate your attributes there
are ways to generate bugs that are yet unaccounted for.
Experiment, have fun with it. Go to PerlMonks and download
extremely's HTML Color Spectrum thingy and use it supply
a list of colors to set_color(). You can find it at
 http://www.perlmonks.org/index.pl?node_id=70521

=head1 CREDITS

Many thanks to the Perl Monks community. Thanks to OeufMayo
for convincing me to write XHTML_Table and not HTML_Table.

=head1 SEE ALSO 

=over 8

=item *

DBIx::XML_RDB

=item *

Data::Table

=item *

HTML::Template

=back

=head1 AUTHOR AND COPYRIGHT

Copyright 2001, Jeffrey Hayes Anderson
captvanhalen@yahoo.com

DBIx::XHTML_Table may be copied and distributed
on the same terms as Perl itself.

=cut