Initial commit.
This commit is contained in:
241
lib/DbFramework/Attribute.pm
Normal file
241
lib/DbFramework/Attribute.pm
Normal file
@ -0,0 +1,241 @@
|
||||
=head1 NAME
|
||||
|
||||
DbFramework::Attribute - Attribute class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use DbFramework::Attribute;
|
||||
my $a = new DbFramework::Attribute($name,$default_value,$is_optional,$data_type);
|
||||
$name = $a->name($name);
|
||||
$value = $a->default_value($value);
|
||||
$opt = $a->is_optional($boolean);
|
||||
$type = $a->references($data_type);
|
||||
$bgc = $a->bgcolor($bgcolor);
|
||||
$sql = $a->as_sql;
|
||||
$s = $a->as_string;
|
||||
$html = $a->as_html_form_field($value,$type);
|
||||
$html = $a->as_html_heading($bgcolor);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A B<DbFramework::Attribute> object represents an attribute (column) in
|
||||
a table (entity).
|
||||
|
||||
=head1 SUPERCLASSES
|
||||
|
||||
B<DbFramework::Util>
|
||||
|
||||
=cut
|
||||
|
||||
package DbFramework::Attribute;
|
||||
use strict;
|
||||
use base qw(DbFramework::Util);
|
||||
use vars qw($_DEBUG $NAME $DEFAULT_VALUE $IS_OPTIONAL $REFERENCES $BGCOLOR);
|
||||
use Alias;
|
||||
|
||||
## CLASS DATA
|
||||
|
||||
my %fields = (
|
||||
NAME => undef,
|
||||
DEFAULT_VALUE => undef,
|
||||
IS_OPTIONAL => undef,
|
||||
# Attribute 0:N References 0:1 DefinitionObject (DataType)
|
||||
REFERENCES => undef,
|
||||
BGCOLOR => '#007777',
|
||||
);
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## CLASS METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=head2 new($name,$default_value,$is_optional,$data_type)
|
||||
|
||||
Create a new B<DbFramework::Attribute> object. I<$name> is the name
|
||||
of the attribute. I<$default_value> is the default value for the
|
||||
attribute. I<$is_optional> should be set to true if the attribute is
|
||||
optional or false. I<$data_type> is a B<DbFramework::DataType>
|
||||
object.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless { _PERMITTED => \%fields, %fields, }, $class;
|
||||
$self->name(shift);
|
||||
$self->default_value(shift);
|
||||
$self->is_optional(shift);
|
||||
$self->references(shift);
|
||||
return $self;
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## OBJECT METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head2 name($name)
|
||||
|
||||
If I<$name> is supplied sets the attribute name. Returns the
|
||||
attribute name.
|
||||
|
||||
=head2 default_value($value)
|
||||
|
||||
If I<$value> is supplied sets the default value for the attribute.
|
||||
I<$value> should be compatible with the the data type set by
|
||||
references(). Returns the default value for the attribute.
|
||||
|
||||
=head2 is_optional($boolean)
|
||||
|
||||
If I<$boolean> is supplied sets the optionality of the attribute
|
||||
(i.e. whether it can contain NULLs.) I<$boolean> should evaluate to
|
||||
true or false. Returns the optionality of the attribute.
|
||||
|
||||
=head2 references($data_type)
|
||||
|
||||
If I<$data_type> is supplied sets the data type of the attribute.
|
||||
I<$data_type> is an ANSII data type object
|
||||
i.e. B<DbFramework::DataType::ANSII> or a driver-specific object
|
||||
e.g. B<DbFramework::DataType::Mysql>. Returns the data type object.
|
||||
|
||||
=head2 bgcolor($bgcolor)
|
||||
|
||||
If I<$color> is supplied sets the background colour for HTML table
|
||||
headings returned by as_html_heading(). Returns the current
|
||||
background colour.
|
||||
|
||||
=head2 as_sql($dbh)
|
||||
|
||||
Returns a string which can be used to create a column in an SQL
|
||||
'CREATE TABLE' statement. I<$dbh> is a B<DBI> handle.
|
||||
|
||||
=cut
|
||||
|
||||
sub as_sql {
|
||||
my($self,$dbh) = (attr shift,shift);
|
||||
my $sql = "$NAME ";
|
||||
$sql .= $REFERENCES->name;
|
||||
$sql .= '(' . $REFERENCES->length . ')' if $REFERENCES->length;
|
||||
$sql .= " NOT NULL" unless $IS_OPTIONAL;
|
||||
$sql .= " DEFAULT " . $dbh->quote($DEFAULT_VALUE) if $DEFAULT_VALUE;
|
||||
$sql .= ' ' . $REFERENCES->extra if $REFERENCES->extra;
|
||||
return $sql;
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head2 as_html_form_field($value,$type)
|
||||
|
||||
Returns an HTML form field representation of the attribute. The HTML
|
||||
field type produced depends on the name of object returned by
|
||||
data_type(). This can be overidden by setting I<$type>. I<$value> is
|
||||
the default value to be entered in the generated field.
|
||||
|
||||
=cut
|
||||
|
||||
sub as_html_form_field {
|
||||
my $self = attr shift;
|
||||
my $value = defined($_[0]) ? $_[0] : '';
|
||||
my $type = defined($_[1]) ? uc($_[1]) : $REFERENCES->name;
|
||||
my $length = $REFERENCES->length || 10;
|
||||
my $html;
|
||||
|
||||
SWITCH: {
|
||||
$type =~ /(INT|DATE)/ &&
|
||||
do {
|
||||
$html = qq{<INPUT NAME="$NAME" VALUE="$value" SIZE=10 TYPE="text">};
|
||||
last SWITCH;
|
||||
};
|
||||
$type =~ /CHAR$/ &&
|
||||
do {
|
||||
$html = qq{<INPUT NAME="$NAME" VALUE='$value' SIZE=30 TYPE="text" MAXLENGTH=$length>};
|
||||
last SWITCH;
|
||||
};
|
||||
$type eq 'TEXT' &&
|
||||
do {
|
||||
$value =~ s/'//g; # remove quotes
|
||||
$html = qq{<TEXTAREA COLS=60 NAME="$NAME" ROWS=4>$value</TEXTAREA>};
|
||||
last SWITCH;
|
||||
};
|
||||
$type eq 'BOOLEAN' &&
|
||||
do {
|
||||
my $y = qq{Yes <INPUT TYPE="RADIO" NAME="$NAME" VALUE=1};
|
||||
my $n = qq{No <INPUT TYPE="RADIO" NAME="$NAME" VALUE=0};
|
||||
$html = $value ? qq{$y CHECKED>\n$n>\n} : qq{$y>\n$n CHECKED>\n};
|
||||
last SWITCH;
|
||||
};
|
||||
# default
|
||||
my $size = ($length < 30) ? $length : 30;
|
||||
$html = qq{<INPUT MAXLENGTH=$size NAME='$NAME' VALUE='$value' SIZE=$size TYPE="text">};
|
||||
}
|
||||
return $html;
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head2 as_string()
|
||||
|
||||
Return attribute details as a text string.
|
||||
|
||||
=cut
|
||||
|
||||
sub as_string {
|
||||
my $self = attr shift;
|
||||
my $s = "$NAME(" . $REFERENCES->name;
|
||||
$s .= ' ('. $REFERENCES->length . ')' if $REFERENCES->length;
|
||||
$s .= " '$DEFAULT_VALUE'" if $DEFAULT_VALUE;
|
||||
$s .= ' NOT NULL' unless $IS_OPTIONAL;
|
||||
$s .= ' ' . $REFERENCES->extra if $REFERENCES->extra;
|
||||
#print " $FUNCTION" if $FUNCTION;
|
||||
return "$s)\n";
|
||||
}
|
||||
|
||||
##----------------------------------------------------------------------------
|
||||
|
||||
sub _input_template {
|
||||
my($self,$t_name) = (attr shift,shift);
|
||||
return qq{<TD><DbField ${t_name}.$NAME></TD>};
|
||||
}
|
||||
|
||||
##----------------------------------------------------------------------------
|
||||
|
||||
sub _output_template {
|
||||
my($self,$t_name) = (attr shift,shift);
|
||||
return qq{<TD BGCOLOR='$BGCOLOR'><DbValue ${t_name}.$NAME></TD>};
|
||||
}
|
||||
|
||||
#-----------------------------------------------------------------------------
|
||||
|
||||
=head2 as_html_heading($bgcolor)
|
||||
|
||||
Returns a string for use as a column heading cell in an HTML table.
|
||||
I<$bgcolor> is the background colour to use for the heading.
|
||||
|
||||
=cut
|
||||
|
||||
sub as_html_heading {
|
||||
my $self = attr shift;
|
||||
my $bgcolor = shift || $BGCOLOR;
|
||||
my $text = $NAME;
|
||||
$text .= ' ('.$REFERENCES->extra.')' if $REFERENCES->extra;
|
||||
qq{<TD BGCOLOR='$bgcolor'>$text</TD>};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DbFramework::DataType::ANSII> and L<DbFramework::DataType::Mysql>.
|
||||
|
||||
=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
|
||||
326
lib/DbFramework/Catalog.pm
Normal file
326
lib/DbFramework/Catalog.pm
Normal file
@ -0,0 +1,326 @@
|
||||
=head1 NAME
|
||||
|
||||
DbFramework::Catalog - Catalog class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use DbFramework::Catalog;
|
||||
my $c = new DbFramework::Catalog($dsn,$user,$password);
|
||||
$c->set_primary_key($table);
|
||||
$c->set_keys($table);
|
||||
$c->set_foreign_keys($dm);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<DbFramework::Catalog> is a class for manipulating the catalog
|
||||
database used by various DbFramework modules and scripts.
|
||||
|
||||
=head2 The Catalog
|
||||
|
||||
DbFramework retrieves as much metadata as possible using DBI. It aims
|
||||
to store the metadata B<not> provided by DBI in a consistent manner
|
||||
across all DBI drivers by using a catalog database called
|
||||
I<dbframework_catalog>. Each database you use with DbFramework
|
||||
B<requires> corresponding key information added to the catalog. The
|
||||
I<dbframework_catalog> database will be created for each driver you
|
||||
test when you build DbFramework. Entries in the catalog only need to
|
||||
be modified when the corresponding database schema changes.
|
||||
|
||||
The following (Mysql) SQL creates the catalog database schema.
|
||||
|
||||
CREATE TABLE c_db (
|
||||
db_name varchar(50) DEFAULT '' NOT NULL,
|
||||
PRIMARY KEY (db_name)
|
||||
);
|
||||
|
||||
CREATE TABLE c_key (
|
||||
db_name varchar(50) DEFAULT '' NOT NULL,
|
||||
table_name varchar(50) DEFAULT '' NOT NULL,
|
||||
key_name varchar(50) DEFAULT '' NOT NULL,
|
||||
key_type int(11) DEFAULT '0' NOT NULL,
|
||||
key_columns varchar(255) DEFAULT '' NOT NULL,
|
||||
PRIMARY KEY (db_name,table_name,key_name)
|
||||
);
|
||||
|
||||
CREATE TABLE c_relationship (
|
||||
db_name varchar(50) DEFAULT '' NOT NULL,
|
||||
fk_table varchar(50) DEFAULT '' NOT NULL,
|
||||
fk_key varchar(50) DEFAULT '' NOT NULL,
|
||||
pk_table varchar(50) DEFAULT '' NOT NULL,
|
||||
PRIMARY KEY (db_name,fk_table,fk_key,pk_table)
|
||||
);
|
||||
|
||||
CREATE TABLE c_table (
|
||||
table_name varchar(50) DEFAULT '' NOT NULL,
|
||||
db_name varchar(50) DEFAULT '' NOT NULL,
|
||||
labels varchar(127) DEFAULT '',
|
||||
PRIMARY KEY (table_name,db_name)
|
||||
);
|
||||
|
||||
The example below shows the creation of a simple Mysql database and
|
||||
the corresponding catalog entries required by DbFramework.
|
||||
|
||||
CREATE DATABASE foo;
|
||||
use foo;
|
||||
|
||||
CREATE TABLE foo (
|
||||
foo integer not null,
|
||||
bar varchar(50),
|
||||
KEY var(bar),
|
||||
PRIMARY KEY (foo)
|
||||
);
|
||||
|
||||
CREATE TABLE bar (
|
||||
bar integer not null,
|
||||
# foreign key to table foo
|
||||
foo integer not null,
|
||||
PRIMARY KEY (bar)
|
||||
);
|
||||
|
||||
use dbframework_catalog;
|
||||
|
||||
# catalog entry for database 'foo'
|
||||
INSERT INTO c_db VALUES('foo');
|
||||
|
||||
# catalog entries for table 'foo'
|
||||
INSERT INTO c_table VALUES('foo','foo','bar');
|
||||
# primary key type = 0
|
||||
INSERT INTO c_key VALUES('foo','foo','primary',0,'foo');
|
||||
# index type = 2
|
||||
INSERT INTO c_key VALUES('foo','foo','bar_index',2,'bar');
|
||||
|
||||
# catalog entries for table 'bar'
|
||||
INSERT INTO c_table VALUES('bar','foo',NULL);
|
||||
# primary key type = 0
|
||||
INSERT INTO c_key VALUES('foo','bar','primary',0,'bar');
|
||||
# foreign key type = 1
|
||||
INSERT INTO c_key VALUES('foo','bar','foreign_foo',2,'foo');
|
||||
# relationship between 'bar' and 'foo'
|
||||
INSERT INTO c_relationship VALUES('foo','bar','foreign_foo','foo');
|
||||
|
||||
=head1 SUPERCLASSES
|
||||
|
||||
B<DbFramework::Util>
|
||||
|
||||
=cut
|
||||
|
||||
package DbFramework::Catalog;
|
||||
use strict;
|
||||
use base qw(DbFramework::Util);
|
||||
use DbFramework::PrimaryKey;
|
||||
use DbFramework::ForeignKey;
|
||||
use Alias;
|
||||
use Carp;
|
||||
use vars qw($DBH $_DEBUG %keytypes $db);
|
||||
|
||||
## CLASS DATA
|
||||
|
||||
my %fields = (
|
||||
DBH => undef,
|
||||
);
|
||||
|
||||
$db = 'dbframework_catalog';
|
||||
%keytypes = (primary => 0, foreign => 1, index => 2);
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## CLASS METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=head2 new($dsn,$user,$password)
|
||||
|
||||
Create a new B<DbFramework::Catalog> object. I<$dsn> is the DBI data
|
||||
source name containing the catalog database (default is
|
||||
'dbframework_catalog'). I<$user> and I<$password> are optional
|
||||
arguments specifying the username and password to use when connecting
|
||||
to the database.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
|
||||
my $self = bless({},$class);
|
||||
for my $element (keys %fields) {
|
||||
$self->{_PERMITTED}->{$element} = $fields{$element};
|
||||
}
|
||||
@{$self}{keys %fields} = values %fields;
|
||||
$self->dbh(DbFramework::Util::get_dbh(@_));
|
||||
$self->dbh->{PrintError} = 0;
|
||||
return $self;
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## OBJECT METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head1 OBJECT METHODS
|
||||
|
||||
=head2 set_primary_key($table)
|
||||
|
||||
Set the primary key for the B<DbFramework::Table> object I<$table>.
|
||||
The catalog column B<c_table.labels> may contain a colon seperated
|
||||
list of column names to be used as 'labels' (see
|
||||
L<DbFramework::Primary/new()>.)
|
||||
|
||||
=cut
|
||||
|
||||
sub set_primary_key {
|
||||
my $self = attr shift;
|
||||
my $table = shift;
|
||||
my $sth = $self->_get_key_columns($table,'primary');
|
||||
if ( $sth->rows == 0 ) {
|
||||
$sth->finish;
|
||||
carp "Can't get primary key for ",$table->name,"\n"
|
||||
}
|
||||
my($name,$columns) = @{$sth->fetchrow_arrayref};
|
||||
$sth->finish;
|
||||
my @attributes = $table->get_attributes(split /:/,$columns);
|
||||
|
||||
# get label columns
|
||||
my $table_name = $DBH->quote($table->name);
|
||||
my $db_name = $DBH->quote($table->belongs_to->db);
|
||||
my $sql = qq{
|
||||
SELECT labels
|
||||
FROM c_table
|
||||
WHERE db_name = $db_name
|
||||
AND table_name = $table_name
|
||||
};
|
||||
print STDERR "$sql\n" if $_DEBUG;
|
||||
$sth = $DBH->prepare($sql) || die($DBH->errstr);
|
||||
my $rv = $sth->execute || die($sth->errstr);
|
||||
my($labels) = $sth->fetchrow_array;
|
||||
my $labels_ref = undef;
|
||||
@$labels_ref = split /:/,$labels if defined $labels && $labels ne '';
|
||||
$sth->finish;
|
||||
print STDERR "$table_name.pk: $columns\n" if $_DEBUG;
|
||||
my $pk = new DbFramework::PrimaryKey(\@attributes,$table,$labels_ref);
|
||||
$table->is_identified_by($pk);
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head2 set_keys($table)
|
||||
|
||||
Set the keys (indexes) for the B<DbFramework::Table> object I<$table>.
|
||||
|
||||
=cut
|
||||
|
||||
sub set_keys {
|
||||
my $self = attr shift;
|
||||
my $table = shift;
|
||||
my $sth = $self->_get_key_columns($table,'index');
|
||||
my @keys;
|
||||
while ( my $rowref = $sth->fetchrow_arrayref ) {
|
||||
my($name,$columns) = @$rowref;
|
||||
print STDERR "$name $columns\n" if $_DEBUG;
|
||||
my @attributes = $table->get_attributes(split /:/,$columns);
|
||||
my $key = new DbFramework::Key($name,\@attributes);
|
||||
$key->belongs_to($table);
|
||||
push(@keys,$key);
|
||||
}
|
||||
$table->is_accessed_using_l(\@keys);
|
||||
$sth->finish;
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head2 set_foreign_keys($dm)
|
||||
|
||||
Set the foreign keys for the B<DbFramework::DataModel> object I<$dm>.
|
||||
|
||||
=cut
|
||||
|
||||
sub set_foreign_keys {
|
||||
my $self = attr shift;
|
||||
my $dm = shift;
|
||||
my $db_name = $DBH->quote($dm->db);
|
||||
for my $table ( @{$dm->collects_table_l} ) {
|
||||
my $table_name = $DBH->quote($table->name);
|
||||
my $sql;
|
||||
if ( $dm->driver eq 'CSV' ) {
|
||||
$sql = qq{
|
||||
SELECT key_name,key_columns,pk_table
|
||||
FROM c_relationship,c_key WHERE c_relationship.db_name = $db_name
|
||||
AND c_relationship.fk_table = $table_name
|
||||
AND c_relationsihp.db_name = c_key.db_name
|
||||
AND c_relationship.fk_table = c_key.table_name
|
||||
AND c_relationship.fk_key = c_key.key_name
|
||||
};
|
||||
} else {
|
||||
$sql = qq{
|
||||
SELECT k.key_name,k.key_columns,r.pk_table
|
||||
FROM c_relationship r, c_key k
|
||||
WHERE r.db_name = $db_name
|
||||
AND r.fk_table = $table_name
|
||||
AND r.db_name = k.db_name
|
||||
AND r.fk_table = k.table_name
|
||||
AND r.fk_key = k.key_name
|
||||
};
|
||||
}
|
||||
print STDERR "$sql\n" if $_DEBUG;
|
||||
my $sth = DbFramework::Util::do_sql($DBH,$sql);
|
||||
while ( my $rowref = $sth->fetchrow_arrayref ) {
|
||||
my($name,$columns,$pk_table_name) = @$rowref;
|
||||
print STDERR "name = $name, columns = $columns, pk_table = $pk_table_name)\n" if $_DEBUG;
|
||||
my @attributes = $table->get_attributes(split /:/,$columns);
|
||||
my $pk_table = $table->belongs_to->collects_table_h_byname($pk_table_name);
|
||||
|
||||
my $fk = new DbFramework::ForeignKey($name,
|
||||
\@attributes,
|
||||
$pk_table->is_identified_by);
|
||||
$fk->belongs_to($table);
|
||||
$table->has_foreign_keys_l_add($fk); # by number
|
||||
$table->has_foreign_keys_h_add({$fk->name => $fk}); # by name
|
||||
$pk_table->is_identified_by->incorporates($fk); # pk ref
|
||||
}
|
||||
$sth->finish;
|
||||
|
||||
$table->validate_foreign_keys;
|
||||
# default templates need updating after setting foreign keys
|
||||
#$table->_templates;
|
||||
}
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
sub _get_key_columns {
|
||||
my $self = attr shift;
|
||||
my($table,$key_type) = @_;
|
||||
my $table_name = $DBH->quote($table->name);
|
||||
my $db_name = $DBH->quote($table->belongs_to->db);
|
||||
my $sql = qq{
|
||||
SELECT key_name,key_columns
|
||||
FROM c_key
|
||||
WHERE db_name = $db_name
|
||||
AND table_name = $table_name
|
||||
AND key_type = $keytypes{$key_type}
|
||||
};
|
||||
print STDERR "$sql\n" if $_DEBUG;
|
||||
my $sth = $DBH->prepare($sql) || die($DBH->errstr);
|
||||
my $rv = $sth->execute || die($sth->errstr);
|
||||
return $sth;
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
sub DESTROY {
|
||||
my $self = attr shift;
|
||||
$DBH->disconnect;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Sharpe E<lt>paul@miraclefish.comE<gt>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 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
|
||||
195
lib/DbFramework/DataModel.pm
Normal file
195
lib/DbFramework/DataModel.pm
Normal file
@ -0,0 +1,195 @@
|
||||
=head1 NAME
|
||||
|
||||
DbFramework::DataModel - Data Model class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use DbFramework::DataModel;
|
||||
$dm = new DbFramework::DataModel($name,$dsn,$user,$password);
|
||||
$dm->init_db_metadata($catalog_dsn,$user,$password);
|
||||
@tables = @{$dm->collects_table_l};
|
||||
%tables = %{$dm->collects_table_h};
|
||||
@tables = @{$dm->collects_table_h_byname(@tables)};
|
||||
$sql = $dm->as_sql;
|
||||
$db = $dm->db;
|
||||
$driver = $dm->driver;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A B<DbFramework::DataModel> object represents a database schema. It
|
||||
can be initialised using the metadata provided by a DBI driver and a
|
||||
catalog database (see L<DbFramework::Catalog>).
|
||||
|
||||
=head1 SUPERCLASSES
|
||||
|
||||
B<DbFramework::Util>
|
||||
|
||||
=cut
|
||||
|
||||
package DbFramework::DataModel;
|
||||
use strict;
|
||||
use vars qw( $NAME $_DEBUG @COLLECTS_TABLE_L $DBH $DSN );
|
||||
use base qw(DbFramework::Util);
|
||||
use DbFramework::Table;
|
||||
use DbFramework::ForeignKey;
|
||||
use DBI;
|
||||
use Alias;
|
||||
|
||||
## CLASS DATA
|
||||
|
||||
my %fields = (
|
||||
NAME => undef,
|
||||
# DataModel 0:N Collects 0:N DataModelObject
|
||||
COLLECTS_L => undef,
|
||||
# DataModel 0:N Collects 0:N Table
|
||||
COLLECTS_TABLE_L => undef,
|
||||
COLLECTS_TABLE_H => undef,
|
||||
DBH => undef,
|
||||
DSN => undef,
|
||||
DRIVER => undef,
|
||||
DB => undef,
|
||||
TYPE_INFO_L => undef,
|
||||
);
|
||||
|
||||
# arbitrary number to add to SQL type numbers as they can be negative
|
||||
# and we want to store them in an array
|
||||
my $_sql_type_adjust = 1000;
|
||||
|
||||
###############################################################################
|
||||
# CLASS METHODS
|
||||
###############################################################################
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=head2 new($name,$dsn,$user,$password)
|
||||
|
||||
Create a new B<DbFramework::DataModel> object. I<$name> is the name of
|
||||
the database associated with the data model. I<$dsn> is the DBI data
|
||||
source name associated with the data model. I<$user> and I<$password>
|
||||
are optional arguments specifying the username and password to use
|
||||
when connecting to the database.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless { _PERMITTED => \%fields, %fields, }, $class;
|
||||
$self->name(shift);
|
||||
$self->dbh(DbFramework::Util::get_dbh(@_));
|
||||
#$self->init_db_metadata;
|
||||
# hack to record driver/db name until I confirm whether $dbh->{Name}
|
||||
# has been implemented for mSQL and Mysql
|
||||
$self->dsn($_[0]);
|
||||
$self->driver($_[0] =~ /DBI:(.*):/);
|
||||
$self->db($self->name);
|
||||
# cache type_info here as it's an expensive function for ODBC
|
||||
$self->type_info_l([$self->dbh->type_info($DBI::SQL_ALL_TYPES)]);
|
||||
return $self;
|
||||
}
|
||||
|
||||
###############################################################################
|
||||
# OBJECT METHODS
|
||||
###############################################################################
|
||||
|
||||
=head1 OBJECT METHODS
|
||||
|
||||
A data model has a number of tables. These tables can be accessed
|
||||
using the methods I<COLLECTS_TABLE_L> and I<COLLECTS_TABLE_H>. See
|
||||
L<DbFramework::Util/AUTOLOAD()> for the accessor methods for these
|
||||
attributes.
|
||||
|
||||
=head2 name($name)
|
||||
|
||||
If I<$name> is supplied sets the name of the database associated with
|
||||
the data model. Returns the database name.
|
||||
|
||||
=head2 dsn()
|
||||
|
||||
Returns the DBI DSN of the database associated with the data model.
|
||||
|
||||
=head2 db()
|
||||
|
||||
Synonym for name().
|
||||
|
||||
=head2 driver()
|
||||
|
||||
Returns the name of the driver associated with the data model.
|
||||
|
||||
=head2 as_sql()
|
||||
|
||||
Returns a SQL string which can be used to create the tables which make
|
||||
up the data model.
|
||||
|
||||
=cut
|
||||
|
||||
sub as_sql {
|
||||
my $self = attr shift;
|
||||
my $sql;
|
||||
for ( @COLLECTS_TABLE_L ) { $sql .= $_->as_sql($DBH) . ";\n" }
|
||||
return $sql;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 init_db_metadata($catalog_dsn,$user,$password)
|
||||
|
||||
Returns a B<DbFramework::DataModel> object configured using metadata
|
||||
from the database handle returned by dbh() and the catalog (see
|
||||
L<DbFramework::Catalog>). I<$catalog_dsn> is the DBI data source name
|
||||
associated with the catalog. I<$user> and I<$password> are used for
|
||||
authorisation against the catalog database. Foreign keys will be
|
||||
automatically configured for tables in the data model but this method
|
||||
will die() unless the number of attributes in each foreign and related
|
||||
primary key match.
|
||||
|
||||
=cut
|
||||
|
||||
sub init_db_metadata {
|
||||
my $self = attr shift;
|
||||
my $c = new DbFramework::Catalog(@_);
|
||||
|
||||
# add tables
|
||||
my($table,@tables,@byname);
|
||||
my $sth = $DBH->table_info;
|
||||
while ( my @table_info = $sth->fetchrow_array ) {
|
||||
my $table_name = $table_info[2];
|
||||
print STDERR "table: $table_name, table_info = @table_info\n" if $_DEBUG;
|
||||
my $table = DbFramework::Table->new($table_name,undef,undef,$DBH,$self);
|
||||
push(@tables,$table->init_db_metadata($c));
|
||||
print STDERR "table: ",$table->name," pk: ",join(',',$table->is_identified_by->attribute_names),"\n" if $_DEBUG;
|
||||
}
|
||||
$self->collects_table_l(\@tables);
|
||||
for ( @tables ) { push(@byname,($_->name,$_)) }
|
||||
$self->collects_table_h(\@byname);
|
||||
|
||||
# add foreign keys
|
||||
$c->set_foreign_keys($self);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DbFramework::Catalog>, L<DbFramework::Table> and
|
||||
L<DbFramework::Util>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Sharpe E<lt>paul@miraclefish.comE<gt>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 1997,1998 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.
|
||||
|
||||
=head1 ACKNOWLEDGEMENTS
|
||||
|
||||
This module was inspired by B<Msql::RDBMS>.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
56
lib/DbFramework/DataModelObject.pm
Normal file
56
lib/DbFramework/DataModelObject.pm
Normal file
@ -0,0 +1,56 @@
|
||||
=head1 NAME
|
||||
|
||||
DbFramework::DataModelObject - DataModelObject class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use DbFramework::DataModelObject;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Abstract class for CDIF Data Model objects.
|
||||
|
||||
=head1 SUPERCLASSES
|
||||
|
||||
B<DbFramework::Util>
|
||||
|
||||
=cut
|
||||
|
||||
package DbFramework::DataModelObject;
|
||||
use strict;
|
||||
use vars qw( $NAME );
|
||||
use base qw(DbFramework::Util);
|
||||
use Alias;
|
||||
|
||||
## CLASS DATA
|
||||
|
||||
my %fields = (
|
||||
# DataModelObject 1:1 ActsAs 0:N RolePlayer
|
||||
ACTS_AS => undef,
|
||||
);
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## CLASS METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless { _PERMITTED => \%fields, %fields, }, $class;
|
||||
$self->name(shift);
|
||||
return $self;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Sharpe E<lt>paul@miraclefish.comE<gt>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 1998 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
|
||||
142
lib/DbFramework/DataType/ANSII.pm
Normal file
142
lib/DbFramework/DataType/ANSII.pm
Normal file
@ -0,0 +1,142 @@
|
||||
=head1 NAME
|
||||
|
||||
DbFramework::DataType::ANSII - ANSII data type class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use DbFramework::DataType::ANSII;
|
||||
$dt = new DbFramework::DataType::ANSII($dm,$type,$ansii_type,$length);
|
||||
$name = $dt->name($name);
|
||||
$type = $type($type);
|
||||
$length = $dt->length($length);
|
||||
$extra = $dt->extra($extra);
|
||||
$ansii = $dt->ansii_type;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A B<DbFramework::DataType::ANSII> object represents an ANSII data type.
|
||||
|
||||
=head1 SUPERCLASSES
|
||||
|
||||
B<DbFramework::DefinitionObject>
|
||||
|
||||
=cut
|
||||
|
||||
package DbFramework::DataType::ANSII;
|
||||
use strict;
|
||||
use base qw(DbFramework::DefinitionObject);
|
||||
use Alias;
|
||||
use vars qw();
|
||||
|
||||
## CLASS DATA
|
||||
|
||||
my %fields = (
|
||||
LENGTH => undef,
|
||||
EXTRA => undef,
|
||||
TYPES_L => undef,
|
||||
TYPE => undef,
|
||||
ANSII_TYPE => undef,
|
||||
);
|
||||
|
||||
# arbitrary number to add to SQL type numbers as they can be negative
|
||||
# and we want to store them in an array
|
||||
my $_sql_type_adjust = 1000;
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## CLASS METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=head2 new($dm,$type,$ansii_type,$length)
|
||||
|
||||
Create a new B<DbFramework::DataType> object. I<$dm> is a
|
||||
B<DbFramework::DataModle> object. I<$type> is a numeric ANSII type
|
||||
e.g. a type contained in the array reference returned by $sth->{TYPE}.
|
||||
This method will die() unless I<$type> is a member of the set of ANSII
|
||||
types supported by the DBI driver. I<$ansii_type> is the same as
|
||||
I<$type>. I<$length> is the length of the data type.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $_debug = 0;
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $dm = shift;
|
||||
my $realtype = shift;
|
||||
shift; # ansii_type is the same as type
|
||||
my $type = $realtype + $_sql_type_adjust;
|
||||
|
||||
my(@types,@type_names);
|
||||
print "type_info_l = ",@{$dm->type_info_l},"\n" if $_debug;
|
||||
for my $t ( @{$dm->type_info_l} ) {
|
||||
# first DATA_TYPE returned should be the ANSII type
|
||||
unless ( $types[$t->{DATA_TYPE} + $_sql_type_adjust] ) {
|
||||
$types[$t->{DATA_TYPE} + $_sql_type_adjust] = $t;
|
||||
$type_names[$t->{DATA_TYPE} + $_sql_type_adjust] = uc($t->{TYPE_NAME});
|
||||
print $type_names[$t->{DATA_TYPE} + $_sql_type_adjust],"\n" if $_debug;
|
||||
}
|
||||
}
|
||||
print STDERR "type = $type ($type_names[$type])\n" if $_debug;
|
||||
$types[$type] || die "Invalid ANSII data type: $type";
|
||||
|
||||
my $self = bless($class->SUPER::new($type_names[$type]),$class);
|
||||
for my $element (keys %fields) {
|
||||
$self->{_PERMITTED}->{$element} = $fields{$element};
|
||||
}
|
||||
@{$self}{keys %fields} = values %fields;
|
||||
|
||||
$self->ansii_type($self->type($realtype));
|
||||
$self->types_l(\@types);
|
||||
$self->length(shift);
|
||||
$self->extra('IDENTITY(0,1)') if $self->types_l->[$type]->{AUTO_INCREMENT};
|
||||
return $self;
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## OBJECT METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head2 name($name)
|
||||
|
||||
If I<$name> is supplied, sets the name of the ANSII data type.
|
||||
Returns the name of the data type.
|
||||
|
||||
=head2 type($type)
|
||||
|
||||
If I<$type> is supplied, sets the number of the ANSII data type.
|
||||
Returns the numeric data type.
|
||||
|
||||
=head2 ansii_type($ansii_type)
|
||||
|
||||
Returns the same type as type().
|
||||
|
||||
=head2 length($length)
|
||||
|
||||
If I<$length> is supplied, sets the length of the data type. Returns
|
||||
the length of the data type.
|
||||
|
||||
=head2 extra($extra)
|
||||
|
||||
If I<$extra> is supplied, sets any extra information which applies to
|
||||
the data type e.g. I<AUTO_INCREMENT>. Returns the extra information
|
||||
which applies to the data type.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DbFramework::DefinitionObject>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Sharpe E<lt>paul@miraclefish.comE<gt>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 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
|
||||
|
||||
1;
|
||||
140
lib/DbFramework/DataType/Mysql.pm
Normal file
140
lib/DbFramework/DataType/Mysql.pm
Normal file
@ -0,0 +1,140 @@
|
||||
=head1 NAME
|
||||
|
||||
DbFramework::DataType::Mysql - Mysql data type class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use DbFramework::DataType::Mysql;
|
||||
$dt = new DbFramework::DataType::ANSII($dm,$type,$ansii_type,$length);
|
||||
$name = $dt->name($name);
|
||||
$type = $dt->type($type);
|
||||
$length = $dt->length($length);
|
||||
$extra = $dt->extra($extra);
|
||||
$ansii = $dt->ansii_type;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A B<DbFramework::DataType::Mysql> object represents a Mysql data type.
|
||||
|
||||
=head1 SUPERCLASSES
|
||||
|
||||
B<DbFramework::DefinitionObject>
|
||||
|
||||
=cut
|
||||
|
||||
package DbFramework::DataType::Mysql;
|
||||
use strict;
|
||||
use base qw(DbFramework::DefinitionObject);
|
||||
use Alias;
|
||||
use vars qw();
|
||||
|
||||
## CLASS DATA
|
||||
|
||||
my %fields = (
|
||||
LENGTH => undef,
|
||||
EXTRA => undef,
|
||||
TYPES_L => undef,
|
||||
TYPE => undef,
|
||||
ANSII_TYPE => undef,
|
||||
);
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## CLASS METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=head2 new($dm,$type,$ansii_type,$length,$extra)
|
||||
|
||||
Create a new B<DbFramework::DataType> object. I<$dm> is a
|
||||
B<DbFramework::DataModle> object. I<$type> is a numeric Mysql type
|
||||
e.g. a type containd in the array reference returned by
|
||||
$sth->{mysql_type}. This method will die() unless I<$type> is a
|
||||
member of the set of types supported by B<DBD::mysql>. I<$ansii_type>
|
||||
is the ANSII type that most closely resembles the native Mysql type.
|
||||
I<$length> is the length of the data type. I<$extra> is any extra
|
||||
stuff which applies to the type e.g. 'AUTO_INCREMENT'.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $_debug = 0;
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
my($dm,$type,$ansii_type) = (shift,shift,shift);
|
||||
|
||||
my(@types,@type_names);
|
||||
for my $t ( @{$dm->type_info_l} ) {
|
||||
$types[$t->{mysql_native_type}] = $t;
|
||||
$type_names[$t->{mysql_native_type}] = uc($t->{TYPE_NAME});
|
||||
print STDERR "$t->{mysql_native_type}, $type_names[$t->{mysql_native_type}]\n" if $_debug
|
||||
}
|
||||
$types[$type] || die "Invalid Mysql data type: $type\n";
|
||||
print STDERR "\ntype = $type ($type_names[$type])\n\n" if $_debug;
|
||||
|
||||
my $self = bless($class->SUPER::new($type_names[$type]),$class);
|
||||
for my $element (keys %fields) {
|
||||
$self->{_PERMITTED}->{$element} = $fields{$element};
|
||||
}
|
||||
@{$self}{keys %fields} = values %fields;
|
||||
|
||||
$self->type($type);
|
||||
$self->ansii_type($ansii_type);
|
||||
$self->types_l(\@types);
|
||||
$self->length(shift);
|
||||
$self->extra(shift);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## OBJECT METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head2 name($name)
|
||||
|
||||
If I<$name> is supplied sets the name of the Mysql data type. Returns
|
||||
the name of the data type.
|
||||
|
||||
=head2 type($type)
|
||||
|
||||
If I<$type> is supplied sets the number of the Mysql data type.
|
||||
Returns the numeric data type.
|
||||
|
||||
=head2 ansii_type($ansii_type)
|
||||
|
||||
If I<$ansii_type> is supplied sets the number of the ANSII type which
|
||||
most closely corresponds to the Mysql native type. Returns the ANSII
|
||||
type which most closely corresponds to the Mysql native type.
|
||||
|
||||
=head2 length($length)
|
||||
|
||||
If I<$length> is supplied sets the length of the data type. Returns
|
||||
the length of the data type.
|
||||
|
||||
=head2 extra($extra)
|
||||
|
||||
If I<$extra> is supplied sets any extra information which applies to
|
||||
the data type e.g. I<AUTO_INCREMENT> in they case of a Mysql
|
||||
I<INTEGER> data type. Returns the extra information which applies to
|
||||
the data type.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DbFramework::DefinitionObject>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Sharpe E<lt>paul@miraclefish.comE<gt>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 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
|
||||
89
lib/DbFramework/DefinitionObject.pm
Normal file
89
lib/DbFramework/DefinitionObject.pm
Normal file
@ -0,0 +1,89 @@
|
||||
=head1 NAME
|
||||
|
||||
DbFramework::DefinitionObject - DefinitionObject class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use DbFramework::DefinitionObject;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Abstract class for CDIF Definition Object objects.
|
||||
|
||||
=head1 SUPERCLASSES
|
||||
|
||||
B<DbFramework::Util>
|
||||
|
||||
=cut
|
||||
|
||||
package DbFramework::DefinitionObject;
|
||||
use strict;
|
||||
use vars qw( $NAME $_DEBUG);
|
||||
use base qw(DbFramework::Util);
|
||||
use Alias;
|
||||
use Carp;
|
||||
|
||||
## CLASS DATA
|
||||
|
||||
my %fields = (
|
||||
NAME => undef,
|
||||
# DefinitionObject 0:1 Contains 0:N Attribute
|
||||
CONTAINS_L => undef,
|
||||
CONTAINS_H => undef,
|
||||
);
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## CLASS METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless { _PERMITTED => \%fields, %fields, }, $class;
|
||||
$self->name(shift);
|
||||
$self->_init(shift);
|
||||
return $self;
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## OBJECT METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head1 OBJECT METHODS
|
||||
|
||||
A definition object contains 0 or more B<DbFramework::Attribute>
|
||||
objects. These objects can be accessed using the attributes
|
||||
I<CONTAINS_L> and I<CONTAINS_H>. See L<DbFramework::Util/AUTOLOAD()>
|
||||
for the accessor methods for these attributes.
|
||||
|
||||
=cut
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub _init {
|
||||
my $self = attr shift;
|
||||
my @by_name;
|
||||
for ( @{$self->contains_l(shift)} ) { push(@by_name,($_->name,$_)) }
|
||||
$self->contains_h(\@by_name);
|
||||
return $self;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
1;
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DbFramework::Util>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Sharpe E<lt>paul@miraclefish.comE<gt>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 1998 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
|
||||
171
lib/DbFramework/ForeignKey.pm
Normal file
171
lib/DbFramework/ForeignKey.pm
Normal file
@ -0,0 +1,171 @@
|
||||
=head1 NAME
|
||||
|
||||
DbFramework::ForeignKey - Foreign Key class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use DbFramework::ForeignKey;
|
||||
$fk = new DbFramework::ForeignKey($name,\@attributes,$primary);
|
||||
$pk = $fk->references($primary);
|
||||
$sql = $fk->as_sql;
|
||||
$html = $fk->as_html_form_field(\%values);
|
||||
$s = $fk->sql_where;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The B<DbFramework::ForeignKey> class implements foreign keys for a
|
||||
table.
|
||||
|
||||
=head1 SUPERCLASSES
|
||||
|
||||
B<DbFramework::Key>
|
||||
|
||||
=cut
|
||||
|
||||
package DbFramework::ForeignKey;
|
||||
use strict;
|
||||
use base qw(DbFramework::Key);
|
||||
use Alias;
|
||||
use vars qw( $NAME $BELONGS_TO @INCORPORATES_L $BGCOLOR $_DEBUG );
|
||||
|
||||
# CLASS DATA
|
||||
|
||||
my %fields = (
|
||||
# ForeignKey 0:N References 1:1 PrimaryKey
|
||||
REFERENCES => undef,
|
||||
);
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## CLASS METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=head2 new($name,\@attributes,$primary)
|
||||
|
||||
Returns a new B<DbFramework::ForeignKey> object.
|
||||
|
||||
I<$name> is the name of the foreign key. I<@attributes> is a list of
|
||||
B<DbFramework::Attribute> objects from a single B<DbFramework::Table>
|
||||
object which make up the key. I<$primary> is the
|
||||
B<DbFramework::Primary> object which the foreign key references.
|
||||
|
||||
=cut
|
||||
|
||||
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->references(shift);
|
||||
$self->bgcolor('#777777');
|
||||
return $self;
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## OBJECT METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head1 OBJECT METHODS
|
||||
|
||||
=head2 references($primary)
|
||||
|
||||
I<$primary> should be a B<DbFramework::PrimaryKey> object. If
|
||||
supplied it sets the primary key referenced by this foreign key.
|
||||
Returns the B<DbFramework::PrimaryKey> object referenced by this
|
||||
foreign key.
|
||||
|
||||
=cut
|
||||
|
||||
#-----------------------------------------------------------------------------
|
||||
|
||||
sub _input_template {
|
||||
my $self = attr shift;
|
||||
my $t_name = $BELONGS_TO ? $BELONGS_TO->name : 'UNKNOWN_TABLE';
|
||||
return qq{<TD><DbFKey ${t_name}.$NAME></TD>};
|
||||
}
|
||||
|
||||
#-----------------------------------------------------------------------------
|
||||
|
||||
sub _output_template {
|
||||
my $self = attr shift;
|
||||
# output template consists of attributes from related pk table
|
||||
my $pk_table = $self->references->belongs_to;
|
||||
my $name = $pk_table->name;
|
||||
my $attributes = join(',',$pk_table->attribute_names);
|
||||
my $out = qq{<TD BGCOLOR='$BGCOLOR'><DbValue ${name}.$attributes></TD>};
|
||||
print STDERR "\$out = $out\n" if $_DEBUG;
|
||||
$out;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 as_html_form_field(\%values)
|
||||
|
||||
Returns an HTML selection box containing values and labels from the
|
||||
primary key columns in the related table. I<%values> is a hash whose
|
||||
keys are the attribute names of the foreign key and whose values
|
||||
indicate the item in the selection box which should be selected by
|
||||
default. See L<DbFramework::PrimaryKey/html_select_field()>.
|
||||
|
||||
=cut
|
||||
|
||||
sub as_html_form_field {
|
||||
my $self = attr shift;
|
||||
my %values = $_[0] ? %{$_[0]} : ();
|
||||
my $pk = $self->references;
|
||||
my $name = join(',',$self->attribute_names);
|
||||
# only handles single attribute foreign keys
|
||||
my $t_name = $BELONGS_TO->name;
|
||||
my @fk_value;
|
||||
$fk_value[0] = $values{"${t_name}.${name}"};
|
||||
if ( $_DEBUG ) {
|
||||
print STDERR "\$t_name = $t_name, \$name = $name, \@fk_value = @fk_value\n";
|
||||
print STDERR "pk table = ",$pk->belongs_to->name,"\n";
|
||||
}
|
||||
$pk->html_select_field(undef,undef,\@fk_value,$name);
|
||||
}
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 sql_where()
|
||||
|
||||
Returns a string containing SQL 'WHERE' condition(s) to join the
|
||||
foreign key against the primary key of the related table.
|
||||
|
||||
=cut
|
||||
|
||||
sub sql_where {
|
||||
my $self = shift;
|
||||
my $fk_table = $self->belongs_to->name;
|
||||
my @fk_columns = $self->attribute_names;
|
||||
my $pk_table = $self->references->belongs_to->name;
|
||||
my @pk_columns = $self->references->attribute_names;
|
||||
my $where;
|
||||
for ( my $i = 0; $i <= $#fk_columns; $i++ ) {
|
||||
$where .= ' AND ' if $where;
|
||||
$where .= "$fk_table.$fk_columns[$i] = $pk_table.$pk_columns[$i]";
|
||||
}
|
||||
$where;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DbFramework::Key>, L<DbFramework::PrimaryKey> and
|
||||
L<DbFramework::Catalog>.
|
||||
|
||||
=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
|
||||
181
lib/DbFramework/Key.pm
Normal file
181
lib/DbFramework/Key.pm
Normal file
@ -0,0 +1,181 @@
|
||||
=head1 NAME
|
||||
|
||||
DbFramework::Key - Key class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use DbFramework::Key;
|
||||
$k = new DbFramework::Key($name,\@attributes);
|
||||
$name = $k->name($name);
|
||||
@a = @{$k->incorporates_l(\@attributes)};
|
||||
@names = $k->attribute_names;
|
||||
$sql = $k->as_sql;
|
||||
$table = $k->belongs_to($table);
|
||||
$html = $k->as_html_heading;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The B<DbFramework::Key> class implements keys (indexes) for a table.
|
||||
|
||||
=head1 SUPERCLASSES
|
||||
|
||||
B<DbFramework::Util>
|
||||
|
||||
=cut
|
||||
|
||||
package DbFramework::Key;
|
||||
use strict;
|
||||
use base qw(DbFramework::Util);
|
||||
use Alias;
|
||||
use vars qw( $NAME @INCORPORATES_L $BELONGS_TO $BGCOLOR );
|
||||
|
||||
my %fields = (
|
||||
NAME => undef,
|
||||
# Key 0:N Incorporates 0:N Attribute
|
||||
INCORPORATES_L => undef,
|
||||
# Key 1:1 BelongsTo 1:1 Table
|
||||
BELONGS_TO => undef,
|
||||
BGCOLOR => '#ffffff',
|
||||
);
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## CLASS METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=head2 new($name,\@attributes)
|
||||
|
||||
Create a new B<DbFramework::Key> object. I<$name> is the name of the
|
||||
key. I<@attributes> is a list of B<DbFramework::Attribute> objects
|
||||
from a single B<DbFramework::Table> object which make up the key.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $DEBUG = 0;
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
print STDERR "=>$class::new(@_)\n" if $DEBUG;
|
||||
my $self = bless { _PERMITTED => \%fields, %fields, }, $class;
|
||||
$self->name(shift);
|
||||
$self->incorporates_l(shift);
|
||||
print STDERR "<=$class::new()\n" if $DEBUG;
|
||||
return $self;
|
||||
}
|
||||
|
||||
##----------------------------------------------------------------------------
|
||||
## OBJECT METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head1 OBJECT METHODS
|
||||
|
||||
A key incorporates 0 or more attributes. These attributes can be
|
||||
accessed using the attribute I<INCORPORATES_L>. See
|
||||
L<DbFramework::Util/AUTOLOAD()> for the accessor methods for this
|
||||
attribute.
|
||||
|
||||
=head2 name($name)
|
||||
|
||||
If I<$name> is supplied sets the data model name. Returns the data
|
||||
model name.
|
||||
|
||||
=head2 belongs_to($table)
|
||||
|
||||
I<$table> is a B<DbFramework::Table> object. If supplied sets the
|
||||
table to which this key refers to I<$table>. Returns a
|
||||
B<DbFramework::Table>.
|
||||
|
||||
=head2 bgcolor($bgcolor)
|
||||
|
||||
If I<$color> is supplied sets the background colour for HTML table
|
||||
cells. Returns the current background colour.
|
||||
|
||||
=head2 attribute_names()
|
||||
|
||||
Returns a list of the names of the attributes which make up the key.
|
||||
|
||||
=cut
|
||||
|
||||
sub attribute_names {
|
||||
my $self = attr shift;
|
||||
my @names;
|
||||
for ( @INCORPORATES_L ) { push(@names,$_->name) }
|
||||
return @names;
|
||||
}
|
||||
|
||||
#-----------------------------------------------------------------------------
|
||||
|
||||
=head2 as_sql()
|
||||
|
||||
Returns a string which can be used in an SQL 'CREATE TABLE' statement
|
||||
to create the key.
|
||||
|
||||
=cut
|
||||
|
||||
sub as_sql {
|
||||
my $self = attr shift;
|
||||
return "KEY $NAME (" . join(',',$self->attribute_names) . ")";
|
||||
}
|
||||
|
||||
#-----------------------------------------------------------------------------
|
||||
|
||||
sub _input_template {
|
||||
my $self = attr shift;
|
||||
my $t_name = $BELONGS_TO ? $BELONGS_TO->name : 'UNKNOWN_TABLE';
|
||||
my $in;
|
||||
my $bgcolor = $self->bgcolor;
|
||||
for ( @INCORPORATES_L ) {
|
||||
my $a_name = $_->name;
|
||||
$in .= qq{<TD><DbField ${t_name}.${a_name}></TD>};
|
||||
}
|
||||
$in;
|
||||
}
|
||||
|
||||
#-----------------------------------------------------------------------------
|
||||
|
||||
sub _output_template {
|
||||
my $self = attr shift;
|
||||
my $t_name = $BELONGS_TO ? $BELONGS_TO->name : 'UNKNOWN_TABLE';
|
||||
my $out;
|
||||
for ( @INCORPORATES_L ) {
|
||||
my $a_name = $_->name;
|
||||
$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 $html = "<TD BGCOLOR='$BGCOLOR' COLSPAN=".scalar(@INCORPORATES_L).">";
|
||||
for ( @INCORPORATES_L ) { $html .= $_->name . ',' }
|
||||
chop($html);
|
||||
"$html</TD>";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DbFramework::ForeignKey>, L<DbFramework::PrimaryKey> and
|
||||
L<DbFramework::Catalog>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Sharpe E<lt>paul@miraclefish.comE<gt>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 1997,1998 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
|
||||
349
lib/DbFramework/Persistent.pm
Normal file
349
lib/DbFramework/Persistent.pm
Normal file
@ -0,0 +1,349 @@
|
||||
=head1 NAME
|
||||
|
||||
DbFramework::Persistent - Persistent Perl object base class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Foo;
|
||||
use base qw(DbFramework::Persistent);
|
||||
|
||||
package main;
|
||||
$foo = new Foo($table,$dbh,$catalog);
|
||||
$foo->attributes_h(\%foo};
|
||||
$foo->insert;
|
||||
$foo->attributes_h(\%new_foo);
|
||||
$foo->update(\%attributes);
|
||||
$foo->delete;
|
||||
$foo->init_pk;
|
||||
@foo = $foo->select($condition,$order);
|
||||
$hashref = $foo->table_qualified_attribute_hashref;
|
||||
$code = DbFramework::Persistent::make_class($name);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Base class for persistent objects which use a DBI database for
|
||||
storage. To create your own persistent object classes subclass
|
||||
B<DbFramework::Persistent> (see the make_class() class method.)
|
||||
|
||||
=head1 SUPERCLASSES
|
||||
|
||||
B<DbFramework::Util>
|
||||
|
||||
=cut
|
||||
|
||||
package DbFramework::Persistent;
|
||||
use strict;
|
||||
use vars qw( $TABLE $_DEBUG $VERSION %ATTRIBUTES_H $CATALOG );
|
||||
$VERSION = '1.10';
|
||||
use base qw(DbFramework::Util);
|
||||
use Alias;
|
||||
use DbFramework::Table;
|
||||
|
||||
## CLASS DATA
|
||||
|
||||
my $Debugging = 0;
|
||||
|
||||
my %fields = (
|
||||
TABLE => undef,
|
||||
ATTRIBUTES_H => undef,
|
||||
CATALOG => undef,
|
||||
);
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## CLASS METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=head2 new($table,$dbh,$catalog)
|
||||
|
||||
Create a new persistent object. I<$table> is a B<DbFramework::Table>
|
||||
object or the name of a database table. I<$dbh> is a B<DBI> database
|
||||
handle which refers to a database containing a table associated with
|
||||
I<$table>. I<$catalog> is a B<DbFramework::Catalog> object.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
my($table,$dbh,$catalog) = @_;
|
||||
my $self = bless { _PERMITTED => \%fields, %fields, }, $class;
|
||||
$table = new DbFramework::Table($table,undef,undef,$dbh)
|
||||
unless (ref($table) eq 'DbFramework::Table');
|
||||
$self->table($table->init_db_metadata($catalog));
|
||||
$self->catalog($catalog);
|
||||
return $self;
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head2 make_class($name)
|
||||
|
||||
Returns some Perl code which can be used with eval() to create a new
|
||||
persistent object (sub)class called I<$name>.
|
||||
|
||||
=cut
|
||||
|
||||
sub make_class {
|
||||
my($proto,$name) = @_;
|
||||
my $class = ref($proto) || $proto;
|
||||
|
||||
my $code = qq{package $name;
|
||||
use strict;
|
||||
use base qw(DbFramework::Persistent);
|
||||
};
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## OBJECT METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head1 OBJECT METHODS
|
||||
|
||||
Attributes in a persistent object which relate to columns in the
|
||||
associated table are made available through the attribute
|
||||
I<ATTRIBUTES_H>. See L<DbFramework::Util/AUTOLOAD()> for the accessor
|
||||
methods for this attribute.
|
||||
|
||||
=head2 delete()
|
||||
|
||||
Delete this object from the associated table based on the values of
|
||||
it's primary key attributes. Returns the number of rows deleted if
|
||||
supplied by the DBI driver.
|
||||
|
||||
=cut
|
||||
|
||||
sub delete {
|
||||
my $self = attr shift;
|
||||
return $TABLE->delete($self->_pk_conditions);
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 insert()
|
||||
|
||||
Insert this object in the associated table. Returns the primary key
|
||||
of the inserted row if it is a Mysql 'AUTO_INCREMENT' column or -1.
|
||||
|
||||
=cut
|
||||
|
||||
sub insert {
|
||||
my $self = attr shift;
|
||||
return $TABLE->insert($self->attributes_h);
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 update(\%attributes)
|
||||
|
||||
Update this object in the associated table. I<%attributes> is a hash
|
||||
whose keys contain primary key column names and whose values will be
|
||||
concatenated with 'ANDs' to form a SQL 'WHERE' clause. The default
|
||||
values of I<%attributes> is the hash returned by attributes_h(). Pass
|
||||
the B<current> primary key attributes as an argument in I<%attributes>
|
||||
when you need to update one or more primary key columns. Returns the
|
||||
number of rows updated if supplied by the DBI driver.
|
||||
|
||||
=cut
|
||||
|
||||
sub update {
|
||||
my $self = attr shift;
|
||||
my %attributes = defined($_[0]) ? %{$_[0]} : %{$self->attributes_h};
|
||||
# get pk attributes
|
||||
my %pk_attributes;
|
||||
for ( $TABLE->is_identified_by->attribute_names ) {
|
||||
$pk_attributes{$_} = $attributes{$_};
|
||||
}
|
||||
return $TABLE->update($self->attributes_h,$self->where_and(\%pk_attributes));
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 select($conditions,$order)
|
||||
|
||||
Returns a list of objects of the same class as the object which
|
||||
invokes it. Each object in the list has its attributes initialised
|
||||
from the values returned by selecting all columns from the associated
|
||||
table matching I<$conditions> ordered by the list of columns in
|
||||
I<$order>.
|
||||
|
||||
=cut
|
||||
|
||||
sub select {
|
||||
my $self = attr shift;
|
||||
|
||||
my @things;
|
||||
my @columns = $TABLE->attribute_names;
|
||||
for ( $TABLE->select(\@columns,shift,shift) ) {
|
||||
print STDERR "\@{\$_} = @{$_}\n" if $_DEBUG;
|
||||
# pass Table *object* to new to retain any fk relationships
|
||||
my $thing = $self->new($TABLE,$TABLE->dbh,$CATALOG);
|
||||
my %attributes;
|
||||
for ( my $i = 0; $i <= $#columns; $i++ ) {
|
||||
print STDERR "assigning $columns[$i] = $_->[$i]\n" if $_DEBUG;
|
||||
$attributes{$columns[$i]} = $_->[$i];
|
||||
}
|
||||
$thing->attributes_h([%attributes]);
|
||||
push(@things,$thing);
|
||||
}
|
||||
return @things;
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
#=head2 validate_required()
|
||||
|
||||
#Returns a list of attribute names which must B<not> be NULL but are
|
||||
#undefined. If I<@attributes> is undefined, validates all attributes.
|
||||
|
||||
#=cut
|
||||
|
||||
#sub validate_required {
|
||||
# my $self = attr shift; my $table = $self->table;
|
||||
# my($attribute,@invalid);
|
||||
|
||||
# my @attributes = @_ ? @_ : sort keys(%STATE);
|
||||
# foreach $attribute ( @attributes ) {
|
||||
# my $column = $table->get_column($attribute);
|
||||
# if ( ! $column->null && ! defined($self->get_attribute($attribute)) ) {
|
||||
# my $heading = $column->heading;
|
||||
# if ( $heading ) {
|
||||
# push(@invalid,$heading)
|
||||
# } else {
|
||||
# push(@invalid,$attribute);
|
||||
# }
|
||||
# }
|
||||
# }
|
||||
# return @invalid;
|
||||
#}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
# return a SQL 'WHERE' clause condition consisting of primary key
|
||||
# attributes and their corresponding values joined by 'AND'
|
||||
|
||||
sub _pk_conditions {
|
||||
my $self = attr shift;
|
||||
my @attributes = @{$TABLE->is_identified_by->incorporates_l};
|
||||
my %values = %{$self->attributes_h};
|
||||
my %pk_attributes;
|
||||
for ( @attributes ) {
|
||||
my $column = $_->name;
|
||||
$pk_attributes{$column} = $values{$column};
|
||||
}
|
||||
return $self->where_and(\%pk_attributes);
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
# return a SQL 'WHERE' clause condition consisting of attributes named
|
||||
# after keys in %attributes and their corresponding values joined by
|
||||
# 'AND'
|
||||
|
||||
sub where_and {
|
||||
my $self = attr shift;
|
||||
my %attributes = %{$_[0]};
|
||||
my $conditions;
|
||||
for ( keys %attributes ) {
|
||||
my($attribute) = $TABLE->get_attributes($_);
|
||||
$conditions .= ' AND ' if $conditions;
|
||||
my($name,$type) = ($attribute->name,$attribute->references->type);
|
||||
$conditions .= "$name = " . $TABLE->dbh->quote($attributes{$name},$type);
|
||||
}
|
||||
print STDERR "$conditions\n" if $_DEBUG;
|
||||
$conditions;
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
#=head2 fill_template($name)
|
||||
|
||||
#Returns the template named I<$name> in the table associated with this
|
||||
#object filled with the object's attribute values. See
|
||||
#L<DbFramework::Table/"fill_template()">.
|
||||
|
||||
#=cut
|
||||
|
||||
sub fill_template {
|
||||
my($self,$name) = (attr shift,shift);
|
||||
$TABLE->fill_template($name,$self->attributes_h);
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head2 as_html_form()
|
||||
|
||||
Returns an HTML form representing the object, filled with the object's
|
||||
attribute values.
|
||||
|
||||
=cut
|
||||
|
||||
sub as_html_form {
|
||||
my $self = attr shift;
|
||||
my %attributes = %{$self->attributes_h};
|
||||
my $html;
|
||||
for ( @{$self->table->contains_l} ) {
|
||||
next if $self->table->in_foreign_key($_);
|
||||
my $name = $_->name;
|
||||
$html .= "<TR><TD><STRONG>$name</STRONG></TD><TD>"
|
||||
. $_->as_html_form_field($attributes{$name})
|
||||
. "</TD></TR>\n";
|
||||
}
|
||||
return $html;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 init_pk()
|
||||
|
||||
Initialise an object by setting its attributes based on the current
|
||||
value of the its primary key attributes.
|
||||
|
||||
=cut
|
||||
|
||||
sub init_pk {
|
||||
my $self = attr shift;
|
||||
my @loh = $TABLE->select_loh(undef,$self->_pk_conditions);
|
||||
$self->attributes_h([ %{$loh[0]} ]);
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 table_qualified_attribute_hashref()
|
||||
|
||||
Returns a reference to a hash whose keys are the keys of
|
||||
I<%ATTRIBUTES_H> with a prefix of I<$table>, where I<$table> is the
|
||||
table associated with the object and whose values are values from
|
||||
I<%ATTRIBUTES_H>. This is useful for filling a template (see
|
||||
L<DbFramework::Template/fill()>.)
|
||||
|
||||
=cut
|
||||
|
||||
sub table_qualified_attribute_hashref {
|
||||
my $self = attr shift;
|
||||
my $t_name = $TABLE->name;
|
||||
my %tq;
|
||||
for ( keys %ATTRIBUTES_H ) { $tq{"$t_name.$_"} = $ATTRIBUTES_H{$_} }
|
||||
return \%tq;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DbFramework::Util>, L<DbFramework::Table> and
|
||||
L<DbFramework::Template>.
|
||||
|
||||
=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
|
||||
|
||||
341
lib/DbFramework/PrimaryKey.pm
Normal file
341
lib/DbFramework/PrimaryKey.pm
Normal file
@ -0,0 +1,341 @@
|
||||
=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
|
||||
|
||||
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
|
||||
#-----------------------------------------------------------------------------
|
||||
|
||||
=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
|
||||
211
lib/DbFramework/Relationship.pm
Normal file
211
lib/DbFramework/Relationship.pm
Normal file
@ -0,0 +1,211 @@
|
||||
package DbFramework::Relationship;
|
||||
use strict;
|
||||
use base qw(DbFramework::DefinitionObject DbFramework::DataModelObject);
|
||||
use DbFramework::ForeignKey;
|
||||
use Alias;
|
||||
use vars qw( $NAME $SRC $DEST @COLUMNS );
|
||||
use Carp;
|
||||
|
||||
# CLASS DATA
|
||||
|
||||
my %relationships;
|
||||
my %fields = (SRC => undef,
|
||||
DEST => undef,
|
||||
ROLES => [], # DbFramework::Role
|
||||
);
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## CLASS METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
sub new {
|
||||
my $DEBUG = 0;
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless($class->SUPER::new(shift),$class);
|
||||
for my $element (keys %fields) {
|
||||
$self->{_PERMITTED}->{$element} = $fields{$element};
|
||||
}
|
||||
@{$self}{keys %fields} = values %fields;
|
||||
|
||||
attr $self;
|
||||
($SRC,$DEST) = (shift,shift);
|
||||
$self->{COLUMNS} = shift || [];
|
||||
$relationships{$NAME} = [ $SRC,$DEST ];
|
||||
|
||||
if ( $DEBUG ) {
|
||||
carp "relationship name: $NAME";
|
||||
for ( @{$self->{COLUMNS}} ) {
|
||||
carp "column: " . $_->name;
|
||||
}
|
||||
}
|
||||
|
||||
# if ( ( $_[2] !~ /(1|N)/ && $_[3] !~ /(1|N)/ ) ||
|
||||
# ( $_[6] !~ /(1|N)/ && $_[7] !~ /(1|N)/ ) ) {
|
||||
# print STDERR $_[0]->name, "($_[2],$_[3]) ", $_[4]->name, "($_[6],$_[7])\n";
|
||||
# die "invalid cardinality";
|
||||
# }
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## OBJECT METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
sub create_ddl {
|
||||
my $self = attr shift;
|
||||
my $t = shift;
|
||||
my %values = ('rel_id' => 0,
|
||||
'rel_name' => $NAME,
|
||||
'rel_srctbl' => $SRC->table->name,
|
||||
'rel_srcrole' => $SRC->role,
|
||||
'rel_srcmin' => $SRC->min,
|
||||
'rel_srcmax' => $SRC->max,
|
||||
'rel_desttbl' => $DEST->table->name,
|
||||
'rel_destrole' => $DEST->role,
|
||||
'rel_destmin' => $DEST->min,
|
||||
'rel_destmax' => $DEST->max );
|
||||
$t->insert_ddl(\%values);
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
# requires (DbFramework::*::Table,DbFramework::*::Table)
|
||||
sub many_to_many {
|
||||
my $class = shift;
|
||||
my($table1,$table2) = @_;
|
||||
|
||||
for ( values(%relationships) ) {
|
||||
if ( ($_->[0][0] == $table1 && $_[1][0] == $table2) ||
|
||||
($_->[0][0] == $table2 && $_[1][0] == $table1) ) {
|
||||
return 1 if ( $_->[0]->max eq 'N' && $_->[1]->max eq 'N' ); # M:N
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
# See Fundamentals of Database Systems by Elmasri/Navathe, 1989 p 329ff
|
||||
# for relationship mapping rules
|
||||
# requires: $DbFramework::*::Schema
|
||||
sub set_foreign_key {
|
||||
my $DEBUG = 0;
|
||||
my $self = attr shift;
|
||||
my $schema = shift;
|
||||
|
||||
if ( $DEBUG ) {
|
||||
carp "in DbFramework::Relationship::set_foreign_key";
|
||||
carp "(src)", $SRC->table->name, " ", $SRC->role, " ", $SRC->min, ",", $SRC->max, "\n";
|
||||
carp "(dest)", $DEST->table->name, " ", $DEST->role, " ", $DEST->min, ",", $DEST->max, "\n";
|
||||
}
|
||||
|
||||
my $s; # role player to add relationship attributes to
|
||||
|
||||
if ( ($SRC->max == 1) && ($DEST->max == 1) ) { # 1:1
|
||||
# add fk in relation with highest min cardinality
|
||||
my @roles = sort _by_min ($DEST,$SRC);
|
||||
my $null = ($roles[0]->min == 0) ? 1 : 0;
|
||||
$self->_pk_as_fk($null,@roles);
|
||||
$s = $roles[0]->table;
|
||||
}
|
||||
|
||||
if ( ($SRC->max == 1) && ($DEST->max eq 'N') ||
|
||||
($SRC->max eq 'N') && ($DEST->max == 1) ) { # 1:N
|
||||
# add fk in relation with N cardinality
|
||||
my @roles = sort _by_max ($DEST,$SRC);
|
||||
if ( $DEBUG ) {
|
||||
carp $roles[0]->min, ",", $roles[1]->min;
|
||||
}
|
||||
my $null = ($roles[0]->min == 0) ? 1 : 0;
|
||||
$self->_pk_as_fk($null,@roles);
|
||||
$s = $roles[0]->table;
|
||||
}
|
||||
|
||||
if ( ($SRC->max eq'N') && ($DEST->max eq 'N') ) { # M:N
|
||||
carp "M:N ", $SRC->table->name, ",", $DEST->table->name if ( $DEBUG );
|
||||
# an M:N can be re-defined as two 1:N relationships with a new table
|
||||
# we don't store these conceptual relationships atm
|
||||
|
||||
my $table_name = $SRC->table->name . '_' . $DEST->table->name;
|
||||
# primary key consists of pk from each table in the M:N (NOT NULL)
|
||||
my(@src_pk,@dest_pk);
|
||||
foreach ( @{$SRC->table->primary_key->columns} ) {
|
||||
push(@src_pk,$_->new($_->name,$_->type,$_->length,0,undef));
|
||||
}
|
||||
foreach ( @{$DEST->table->primary_key->columns} ) {
|
||||
push(@dest_pk,$_->new($_->name,$_->type,$_->length,0,undef));
|
||||
}
|
||||
my $pk = DbFramework::PrimaryKey->new([@src_pk,@dest_pk]);
|
||||
my $n_side = $SRC->table->new($table_name,[@src_pk,@dest_pk],$pk,undef);
|
||||
$n_side->foreign_key(DbFramework::ForeignKey->new($SRC->table,\@src_pk));
|
||||
$n_side->foreign_key(DbFramework::ForeignKey->new($DEST->table,\@dest_pk));
|
||||
$schema->tables( [ $n_side ] );
|
||||
$s = $n_side;
|
||||
}
|
||||
|
||||
# add attributes of relationship to appropriate table
|
||||
if ( @COLUMNS ) {
|
||||
print STDERR "adding columns from relationship $NAME to ",$s->name,"\n"
|
||||
if $DEBUG;
|
||||
$s->add_columns(\@COLUMNS);
|
||||
}
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
# ascending sort by max cardinality
|
||||
sub _by_max {
|
||||
my $DEBUG = 0;
|
||||
if ( $DEBUG ) {
|
||||
carp "in DbFramework::Relationship::_sort_relationship";
|
||||
carp $a->max, ",", $b->max;
|
||||
}
|
||||
if ( $b->max == 1 ) {
|
||||
return 0 if ( $a->max == 1 );
|
||||
return -1 if ( $a->max eq 'N' );
|
||||
}
|
||||
if ( $b->max eq 'N' ) {
|
||||
return 0 if ( $a->max == 'N' );
|
||||
return 1 if ( $a->max == 1 );
|
||||
}
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
# ascending sort by min cardinality
|
||||
sub _by_min {
|
||||
return ( $a->min <=> $b->min );
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
# add primary key from table as a foreign key in related table
|
||||
# require: ($DbFramework::RolePlayer,$DbFramework::RolePlayer)
|
||||
sub _pk_as_fk {
|
||||
my $DEBUG = 0;
|
||||
carp "in DbFramework::Relationship::_pk_as_fk" if ( $DEBUG );
|
||||
my $self = attr shift;
|
||||
my($null,$pk_side,$fk_side) = @_;
|
||||
|
||||
if ( $DEBUG ) {
|
||||
carp "pk side: ", $pk_side->table->name, " fk side: ", $fk_side->table->name;
|
||||
}
|
||||
my $column_name_suffix;
|
||||
if ( $pk_side->table->name eq $fk_side->table->name ) { # recursive
|
||||
$column_name_suffix = '_' . $NAME;
|
||||
}
|
||||
|
||||
my @columns;
|
||||
foreach ( @{$pk_side->table->primary_key->columns} ) {
|
||||
# be sure to create new columns from the same (sub)class by calling
|
||||
# new() on an object
|
||||
push(@columns,$_->new($_->name . $column_name_suffix,$_->type,$_->length,$null,undef));
|
||||
}
|
||||
|
||||
$fk_side->table->add_columns(\@columns);
|
||||
$fk_side->table->foreign_key(DbFramework::ForeignKey->new($pk_side->table,\@columns));
|
||||
}
|
||||
|
||||
1;
|
||||
886
lib/DbFramework/Table.pm
Normal file
886
lib/DbFramework/Table.pm
Normal file
@ -0,0 +1,886 @@
|
||||
=head1 NAME
|
||||
|
||||
DbFramework::Table - Table class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
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);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A B<DbFramework::Table> object represents a database table (entity).
|
||||
|
||||
=head1 SUPERCLASSES
|
||||
|
||||
B<DbFramework::DefinitionObject>
|
||||
|
||||
B<DbFramework::DataModelObject>
|
||||
|
||||
=cut
|
||||
|
||||
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
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=head2 new($name,\@attributes,$pk,$dbh,$dm)
|
||||
|
||||
Create a new B<DbFramework::Table> object. I<$dbh> is a DBI database
|
||||
handle which refers to a database containing a table named I<$name>.
|
||||
I<@attribues> is a list of B<DbFramework::Attribute> objects.
|
||||
I<$primary> is a B<DbFramework::PrimaryKey> object. I<@attributes>
|
||||
and I<$primary> can be omitted if you plan to use the
|
||||
B<init_db_metadata()> object method (see below). I<$dm> is a
|
||||
B<DbFramework::DataModel> object to which this table belongs.
|
||||
|
||||
=cut
|
||||
|
||||
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
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head1 OBJECT METHODS
|
||||
|
||||
Foreign keys in a table can be accessed using the
|
||||
I<HAS_FOREIGN_KEYS_L> and I<HAS_FOREIGN_KEYS_H> attributes. B<Note>
|
||||
that foreign key objects will not be created automatically by calling
|
||||
init_db_metadata() on a table object. If you want to automatically
|
||||
create foreign key objects for your tables you should use call
|
||||
init_db_metadata() on a B<DbFramework::DataModel> object (see
|
||||
L<DbFramework::Datamodel/init_db_metadata()>). Other keys (indexes)
|
||||
defined for a table can be accessed using the I<IS_ACCESSED_USING_L>
|
||||
attribute. See L<DbFramework::Util/AUTOLOAD()> for the accessor
|
||||
methods for these attributes.
|
||||
|
||||
=head2 is_identified_by($primary)
|
||||
|
||||
I<$primary> is a B<DbFramework::PrimaryKey> object. If supplied sets
|
||||
the table's primary key to I<$primary>. Returns a
|
||||
B<DbFramework::PrimaryKey> object with is the table's primary key.
|
||||
|
||||
=head2 dbh($dbh)
|
||||
|
||||
I<$dbh> is a DBI database handle. If supplied sets the database
|
||||
handle associated with the table. Returns the database handle
|
||||
associated with the table.
|
||||
|
||||
=head2 belongs_to($dm)
|
||||
|
||||
I<$dm> is a B<DbFramework::DataModel> object. If supplied sets the
|
||||
data model to which the table belongs. Returns the data model to
|
||||
which the table belongs.
|
||||
|
||||
=head2 get_attributes(@names)
|
||||
|
||||
Returns a list of B<DbFramework::Attribute> objects. I<@names> is a
|
||||
list of attribute names to return. If I<@names> is undefined all
|
||||
attributes associated with the table are returned.
|
||||
|
||||
=cut
|
||||
|
||||
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
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head2 attribute_names()
|
||||
|
||||
Returns a list of attribute names for the table.
|
||||
|
||||
=cut
|
||||
|
||||
sub attribute_names {
|
||||
my $self = attr shift;
|
||||
my @names;
|
||||
for ( @CONTAINS_L ) { push(@names,$_->name) }
|
||||
@names;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 as_html_form()
|
||||
|
||||
Returns HTML form fields for all attributes in the table.
|
||||
|
||||
=cut
|
||||
|
||||
sub as_html_form {
|
||||
my $self = attr shift;
|
||||
my $form;
|
||||
for ( @CONTAINS_L ) { $form .= "<tr><td>" . $_->as_html_form_field . "</td></tr>\n" }
|
||||
$form;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 in_foreign_key($attribute)
|
||||
|
||||
I<$attribute> is a B<DbFramework::Attribute> object. Returns a list
|
||||
of B<DbFramework::ForeignKey> objects which contain I<$attribute>.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 in_primary_key($attribute)
|
||||
|
||||
I<$attribute> is a B<DbFramework::Attribute> object. Returns true if
|
||||
I<$attribute> is a part of the primary key in the table.
|
||||
|
||||
=cut
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 in_key($attribute)
|
||||
|
||||
I<$attribute> is a B<DbFramework::Attribute> object. Returns true if
|
||||
I<$attribute> is a part of a key (index) in the table.
|
||||
|
||||
=cut
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 in_any_key($attribute)
|
||||
|
||||
I<$attribute> is a B<DbFramework::Attribute> object. Returns true if
|
||||
I<$attribute> is a part of a key (index), a primary key or a foreign
|
||||
key in the table.
|
||||
|
||||
=cut
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 non_key_attributes()
|
||||
|
||||
Returns a list of B<DbFramework::Attribute> objects which are not
|
||||
members of any key, primary key or foreign key.
|
||||
|
||||
=cut
|
||||
|
||||
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";
|
||||
#}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 as_string()
|
||||
|
||||
Returns table details as a string.
|
||||
|
||||
=cut
|
||||
|
||||
sub as_string {
|
||||
my $self = attr shift;
|
||||
my $s = "Table: $NAME\n";
|
||||
for ( @{$self->contains_l} ) { $s .= $_->as_string }
|
||||
return $s;
|
||||
}
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head2 init_db_metadata($catalog)
|
||||
|
||||
Returns an initialised B<DbFramework::Table> object for the table
|
||||
matching this object's name() in the database referenced by dbh().
|
||||
I<$catalog> is a B<DbFramework::Catalog> object.
|
||||
|
||||
=cut
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 as_sql()
|
||||
|
||||
Returns a string which can be used to create a table in an SQL 'CREATE
|
||||
TABLE' statement.
|
||||
|
||||
=cut
|
||||
|
||||
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";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 delete($conditions)
|
||||
|
||||
DELETE rows FROM the table associated with this object WHERE the
|
||||
conditions in I<$conditions> are met. Returns the number of rows
|
||||
deleted if supplied by the DBI driver.
|
||||
|
||||
=cut
|
||||
|
||||
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);
|
||||
}
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 insert(\%values)
|
||||
|
||||
INSERT INTO the table columns corresponding to the keys of I<%values>
|
||||
the VALUES corresponding to the values of I<%values>. Returns the
|
||||
primary key of the inserted row if it is a Mysql 'AUTO_INCREMENT'
|
||||
column or -1.
|
||||
|
||||
=cut
|
||||
|
||||
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;
|
||||
}
|
||||
}
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 update(\%values,$conditions)
|
||||
|
||||
UPDATE the table SETting the columns matching the keys in %values to
|
||||
the values in %values WHERE I<$conditions> are met. Returns the
|
||||
number of rows updated if supplied by the DBI driver.
|
||||
|
||||
=cut
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 select(\@columns,$conditions,$order)
|
||||
|
||||
Returns a list of lists of values by SELECTing values FROM I<@columns>
|
||||
WHERE rows meet I<$conditions> ORDERed BY the list of columns in
|
||||
I<$order>. Strings in I<@columns> can refer to functions supported by
|
||||
the database in a SELECT clause e.g.
|
||||
|
||||
C<@columns = q/sin(foo),cos(bar),tan(baz)/;>
|
||||
|
||||
=cut
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 select_loh(\@columns,$conditions,$order)
|
||||
|
||||
Returns a list of hashrefs containing B<(column_name,value)> pairs by
|
||||
SELECTing values FROM I<@columns> WHERE rows meet I<$conditions>
|
||||
ORDERed BY the list of columns in I<$order>. Strings in I<@columns>
|
||||
can refer to functions supported by the database in a SELECT clause
|
||||
e.g.
|
||||
|
||||
C<@columns = q/sin(foo),cos(bar),tan(baz)/;>
|
||||
|
||||
The keys in the hashrefs will match the name of the function applied
|
||||
to the column i.e.
|
||||
|
||||
C<@loh = $foo-E<gt>select(\@columns);>
|
||||
|
||||
C<print "sin(foo) = $loh[0]-E<gt>{sin(foo)}\n";>
|
||||
|
||||
=cut
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 as_html_heading()
|
||||
|
||||
Returns a string for use as a table heading row in an HTML table.
|
||||
|
||||
=cut
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DbFramework::DefinitionObject>, L<DbFramework::Attribute>,
|
||||
L<DbFramework::DataModelObject> and L<DbFramework::DataModel>.
|
||||
|
||||
=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
|
||||
|
||||
1;
|
||||
268
lib/DbFramework/Template.pm
Normal file
268
lib/DbFramework/Template.pm
Normal file
@ -0,0 +1,268 @@
|
||||
=head1 NAME
|
||||
|
||||
DbFramework::Template - Fill template with database values
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use DbFramework::Template;
|
||||
$t = new DbFramework::Template($template,\@tables);
|
||||
print $t->fill;
|
||||
$t->default($table);
|
||||
$t->template->set_text($template);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<DbFramework::Template> is a class for filling templates with values
|
||||
from a database.
|
||||
|
||||
=head2 Template placeholders
|
||||
|
||||
The following list describes the placeholders allowed in a template.
|
||||
In each case I<%values> relates to the hash passed to the fill()
|
||||
method.
|
||||
|
||||
=over 4
|
||||
|
||||
=item I<(:&db_value(table.column):)>
|
||||
|
||||
Replaced with the value from I<%values> whose key is I<table.column>.
|
||||
See L<DbFramework::Persistent/table_qualified_attribute_hashref()> for
|
||||
a useful method for generating a hash to fill this type of
|
||||
placeholder.
|
||||
|
||||
=item I<(:&db_html_form_field(table.column[ value=value][ type=type]):)>
|
||||
|
||||
Replaced with an HTML form field appropriate for the column I<column>
|
||||
in the table I<table>. I<value> is the inital value which will be
|
||||
applied to the field. The type of field generated is determined by
|
||||
the data type of I<column>. This can be overridden by setting
|
||||
I<type>. See L<DbFramework::Attribute/as_html_form_field()> for more
|
||||
details.
|
||||
|
||||
=item I<(:&db_fk_html_form_field(table.fk):)>
|
||||
|
||||
Replaced with an HTML form field appropriate for the foreign key I<fk>
|
||||
in the table I<table>. See
|
||||
L<DbFramework::ForeignKey/as_html_form_field()> for more details.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SUPERCLASSES
|
||||
|
||||
B<DbFramework::Util>
|
||||
|
||||
=cut
|
||||
|
||||
package DbFramework::Template;
|
||||
use strict;
|
||||
use base 'DbFramework::Util';
|
||||
use Text::FillIn;
|
||||
use Alias;
|
||||
use vars qw($_DEBUG $TEMPLATE %TABLE_H %VALUES);
|
||||
|
||||
# set delimiters
|
||||
Text::FillIn->Ldelim('(:');
|
||||
Text::FillIn->Rdelim(':)');
|
||||
|
||||
my %fields = (
|
||||
TEMPLATE => {},
|
||||
TABLE_H => {},
|
||||
VALUES => {},
|
||||
);
|
||||
|
||||
##-----------------------------------------------------------------------------
|
||||
## CLASS METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=head2 new($template,\@tables)
|
||||
|
||||
Create a new B<DbFramework::Template> object. I<$template> is the
|
||||
template to be filled. I<@tables> are the B<DbFramework::Table>
|
||||
objects required for filling the template.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless { _PERMITTED => \%fields, %fields, }, $class;
|
||||
|
||||
my $template = $self->template(new Text::FillIn());
|
||||
$template->text(shift);
|
||||
$template->object($self);
|
||||
$template->hook('&','do_method');
|
||||
|
||||
my @tables;
|
||||
for ( @{$_[0]} ) { push(@tables,($_->name,$_)) }
|
||||
$self->table_h(\@tables);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
##----------------------------------------------------------------------------
|
||||
## OBJECT METHODS
|
||||
##-----------------------------------------------------------------------------
|
||||
|
||||
=head1 OBJECT METHODS
|
||||
|
||||
=head2 template()
|
||||
|
||||
Returns the B<Text::FillIn> object associated with the template.
|
||||
|
||||
=head2 fill(\%values)
|
||||
|
||||
Returns a filled template. The values in I<%values> are used to fill
|
||||
certain placeholders in the template (see L<"Template placeholders">.)
|
||||
|
||||
=cut
|
||||
|
||||
sub fill {
|
||||
my $self = attr shift;
|
||||
%VALUES = $_[0] ? %{$_[0]} : ();
|
||||
$TEMPLATE->interpret;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub do_method {
|
||||
my $self = shift;
|
||||
my($method,$arg) = $_[0] =~ /(\w+)\((.*)\)/ or die ("Bad slot: $_[0]");
|
||||
#no strict('refs');
|
||||
return $self->$method($arg);
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub db_value {
|
||||
my($self,$arg) = (attr shift,shift);
|
||||
# (:&db_value(table.column):)
|
||||
$arg =~ /(\w+\.\w+)/ && return $VALUES{$1};
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub db_html_form_field {
|
||||
my($self,$arg) = (attr shift,shift);
|
||||
my $html;
|
||||
|
||||
# (:&db_html_form_field(table.column[ value=value][ type=type]):)
|
||||
if ( $arg =~ /^((\w+)\.(\w+))(,(.*?))?(,(.*?))?$/i ) {
|
||||
my $table = $TABLE_H{$2} or die "Can't find table in $arg";
|
||||
my $value = $5 ? $5 : $VALUES{$1};
|
||||
my $type = $7 ? $7 : undef;
|
||||
my $attribute_name = $3;
|
||||
my($attribute) = $table->get_attributes($attribute_name);
|
||||
|
||||
print STDERR "\$arg = $arg, \$value = $value, \$type = $type, \$attribute_name = $attribute_name, \$attribute = $attribute" if $_DEBUG;
|
||||
|
||||
$html = $attribute->as_html_form_field($value,$type);
|
||||
}
|
||||
$html;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub db_fk_html_form_field {
|
||||
my($self,$arg) = (attr shift,shift);
|
||||
|
||||
# (:&db_fk_html_form_field(table.fk):)
|
||||
if ( my($t_name,$fk_name) = $arg =~ /^(\w+)\.(\w+)$/ ) {
|
||||
my $table = $TABLE_H{$t_name} or die "Can't find table in $arg";
|
||||
my($fk) = $table->has_foreign_keys_h_byname($fk_name)
|
||||
or die "Can't find foreign key $2 in table " . $table->name;
|
||||
|
||||
print STDERR "\$fk_name = $fk_name, \$fk = $fk\n" if $_DEBUG;
|
||||
|
||||
$fk->as_html_form_field(\%VALUES);
|
||||
}
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
sub db_pk_html_hidden {
|
||||
my($self,$arg) = (attr shift,shift);
|
||||
|
||||
# (:&db_pk_html_hidden(table):)
|
||||
if ( my($t_name) = $arg =~ /^(\w+)$/ ) {
|
||||
my $table = $TABLE_H{$t_name} or die "Can't find table in $arg";
|
||||
$table->is_identified_by->as_hidden_html(\%VALUES);
|
||||
}
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 default($table)
|
||||
|
||||
I<$table> is a B<DbFramework::Table> object. Sets up a default
|
||||
template consisting of all fields in I<$table>.
|
||||
|
||||
=cut
|
||||
|
||||
sub default {
|
||||
my($self,$table) = (attr shift,shift);
|
||||
|
||||
$table = $TABLE_H{$table} or die "Can't find table '$table'";
|
||||
my $t_name = $table->name;
|
||||
my($l,$r) = ($TEMPLATE->Ldelim,$TEMPLATE->Rdelim);
|
||||
my $t;
|
||||
|
||||
# primary key
|
||||
for ( @{$table->is_identified_by->incorporates_l} ) {
|
||||
unless ( $table->in_foreign_key($_) ) {
|
||||
my $a_name = $_->name;
|
||||
$t .= qq{<TD>${l}&db_html_form_field(${t_name}.${a_name})${r}</TD>};
|
||||
}
|
||||
}
|
||||
|
||||
# ordinary attributes
|
||||
for ( $table->non_key_attributes ) {
|
||||
my $a_name = $_->name;
|
||||
$t .= qq{<TD>${l}&db_html_form_field(${t_name}.${a_name})${r}</TD>};
|
||||
}
|
||||
|
||||
# keys
|
||||
my(%key_attributes,@fk_attributes,@key_attributes);
|
||||
for ( @{$table->has_foreign_keys_l} ) {
|
||||
push(@fk_attributes,$_->attribute_names)
|
||||
}
|
||||
@key_attributes = (@fk_attributes,$table->is_identified_by->attribute_names);
|
||||
|
||||
for my $key ( @{$table->is_accessed_using_l} ) {
|
||||
# get unique hash of key attributes not in primary or foreign keys
|
||||
for ( @{$key->incorporates_l} ) {
|
||||
my $name = $_->name;
|
||||
$key_attributes{$name} = $_ unless grep(/^$name$/,@key_attributes);
|
||||
}
|
||||
}
|
||||
for ( keys(%key_attributes) ) {
|
||||
$t .= qq{<TD>${l}&db_html_form_field(${t_name}.$_)${r}</TD>};
|
||||
}
|
||||
|
||||
# foreign keys
|
||||
for ( @{$table->has_foreign_keys_l} ) {
|
||||
my $fk_name = $_->name;
|
||||
$t .= qq{<TD>${l}&db_fk_html_form_field(${t_name}.${fk_name})${r}</TD>};
|
||||
}
|
||||
|
||||
$TEMPLATE->text($t);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Text::FillIn> and L<DbFramework::Util>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Sharpe E<lt>paul@miraclefish.comE<gt>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 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
|
||||
219
lib/DbFramework/Util.pm
Normal file
219
lib/DbFramework/Util.pm
Normal file
@ -0,0 +1,219 @@
|
||||
=head1 NAME
|
||||
|
||||
DbFramework::Util - DbFramework utility functions
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use DbFramework::Util;
|
||||
($user,$password) = DbFramework::Util::get_auth();
|
||||
$dbh = DbFramework::Util::get_dbh($dsn,$user,$password);
|
||||
$sth = DbFramework::Util::do_sql($dbh,$sql);
|
||||
($user,$password) = DbFramework::Util::get_auth();
|
||||
|
||||
$object->debug($n);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
I<DbFramework::Util> contains miscellaneous utility functions and acts
|
||||
as a base class for many other B<DbFramework> classes.
|
||||
|
||||
=cut
|
||||
|
||||
package DbFramework::Util;
|
||||
use strict;
|
||||
use vars qw($AUTOLOAD);
|
||||
use IO::File;
|
||||
use DBI 1.06;
|
||||
use Carp;
|
||||
use Term::ReadKey;
|
||||
|
||||
## CLASS DATA
|
||||
|
||||
my $Debugging = 0;
|
||||
|
||||
=head1 BASE CLASS METHODS
|
||||
|
||||
=head2 AUTOLOAD()
|
||||
|
||||
AUTOLOAD() provides default accessor methods (apart from DESTROY())
|
||||
for any of its subclasses. For AUTOLOAD() to catch calls to these
|
||||
methods objects must be implemented as an anonymous hash. Object
|
||||
attributes must
|
||||
|
||||
=over 4
|
||||
|
||||
=item *) have UPPER CASE names
|
||||
|
||||
=item *) have keys in attribute _PERMITTED (an anonymous hash)
|
||||
|
||||
=back
|
||||
|
||||
The name accessor method is the name of the attribute in B<lower
|
||||
case>. The 'set' versions of these accessor methods require a single
|
||||
scalar argument (which could of course be a reference.) Both 'set'
|
||||
and 'get' versions return the attribute's value.
|
||||
|
||||
B<Special Attributes>
|
||||
|
||||
=over 4
|
||||
|
||||
=item B</_L$/>
|
||||
|
||||
Attribute names matching the pattern B</_L$/> will be treated as
|
||||
arrayrefs. These accessors require an arrayref as an argument. If
|
||||
the attribute is defined they return the arrayref, otherwise they
|
||||
return an empty arrayref.
|
||||
|
||||
A method B<*_l_add(@foo)> can be called on this type of attribute to
|
||||
add the elements in I<@foo> to the array. If the attribute is defined
|
||||
they return the arrayref, otherwise they return an empty arrayref.
|
||||
|
||||
=item B</_H$/>
|
||||
|
||||
Attribute names matching the pattern B</_H$/> will be treated as
|
||||
hashrefs. These accessors require a reference to an array containing
|
||||
key/value pairs. If the attribute is defined they return the hashref,
|
||||
otherwise they return an empty hashref.
|
||||
|
||||
A method B<*_h_byname(@list)> can be called on this type of attribute.
|
||||
These methods will return a list which is the hash slice of the B<_H>
|
||||
attribute value over I<@list> or an empty list if the attribute is
|
||||
undefined.
|
||||
|
||||
A method B<*_h_add(\%foo)> can be called on this type of attribute to
|
||||
add the elements in I<%foo> to the hash. If the attribute is defined
|
||||
they return the hashref, otherwise they return an empty hashref.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $self = shift;
|
||||
my $type = ref($self) or die "$self is not an object";
|
||||
warn "AUTOLOAD($AUTOLOAD)" if $self->{_DEBUG} || $Debugging;
|
||||
|
||||
my $method = $AUTOLOAD;
|
||||
$method =~ s/.*://; # strip fully-qualified portion
|
||||
|
||||
# accessor methods
|
||||
$method = uc($method);
|
||||
return if ( $method eq 'DESTROY' ); # don't catch 'DESTROY'
|
||||
my $name = $method;
|
||||
$name =~ s/_H_BYNAME|_H_ADD$/_H/;
|
||||
$name =~ s/_L_ADD$/_L/;
|
||||
unless ( exists $self->{_PERMITTED}->{$name} ) {
|
||||
die "Can't access `$name' field in class $type";
|
||||
}
|
||||
|
||||
print STDERR "\$_[0] = ",defined($_[0]) ? $_[0] : 'undef',"\n"
|
||||
if $self->{_DEBUG};
|
||||
|
||||
if ( $method =~ /_L$/ ) { # set/get array
|
||||
@{$self->{$name}} = @{$_[0]} if $_[0];
|
||||
return defined($self->{$name}) ? $self->{$name} : [];
|
||||
} elsif ( $method =~ /_L_ADD$/ ) { # add to array
|
||||
print STDERR "\@_ = @_\n" if $self->{_DEBUG};
|
||||
push(@{$self->{$name}},@_);
|
||||
return defined($self->{$name}) ? $self->{$name} : [];
|
||||
} elsif ( $method =~ /_H$/ ) { # set/get hash
|
||||
%{$self->{$name}} = @{$_[0]} if $_[0];
|
||||
return defined($self->{$name}) ? $self->{$name} : {};
|
||||
} elsif ( $method =~ /_H_ADD$/ ) { # add to hash
|
||||
while ( my($k,$v) = each(%{$_[0]}) ) { $self->{$name}->{$k} = $v }
|
||||
return defined($self->{$name}) ? $self->{$name} : {};
|
||||
} elsif ( $method =~ /_H_BYNAME$/ ) { # get hash values by name
|
||||
print STDERR "$self $name byname: @_\n" if $self->{_DEBUG};
|
||||
return defined($self->{$name}) ? @{$self->{$name}}{@_} : ();
|
||||
}
|
||||
else { # set/get scalar
|
||||
return @_ ? $self->{$name} = shift : $self->{$name};
|
||||
}
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 debug($n)
|
||||
|
||||
As a class method sets the class attribute I<$Debugging> to I<$n>. As
|
||||
an object method sets the object attribute I<$_DEBUG> to I<$n>.
|
||||
|
||||
=cut
|
||||
|
||||
sub debug {
|
||||
my $self = shift;
|
||||
confess "usage: thing->debug(level)" unless @_ == 1;
|
||||
my $level = shift;
|
||||
if (ref($self)) {
|
||||
$self->{"_DEBUG"} = $level; # just myself
|
||||
} else {
|
||||
$Debugging = $level; # whole class
|
||||
}
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head1 UTILITY FUNCTIONS
|
||||
|
||||
=head2 get_auth()
|
||||
|
||||
Read (I<$user>,I<$password>) from standard input with no echo when
|
||||
entering password.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_auth {
|
||||
print "Username: ";
|
||||
chop(my $user = <STDIN>);
|
||||
print "Password: ";
|
||||
ReadMode 2;
|
||||
chop(my $password = <STDIN>);
|
||||
print "\n";
|
||||
ReadMode 0;
|
||||
return($user,$password);
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 get_dbh($dsn,$user,$password)
|
||||
|
||||
Returns a database handle for the data source name I<$dsn> by
|
||||
connecting using I<$user> and I<$password>.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_dbh {
|
||||
my($dsn,$user,$password) = @_;
|
||||
return DBI->connect($dsn,$user,$password) || die("$dsn $DBI::errstr");
|
||||
}
|
||||
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
=head2 do_sql($dbh,$sql)
|
||||
|
||||
Executes I<$sql> on I<$dbh> and returns a statement handle. This
|
||||
method will die with I<$h-E<gt>errstr> if prepare() or execute() fails.
|
||||
|
||||
=cut
|
||||
|
||||
sub do_sql {
|
||||
my($dbh,$sql) = @_;
|
||||
#print "$sql\n";
|
||||
my $sth = $dbh->prepare($sql) || die($dbh->errstr);
|
||||
my $rv = $sth->execute || die($sth->errstr);
|
||||
return $sth;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Sharpe E<lt>paul@miraclefish.comE<gt>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 1997,1998 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
|
||||
Reference in New Issue
Block a user