DbFramework::PrimaryKey - Primary key class

  use DbFramework::PrimaryKey;
  $pk   = new DbFramework::Primary(\@attributes,$table,\@labels);
  $sql  = $pk->as_sql;
  $html = $pk->html_select_field(\@column_names,$multiple,\@default);
  $html = $pk->as_html_heading;
  $html = $pk->as_hidden_html(\%values);
  $qw   = $pk->as_query_string(\%values);

package DbFramework::PrimaryKey;
use strict;
use base qw(DbFramework::Key);
use Alias;
use vars qw( $NAME $BELONGS_TO @INCORPORATES_L $BGCOLOR $_DEBUG );
use CGI;
use URI::Escape;

# CLASS DATA

my %fields = (
              # PrimaryKey 0:N Incorporates 0:N ForeignKey
              INCORPORATES => undef,
	      LABELS_L     => undef,
);

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

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

  my(@bad,@labels);
  if ( defined($_[0]) ) {
    my @columns = $table->attribute_names;
    @labels  = @{$_[0]};
    for my $label ( @labels ) {
      push(@bad,$label) unless grep(/^$label$/,@columns);
    }
    die "label column(s) '@bad' do not exist in '",$table->name,"'" if @bad;
  } else {
    @labels = $table->attribute_names;
  }
  $self->labels_l(\@labels);
  $self->bgcolor('#00ff00');
  return $self;
}

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

sub as_sql {
  my $self = attr shift;
  return "PRIMARY KEY (" . join(',',$self->attribute_names) . ")";
}

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

sub html_select_field {
  my $self = attr shift;

  my @labels     = $_[0] || @{$self->labels_l};
  my $multiple   = $_[1];
  # this is hard-coded for single-attribute primary keys
  my $default    = $multiple ? $_[2] : $_[2]->[0];
  my $name       = $_[3];
  my @pk_columns = $self->attribute_names;
  my $pk         = join(',',@pk_columns);
  my @columns    = (@pk_columns,@labels);

  # build SELECT statement
  my(%tables,%where);
  my $table_name = $self->BELONGS_TO->name;
  @{$tables{$table_name}} = @pk_columns;
  my $order = 'ORDER BY ';
  for my $label ( @labels ) {
    my($table_name,@labels);
    my($attribute) = $BELONGS_TO->get_attributes($label);
    # handle foreign keys with > 1 attribute here!
    if ( my($fk) = $BELONGS_TO->in_foreign_key($attribute) ) {
      # get label columns from related table
      $table_name = $fk->references->belongs_to->name;
      @labels     = @{$fk->references->labels_l};
      $where{$table_name} = $fk->sql_where;
    } else {
      $table_name = $BELONGS_TO->name;
      @labels     = ($label);
    }
    push @{$tables{$table_name}},@labels;
    for ( @labels ) { $order .= "$table_name.$_," }
  }
  chop $order;

  my $from  = 'FROM ' . join(',',keys(%tables));
  my $select = 'SELECT ';
  # do this table first so that pk columns are returned at the front
  for ( @{$tables{$table_name}} ) { $select .= "$table_name.$_," }
  delete $tables{$table_name};
  while ( my($table,$col_ref) = each %tables ) {
    for ( @$col_ref ) { $select .= "$table.$_," }
  }
  chop $select;
  my @where = values(%where);
  my $where = @where ? 'WHERE ' : '';
  for ( my $i = 0; $i <= $#where; $i++ ) {
    $where .= ' AND ' if $i;
    $where .= $where[$i];
  }
  my $sql = "$select\n$from\n$where\n$order\n";
  print STDERR $sql if $_DEBUG;
  my $sth = DbFramework::Util::do_sql($BELONGS_TO->dbh,$sql);

  # prepare arguments for CGI methods
  my (@pk_values,%labels,@row);
  my $i = 0;
  $pk_values[$i++] = ''; $labels{''} = '** Any Value **';
  $pk_values[$i++] = 'NULL'; $labels{'NULL'} = 'NULL';
  while ( my $row_ref = $sth->fetchrow_arrayref ) {
    @row = @{$row_ref};
    my $pk = join(',',@row[0..$#pk_columns]); # pk fields
    $pk_values[$i++] = $pk;

    # label fields
    for ( @row[$#pk_columns+1..$#row] ) {
      $labels{$pk} .= ' ' if defined($labels{$pk});
      $labels{$pk} .= defined($_) ? $_ : 'NULL';
    }
  }

  $name = $pk unless $name;

  my $html;
  my $cgi = new CGI('');  # we just want this object for its methods
  if ( $multiple ) {
    $html = $cgi->scrolling_list(-name=>$name,
				 -values=>\@pk_values,
				 -labels=>\%labels,
				 -multiple=>'true',
				 -default=>$default,
				);
  } else {
    $html = $cgi->popup_menu(-name=>$name,
			     -values=>\@pk_values,
			     -labels=>\%labels,
			     -default=>$default,
			    );
  }

  return $html;
}

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

sub _input_template {
  my($self,@fk_attributes) = @_;
  attr $self;
  print STDERR "$self: _input_template(@fk_attributes)\n" if $_DEBUG;
  my $t_name = $BELONGS_TO ? $BELONGS_TO->name : 'UNKNOWN_TABLE';
  my $in;
  for my $attribute ( @INCORPORATES_L ) {
    my $a_name = $attribute->name;
    unless ( grep(/^$a_name$/,@fk_attributes) ) { # part of foreign key
      print STDERR "Adding $a_name to input template for pk in $t_name\n" if $_DEBUG;
      $in .= qq{<TD><DbField ${t_name}.${a_name}></TD>
};
    }
  }
  $in;
}

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

sub _output_template {
  my($self,@fk_attributes) = @_;
  attr $self;
  my $t_name = $BELONGS_TO ? $BELONGS_TO->name : 'UNKNOWN_TABLE';
  my $out;
  for ( @INCORPORATES_L ) {
    my $a_name = $_->name;
    unless ( grep(/^$a_name$/,@fk_attributes) ) { # part of foreign key
      $out .= qq{<TD BGCOLOR='$BGCOLOR'><DbValue ${t_name}.${a_name}></TD>};
    }
  }
  $out;
}

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

sub as_html_heading {
  my $self = attr shift;
  my @fk_attributes = @_;
  my @attributes;
  for ( @INCORPORATES_L ) {
    my $a_name = $_->name;
    push(@attributes,$_)
      unless grep(/^$a_name$/,@fk_attributes); # part of foreign key
  }
  return '' unless @attributes;
  my $html = "<TD BGCOLOR='$BGCOLOR' COLSPAN=".scalar(@attributes).">";
  for ( @attributes ) {
    my $a_name = $_->name;
    my $extra  = $_->references->extra
      ? ' ('.$_->references->extra.')'
      : '';
    $html .= "$a_name$extra,";
  }
  chop($html);
  "$html</TD>";
}

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

sub as_query_string {
  my $self = attr shift;
  my %values = $_[0] ? %{$_[0]} : ();
  my $qs;
  for ( $self->attribute_names ) {
    my $value = $values{$_} ? $values{$_} : '';
    $qs .= "$_=$value&";
  }
  chop($qs);
  uri_escape($qs);
}

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

sub as_hidden_html {
  my $self       = attr shift;
  my %values     = $_[0] ? %{$_[0]} : ();
  my $table_name = $self->BELONGS_TO->name;
  my $html;
  for ( $self->attribute_names ) {
    my $value = defined($values{$_}) ? $values{$_} : '';
    $html    .= qq{<input type="hidden" name="pk_$_" value="$value">\n};
  }
  $html;
}

1;