DbFramework::Table - Table class

  use DbFramework::Table;

  $t    = new DbFramework::Table new($name,\@attributes,$pk,$dbh,$dm);
  $t->init_db_metadata($catalog);
  $dbh  = $t->dbh($dbh);
  $pk   = $t->is_identified_by($pk);
  @fks  = @{$t->has_foreign_keys_l};
  %fks  = %{$t->has_foreign_keys_h};
  @keys = @{$t->is_accessed_using_l};
  @a    = $t->get_attributes(@names);
  @n    = $t->attribute_names;
  $html = $t->as_html_form;
  $s    = $t->as_string;
  $sql  = $t->as_sql;
  $rows = $t->delete($conditions);
  $pk   = $t->insert(\%values);
  $rows = $t->update(\%values,$conditions);
  @lol  = $t->select(\@columns,$conditions,$order);
  @loh  = $t->select_loh(\@columns,$conditions,$order);
  @a    = $t->non_key_attributes;
  $dm   = $t->belongs_to;
  @fks  = $t->in_foreign_key($attribute);
  do_something if $t->in_key($attribute);
  do_something if $t->in_primary_key($attribute);
  do_something if $t->in_any_key($attribute);

package DbFramework::Table;
use strict;
use vars qw( $NAME @CONTAINS_L $IS_IDENTIFIED_BY $_DEBUG @IS_ACCESSED_USING_L
	     @HAS_FOREIGN_KEYS_L $DBH %TEMPLATE_H @CGI_PK %FORM_H
	     $BELONGS_TO );
use base qw(DbFramework::DefinitionObject DbFramework::DataModelObject);
use DbFramework::PrimaryKey;
use DbFramework::DataType::ANSII;
use DbFramework::DataType::Mysql;
use DbFramework::Attribute;
use DbFramework::Catalog;
use Alias;
use Carp;
use CGI;

# CLASS DATA

my %fields = (
	      # Entity 1:1 IsIdentifiedBy 1:1 PrimaryKey
	      IS_IDENTIFIED_BY    => undef,
	      # Entity 1:1 HasForeignKeys 0:N ForeignKey
	      HAS_FOREIGN_KEYS_L  => undef,
	      HAS_FOREIGN_KEYS_H  => undef,
	      # Table 1:1 IsAccessedUsing 0:N Key
	      IS_ACCESSED_USING_L => undef,
	      # Table 1:1 BelongsTo 1:1 DataModel
	      BELONGS_TO          => undef,
	      DBH                 => undef,
	      TEMPLATE_H          => undef,
	      FORM_H              => undef,
	     );
my $formsdir = '/usr/local/etc/dbframework/forms';

##-----------------------------------------------------------------------------
## CLASS METHODS
##-----------------------------------------------------------------------------

sub new {
  my $proto = shift;
  my $class = ref($proto) || $proto;
  my $self  = bless($class->SUPER::new(shift,shift),$class);
  for my $element (keys %fields) {
    $self->{_PERMITTED}->{$element} = $fields{$element};
  }
  @{$self}{keys %fields} = values %fields;
  $self->is_identified_by(shift);
  $self->dbh(shift);
  $self->belongs_to(shift);
  return $self;
}

##-----------------------------------------------------------------------------
## OBJECT METHODS
##-----------------------------------------------------------------------------

sub get_attributes {
  my $self = attr shift;
  print STDERR "getting attributes for (",join(',',@_),")\n" if $_DEBUG;
  return @_ ? $self->contains_h_byname(@_) # specific attributes
            : @{$self->contains_l};	   # all attributes
}

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

sub attribute_names {
  my $self = attr shift;
  my @names;
  for ( @CONTAINS_L ) { push(@names,$_->name) }
  @names;
}

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

sub as_html_form {
  my $self = attr shift;
  my $form;
  for ( @CONTAINS_L ) { $form .= "<tr><td>" . $_->as_html_form_field . "</td></tr>\n" }
  $form;
}

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

sub in_foreign_key {
  my($self,$attribute) = (attr shift,shift);
  my $name = $attribute->name;
  my @in = ();
  print STDERR "foreign keys: @HAS_FOREIGN_KEYS_L\n" if $_DEBUG;
  for ( @HAS_FOREIGN_KEYS_L ) {
    my @fk_names = $_->attribute_names;
    push @in,$_ if grep(/^$name$/,@fk_names);
  }
  return @in;
}

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

sub in_primary_key {
  my($self,$attribute) = (attr shift,shift);
  my $name     = $attribute->name;
  my @pk_names = $self->is_identified_by->attribute_names;
  print STDERR "Looking for $name in @pk_names\n" if $_DEBUG;
  return grep(/^$name$/,@pk_names) ? 1 : 0;
}

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

sub in_key {
  my($self,$attribute) = (attr shift,shift);
  my @k_names = ();
  my $name    = $attribute->name;
  for ( @IS_ACCESSED_USING_L ) { push(@k_names,$_->attribute_names) }
  print STDERR "Looking for $name in @k_names\n" if $_DEBUG;
  return grep(/^$name$/,@k_names) ? 1 : 0;
}

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

sub in_any_key {
  my($self,$attribute) = (attr shift,shift);
  print STDERR "$self->in_any_key($attribute)\n" if $_DEBUG;
  return ($self->in_key($attribute)         ||
	  $self->in_primary_key($attribute) ||
	  $self->in_foreign_key($attribute)) ? 1 : 0;
}

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

sub non_key_attributes {
  my $self = attr shift;
  my @non_key;
  for ( @CONTAINS_L ) { push(@non_key,$_) unless $self->in_any_key($_) }
  @non_key;
}

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

#=head2 html_hidden_pk_list()

#Returns a 'hidden' HTML form field whose key consists of the primary
#key column names separated by '+' characters and whose value is the
#current list of @CGI_PK

#=cut

#sub html_hidden_pk_list {
#  my $self   = attr shift;
#  my $cgi    = new CGI('');
#  return $cgi->hidden(join('+',@{$PRIMARY->column_names}),@CGI_PK) . "\n";
#}

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

sub as_string {
  my $self = attr shift;
  my $s    = "Table: $NAME\n";
  for ( @{$self->contains_l} ) { $s .= $_->as_string }
  return $s;
}

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

sub init_db_metadata {
  my $self  = attr shift;
  my $catalog = shift;

  my $driver = $self->belongs_to->driver;
  my($sql,$sth,$rows,$rv);
  # query to get typeinfo
  if ( ! defined($self->belongs_to) || $driver eq 'mSQL' ) {
    $sql   = qq{SELECT * FROM $NAME};
  } else {
    # more efficient query for getting typeinfo but not supported by mSQL
    $sql   = qq{SELECT * FROM $NAME WHERE 1 = 0};
  }
  $sth = DbFramework::Util::do_sql($DBH,$sql);
  
  my %datatypes = ( mysql => 'Mysql' ); # driver-specific datatype classes
  my @columns;
  for ( my $i = 0; $i < $sth->{NUM_OF_FIELDS}; $i++ ) {
    my $class = ( defined($self->belongs_to) && 
		  exists($datatypes{$driver}) 
		)
      ? $datatypes{$driver}
      : 'ANSII';
    my $name = $sth->{NAME}->[$i];
  # if driver-specific class exists, get the driver-specific type
    my($type,$ansii_type,$default,$extra);
  SWITCH: for ( $class ) {
    /Mysql/ && do {
      print STDERR "mysql_type = ",join(',',@{$sth->{mysql_type}}),"\n"
	if $_DEBUG;
      $type = $sth->{mysql_type}->[$i];
      $ansii_type = $sth->{TYPE}->[$i];
      my $sth = DbFramework::Util::do_sql($DBH,"DESCRIBE $NAME $name");
      my $metadata = $sth->fetchrow_hashref;
      ($default,$extra) = ($metadata->{Default},uc($metadata->{Extra}));
      $sth->finish;
      last SWITCH;
    };
    /ANSII/ && do {
      $ansii_type = $type = $sth->{TYPE}->[$i];
      last SWITCH;
    };
  }
    $class = "DbFramework::DataType::$class";
    my $precision = $sth->{PRECISION}->[$i];

    my $d = $class->new($self->belongs_to,
			$type,
			$ansii_type,
			$precision,
			$extra,
		       );
    my $a = new DbFramework::Attribute($sth->{NAME}->[$i],
                                       $default,
                                       $sth->{NULLABLE}->[$i],
                                       $d
                                      );
    push(@columns,$a);
  }
  $self->_init(\@columns);

  ## add keys
  $catalog->set_primary_key($self);
  $catalog->set_keys($self);

  #$self->_templates;  # set default templates

  return $self;
}

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

sub as_sql {
  my $self = attr shift;
  my $sql = "CREATE TABLE $NAME (\n";
  for ( @{$self->contains_l} ) { $sql .= "\t" . $_->as_sql($DBH) . ",\n"; }
  $sql .= "\t" . $IS_IDENTIFIED_BY->as_sql;
  for ( @IS_ACCESSED_USING_L ) { $sql .= ",\n\t" . $_->as_sql }
  for ( @HAS_FOREIGN_KEYS_L )  { $sql .= ",\n\t" . $_->as_sql }
  return "$sql\n)";
}

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

#=head2 validate_foreign_keys()

#Ensure that foreign key definitions match related primary key
#definitions.

#=cut

sub validate_foreign_keys {
  my $self = shift;
  attr $self;

  for my $fk ( @HAS_FOREIGN_KEYS_L ) {
    my $fk_name       = $fk->name;
    my @fk_attributes = @{$fk->incorporates_l};
    my @pk_attributes = @{$fk->references->incorporates_l};
    @fk_attributes == @pk_attributes ||
      die "Number of attributes in foreign key $NAME:$fk_name(",scalar(@fk_attributes),") doesn't match that of related primary key (",scalar(@pk_attributes),")";
    for ( my $i = 0; $i <= $#fk_attributes; $i++) {
      my($fk_aname,$pk_aname) =
        ($fk_attributes[$i]->name,$pk_attributes[$i]->name);
      print STDERR "$fk_aname eq $pk_aname\n" if $_DEBUG;
      #$fk_aname eq $pk_aname ||
      #  die "foreign key component $NAME:$fk_aname ne primary key component $pk_aname\n";
    }
  }
}

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

sub delete {
  my($self,$conditions) = (attr shift,shift);

  my $sql  = "DELETE FROM $NAME";
     $sql .= " WHERE $conditions" if $conditions;
  print STDERR "$sql\n" if $_DEBUG;
  return $DBH->do($sql) || die($DBH->errstr);
}
#------------------------------------------------------------------------------

sub insert {
  my $self   = attr shift;
  my %values = %{$_[0]};

  my(@columns,$values);
  for ( keys(%values) ) {
    next unless defined($values{$_});
    push(@columns,$_);
    my $type = $self->get_attributes($_)->references->ansii_type;
    print STDERR "value = $values{$_}, type = $type\n" if $_DEBUG;
    $values .= $self->_quote($values{$_},$type) . ',';
  }
  chop $values;
  my $columns = '(' . join(',',@columns). ')';

  my $sql = "INSERT INTO $NAME $columns VALUES ($values)";
  print STDERR "$sql\n" if $_DEBUG;

  my $sth = $DBH->prepare($sql) || die $DBH->errstr;
  my $rv  = $sth->execute       || die "$sql\n" . $sth->errstr . "\n";
  my $rc  = $sth->finish;

  if ( $self->belongs_to->driver eq 'mysql' ) {
    # id of auto_increment field
    return $sth->{mysql_insertid};
  } else {
    return -1;
  }
}
#------------------------------------------------------------------------------

sub update {
  my $self = attr shift;
  my %values     = %{$_[0]};
  my $conditions = $_[1];

  my $values;
  for ( keys %values ) {
    next unless $values{$_};
    my $dt   = $self->get_attributes($_)->references;
    my $type = $dt->ansii_type;
    print STDERR "\$type = ",$dt->name,"($type)\n" if $_DEBUG;
    $values .= "$_ = " . $self->_quote($values{$_},$type) . ',';
  }
  chop $values;
  
  my $sql  = "UPDATE $NAME SET $values";
     $sql .= " WHERE $conditions" if $conditions;
  print STDERR "$sql\n" if $_DEBUG;
  return $DBH->do($sql) || die($DBH->errstr);
}

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

sub select {
  my $self = attr shift;
  my $sth  = $self->_do_select(@_);
  my @things;
  # WARNING!
  # Can't use fetchrow_arrayref here as it returns the *same* ref (man DBI)
  while ( my @attributes = $sth->fetchrow_array ) {
    print "@attributes\n" if $_DEBUG;
    push(@things,\@attributes);
  }
  if ( $_DEBUG ) {
    print "@things\n";
    for ( @things ) { print "@{$_}\n" }
  }
  return @things;
}

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

sub select_loh {
  my $self = attr shift;
  my $sth  = $self->_do_select(@_);
  my @things;
  while ( $_ = $sth->fetchrow_hashref ) {
    # fetchrow_hashref may not return a fresh hashref in future (man DBI)
    my %hash = %{$_};
    push(@things,\%hash);
  }
  return @things;
}

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

# select(\@columns,$conditions,$order)
# returns a statement handle for a SELECT

sub _do_select {
  my $self = attr shift;
  my($columns_ref,$conditions,$order,$function_ref) = @_;
  my @columns = defined($columns_ref) ? @$columns_ref : $self->attribute_names;
  my $sql        = "SELECT " . join(',',@columns) . " FROM $NAME";
     $sql       .= " WHERE $conditions" if $conditions;
     $sql       .= " ORDER BY $order"   if $order;
  print STDERR "$sql\n" if $_DEBUG;
  my $sth = $DBH->prepare($sql) || die($DBH->errstr);
  my $rv  = $sth->execute       || die "$sql\n" . $sth->errstr . "\n";
  return $sth;
}

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

#=head2 fill_template($name,\%values)

#Return the filled HTML template named I<$name>.  A template can
#contain special placeholders representing columns in a database table.
#Placeholders in I<$template> can take the following forms:

#=over 4

#=item B<E<lt>DbField table.column [value=value] [type=type]E<gt>>

#If the table's name() matches I<table> in a B<DbField> placeholder,
#the placeholder will be replaced with the corresponding HTML form
#field for the column named I<column> with arguments I<value> and
#I<type> (see L<DbFramework::Attribute/html_form_field()>).  If
#I<%values> is supplied placeholders will have the values in I<%values>
#added where a key in I<%values> matches a column name in the table.

#=item B<E<lt>DbFKey table.fk_name[,column...]E<gt>>

#If the table's name() matches I<table> in a B<DbFKey> placeholder, the
#placeholder will be replaced with the a selection box containing
#values and labels from the primary key columns in the related table.
#Primary key attribute values in I<%values> will be used to select the
#default item in the selection box.

#=item B<E<lt>DbValue table.column[,column...]E<gt>>

#If the table's name() matches I<table> in a B<DbValue> placeholder,
#the placeholder will be replaced with the values in I<%values> where a
#key in I<%values> matches a column name in the table.

#=item B<E<lt>DbJoin table.column.template[.order][.column_name[;column_name...]]E<gt>>

#A B<DbJoin> placeholder will cause a join to be performed between this
#table and the table specified in I<table> over the column I<column>
#where the value equals I<%values{column}> orderd by I<order>.  Values
#will be selected from columns specified with I<column_name>.
#I<column_name> may refer to functions supported by the database in a
#B<SELECT> clause.  If no I<column_name>s are specified, the values
#from all columns from I<table> will be selected.  The placeholder will
#be replaced by the concatenation of I<template> filled with the values
#from each row returned by the join.  B<DbJoin> placeholders may be
#chained.

#=back

#The easiest way to pass the values required to fill a template is by
#calling fill_template() with the name of the template and the hashrefs
#returned by select_loh() e.g.

#  for ( $foo->select_loh(\@columns) ) {
#    $html .= $foo->fill_template($template,$_)
#  }

#=cut

sub fill_template {
  my($self,$name,$values) = (attr shift,shift,shift);
  print STDERR "filling template '$name' for table '$NAME'\n" if $_DEBUG;
  return '' unless exists $TEMPLATE_H{$name};

  my $template = $TEMPLATE_H{$name};
#  if ( $_DEBUG ) {
#    print STDERR "\$template = $template\n";
#    print STDERR "\$values = ", defined($values) ? %$values : 'undef',"\n" ;
#  }
#  my $error;
#  my $rc = Parse::ePerl::Expand({
#			  Script => $template,
#			  Result => \$template,
#			  Error  => \$error,
#			 });
#  die "Error parsing ePerl in template $name: $error" unless $rc;
#  if ( $_DEBUG ) {
#    print STDERR "\$rc = $rc\n";
#    print STDERR "\$template = ",defined($template) ? $template : 'undef',"\n";
#  }

  my %fk = %{$self->has_foreign_keys_h};

  # insert values into template
  if ( defined($values) ) {
    # only works for single column foreign keys
    $template =~ s/<DbJoin\s+(\w+)\.(\w+)\.(\w+)(\.(\w*))?(\.(.*))?\s*>/$self->_join_fill_template($1,$2,$3,$5,$values->{$2},$7)/eg;

    $template =~ s/(<DbField\s+$NAME\.)(\w+)(\s+value=)(.*?\s*)>/$1$2 value=$values->{$2}>/g;
    $template =~ s/(<DbField $NAME\.)(\w+)>/$1$2 value=$values->{$2}>/g;
    # handle multiple attributes here for foreign key values
    $template =~ s/<DbValue\s+$NAME\.([\w,]+)\s*>/join(',',@{$values}{split(m{,},$1)})/eg;
    # values which are the result of applying functions to a column
    $template =~ s/<DbValue\s+$NAME\.(.+)\s*>/$values->{$1}/g;
  }

  #print STDERR "template = \n$TEMPLATE_H{$name}\n\$values = ",%$values,"\n" if $_DEBUG;

  # foreign key placeholders
  $template =~ s/<DbFKey\s+$NAME\.(\w+)\s*>/$fk{$1}->as_html_form_field($values)/eg;

  # form field placeholders
  $template =~ s/<DbField\s+$NAME\.(\w+)\s+value=(.*?)\s+type=(.*?)>/$self->_as_html_form_field($1,$2,$3)/eg;
  $template =~ s/<DbField\s+$NAME\.(\w+)\s+value=(.*?)>/$self->_as_html_form_field($1,$2)/eg;
  $template =~ s/<DbField $NAME\.(\w+)>/$self->_as_html_form_field($1)/eg;

  $template;
}

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

sub _as_html_form_field {
  my($self,$attribute) = (shift,shift);
  my @attributes = $self->get_attributes($attribute);
  $attributes[0]->as_html_form_field(@_);
}

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

#=head2 set_templates(%templates)

#Adds the contents of the files which are the values in I<%templates>
#as templates named by the keys in I<%templates>.  Returns a reference
#to a hash of all templates.

#=cut

sub set_templates {
  my $self = attr shift;
  if ( @_ ) {
    my %templates = @_;
    my @templates;
    for ( keys %templates ) {
      open(T,"<$templates{$_}") || die "Couldn't open template $templates{$_}";
      my @t = <T>;
      close T;
      push(@templates,$_,"@t");
    }
    $self->template_h(\@templates);
  }
  \%TEMPLATE_H;
}

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

sub _templates {
  my $self = attr shift;
  $self->_template('input','_input_template');
  $self->_template('output','_output_template');
}

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

sub _template {
  my($self,$method) = (attr shift,shift);
  my @fk_attributes;
  for ( @HAS_FOREIGN_KEYS_L ) { push(@fk_attributes,$_->attribute_names) }
  my $t = $IS_IDENTIFIED_BY->$method(@fk_attributes) || '';
  for ( $self->non_key_attributes ) { $t .= $_->$method($NAME) }
  for ( @IS_ACCESSED_USING_L )      { $t .= $_->$method() }
  for ( @HAS_FOREIGN_KEYS_L )       { $t .= $_->$method() }
  $t;
}

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

#=head2 read_form($name,$path)

#Assigns the contents of a file to a template.  I<$name> is the name of
#the template and I<$path> is the path to the file.  If I<$path> is
#undefined, tries to read
#F</usr/local/etc/dbframework/$db/$table/$name.form>, where I<$db> is
#the name of the database containing the table and I<$table> is the
#name of the table.  See L<Forms and Templates>.

#=cut

sub read_form {
  my $self = attr shift;
  my $name = shift;
  my $db = $self->belongs_to ? $self->belongs_to->db : 'UNKNOWN_DB';
  my $path = shift || "$formsdir/$db/$NAME/$name.form";
  $TEMPLATE_H{$name} = _readfile_no_comments($path,"Couldn't open form");
}

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

sub _readfile_no_comments {
  my($file,$error) = @_;
  open FH,"<$file" or die "$error: $file: $!";
  my $lines;
  while (<FH>) {
    next if /^\s*#/;
    $lines .= $_;
  }
  close FH;
  $lines;
}

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

sub as_html_heading {
  my $self = attr shift;
  my $method = 'as_html_heading';
  my @fk_attributes;
  for ( @HAS_FOREIGN_KEYS_L ) { push(@fk_attributes,$_->attribute_names) }
  my $html = $IS_IDENTIFIED_BY->$method(@fk_attributes);
  for ( $self->non_key_attributes ) { $html .= $_->$method() }
  my @key_attributes = (@fk_attributes, $IS_IDENTIFIED_BY->attribute_names);
  my(%key_attributes,$bgcolor);
  for my $key ( @IS_ACCESSED_USING_L ) {
    # get unique hash of key attributes
    for ( @{$key->incorporates_l} ) {
      my $name = $_->name;
      $key_attributes{$_->name} = $_ unless grep(/^$name$/,@key_attributes);
    }
    $bgcolor = $key->bgcolor;
  }
  for ( values(%key_attributes) )   { $html .= $_->$method($bgcolor) }
  for ( @HAS_FOREIGN_KEYS_L )       { $html .= $_->$method() }
  "<TR>$html</TR>";
}

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

# Returns an HTML string by filling I<$template> in I<table> with the
# values SELECTed WHERE the values in the I<$column_name> match $value.

sub _join_fill_template {
  my $self = attr shift;
  my($table_name,$column_name,$template,$order,$value,$columns) = @_;
  print STDERR "\@_ = @_\n\$columns = $columns\n" if $_DEBUG;
  my($table) = $BELONGS_TO->collects_table_h_byname($table_name)
    or die("Can't find table $table_name in data model ".$BELONGS_TO->name);
  my @columns = $columns ? split(';',$columns) : $table->attribute_names;
  my $html;
  $table->read_form($template);
  for my $hashref ( $table->select_loh(\@columns,"$column_name = $value",$order) ) {
    print STDERR "\$template = $template, \$hashref = ",%$hashref,"\n" if $_DEBUG;
    $html .= $table->fill_template($template,$hashref);
  }
  $html;
}

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

# workaround for lack of quoting in dates
# Jochen says it will be fixed in later releases of DBD::mysql
sub _quote {
  my($self,$value,$type) = @_;
  $type = 12 if $type == 9;
  return $self->dbh->quote($value,$type);
}

1;