=head1 NAME
DbFramework::PrimaryKey - Primary key class
=head1 SYNOPSIS
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);
=head1 DESCRIPTION
The B<DbFramework::PrimaryKey> class implements primary keys for a
table.
=head1 SUPERCLASSES
B<DbFramework::Key>
=cut
use strict;
use Alias;
use vars qw( $NAME $BELONGS_TO @INCORPORATES_L $BGCOLOR $_DEBUG );
use CGI;
# CLASS DATA
my %fields = (
# PrimaryKey 0:N Incorporates 0:N ForeignKey
INCORPORATES => undef,
LABELS_L => undef,
);
#-----------------------------------------------------------------------------
## CLASS METHODS
#-----------------------------------------------------------------------------
=head1 CLASS METHODS
=head2 new(\@attributes,$table,\@labels)
Create a new B<DbFramework::PrimaryKey> object. I<@attributes> is a
list of B<DbFramework::Attribute> objects from a single
B<DbFramework::Table> object which make up the key. I<$table> is the
B<DbFramework::Table> to which the primary key belongs. I<@labels> is
a list of column names which should be used as labels when calling
html_select_field(). I<@labels> will default to all columns in
I<$table>.
=cut
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;
}
#-----------------------------------------------------------------------------
=head1 OBJECT METHODS
=head2 as_sql()
Returns a string which can be used in an SQL 'CREATE TABLE' statement
to create the primary key.
=cut
sub as_sql {
my $self = attr shift;
return "PRIMARY KEY (" . join(',',$self->attribute_names) . ")";
}
##----------------------------------------------------------------------------
=head2 html_select_field(\@column_names,$multiple,\@default,$name)
Returns an HTML form select field where the value consists of the
values from the columns which make up the primary key and the labels
consist of the corresponding values from I<@column_names>. If
I<@column_names> is undefined the labels consist of the values from
all column names. If I<$multiple> is defined the field will allow
multiple selections. I<@default> is a list of values in the select
field which should be selected by default. For fields which allow
only a single selection the first value in I<@default> will be used as
the default. If I<$name> is defined it will be used as the name of
the select field, otherwise the name will consist of the attribute
names of the primary key joined by ',' (comma) and the values will
consist of the corresponding attribute values joined by ',' (comma).
=cut
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;
}
#-----------------------------------------------------------------------------
=head2 as_html_heading()
Returns a string for use as a column heading cell in an HTML table;
=cut
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>";
}
#-----------------------------------------------------------------------------
=head2 as_query_string(\%values)
Returns a CGI query string consisting of attribute names from the
primary key and their corresponding values from I<%values>.
=cut
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);
}
#-----------------------------------------------------------------------------
=head2 as_hidden_html(\%values)
Returns hidden HTML form fields for each primary key attribute. The
field name is B<pk_$attribute_name>. The field value is the value in
I<%values> whose key is I<$attribute_name>. This method is useful for
tracking the previous value of a primary key when you need to update a
primary key.
=cut
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;
=head1 SEE ALSO
L<DbFramework::Key>
=head1 AUTHOR
Paul Sharpe E<lt>paul@miraclefish.comE<gt>
=head1 COPYRIGHT
Copyright (c) 1997,1998,1999 Paul Sharpe. England. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut