From: Ivan Kohler Date: Sun, 3 Nov 2013 09:08:15 +0000 (-0800) Subject: start of foreign key support X-Git-Url: http://git.freeside.biz/gitweb/?p=DBIx-DBSchema.git;a=commitdiff_plain;h=400aa157abf08369aef787b093814ab9f4523015 start of foreign key support --- diff --git a/Changes b/Changes index 83f6abd..6b85511 100644 --- a/Changes +++ b/Changes @@ -1,7 +1,13 @@ Revision history for Perl extension DBIx::DBSchema. +0.42_01 unreleased + - Basic foreign key support + + table creation + + table alteration (adding new foreign keys) + + reverse-engineering (Pg driver) + 0.41_01 unreleased - - consolidate multiple ALTER TABLE statements for efficiency + - consolidate multiple ADD/ALTER COLUMN statements into one ALTER TABLE 0.40 Sat Dec 17 17:03:51 PST 2011 - doc: sql_update_schema link to sql_add_column misspelled diff --git a/DBSchema.pm b/DBSchema.pm index c55b823..78adaca 100644 --- a/DBSchema.pm +++ b/DBSchema.pm @@ -1,19 +1,19 @@ package DBIx::DBSchema; use strict; -use vars qw($VERSION $DEBUG $errstr); use Storable; use DBIx::DBSchema::_util qw(_load_driver _dbh _parse_opt); use DBIx::DBSchema::Table 0.08; use DBIx::DBSchema::Index; use DBIx::DBSchema::Column; -use DBIx::DBSchema::ColGroup::Unique; -use DBIx::DBSchema::ColGroup::Index; +use DBIx::DBSchema::ForeignKey; -$VERSION = "0.41_01"; +our $VERSION = '0.42_01'; $VERSION = eval $VERSION; # modperlstyle: convert the string into a number -$DEBUG = 0; +our $DEBUG = 0; + +our $errstr; =head1 NAME @@ -56,8 +56,8 @@ you can create a database schema with an OO Perl interface. You can read the schema from an existing database. You can save the schema to disk and restore it in a different process. You can write SQL CREATE statements statements for different databases from a single source. In recent versions, you can -transform one schema to another, adding any necessary new columns and tables -(and, as of 0.33, indices). +transform one schema to another, adding any necessary new columns, tables, +indices and foreign keys. Currently supported databases are MySQL, PostgreSQL and SQLite. Sybase and Oracle drivers are partially implemented. DBIx::DBSchema will attempt to use @@ -420,7 +420,20 @@ sub pretty_print { } keys %indices - ). "\n }, \n" + ). "\n }, \n". + + #foreign_keys + " 'foreign_keys' => [ ". join( ",\n ", + + map { my $name = $_->constraint; + "'$name' => { \n". + " },\n"; + } + $table->foreign_keys + + ). "\n ], \n" + + ; } $self->tables ). "}\n"; @@ -458,11 +471,7 @@ sub pretty_read { 'primary_key' => $info->{'primary_key'}, 'columns' => \@columns, - #old-style indices - 'unique' => DBIx::DBSchema::ColGroup::Unique->new($info->{'unique'}), - 'index' => DBIx::DBSchema::ColGroup::Index->new($info->{'index'}), - - #new-style indices + #indices 'indices' => [ map { my $idx_info = $info->{'indices'}{$_}; DBIx::DBSchema::Index->new({ 'name' => $_, @@ -531,15 +540,22 @@ the same terms as Perl itself. Multiple primary keys are not yet supported. -Foreign keys and other constraints are not yet supported. - -sql_update_schema doesn't deal with deleted columns yet. +Foreign keys: need to support dropping, NOT VALID, reverse engineering w/mysql Need to port and test with additional databases Each DBIx::DBSchema object should have a name which corresponds to its name within the SQL database engine (DBI data source). +Need to support "using" index attribute in pretty_read and in reverse +engineering + +sql CREATE TABLE output should convert integers +(i.e. use DBI qw(:sql_types);) to local types using DBI->type_info plus a hash +to fudge things + +=head2 PRETTY_ BUGS + pretty_print is actually pretty ugly. pretty_print isn't so good about quoting values... save/load is a much better @@ -553,16 +569,9 @@ when nothing is given in the read. Perhaps pretty_read should eval column types so that we can use DBI qw(:sql_types) here instead of externally. -Need to support "using" index attribute in pretty_read and in reverse -engineering - perhaps we should just get rid of pretty_read entirely. pretty_print is useful for debugging, but pretty_read is pretty bunk. -sql CREATE TABLE output should convert integers -(i.e. use DBI qw(:sql_types);) to local types using DBI->type_info plus a hash -to fudge things - =head1 SEE ALSO L, L, diff --git a/DBSchema/DBD.pm b/DBSchema/DBD.pm index 7a34e3c..898d0aa 100644 --- a/DBSchema/DBD.pm +++ b/DBSchema/DBD.pm @@ -1,9 +1,8 @@ package DBIx::DBSchema::DBD; use strict; -use vars qw($VERSION); -$VERSION = '0.07'; +our $VERSION = '0.08'; =head1 NAME @@ -152,6 +151,35 @@ Inheriting from DBIx::DBSchema::DBD will provide the default empty string. sub default_db_schema { ''; } +=item constraints CLASS DBI_DBH TABLE + +Given an active DBI database handle, return the constraints (currently, foreign +keys) for the specified table, as a list of hash references. + +Each hash reference has the following keys: + +=over 8 + +=item constraint - contraint name + +=item columns - List refrence of column names + +=item table - Foreign taable name + +=item references - List reference of column names in foreign table + +=item match - + +=item on_delete - + +=item on_update - + +=back + +=cut + +sub constraints { (); } + =item column_callback DBH TABLE_NAME COLUMN_OBJ Optional callback for driver-specific overrides to SQL column definitions. @@ -258,7 +286,7 @@ Ivan Kohler =head1 COPYRIGHT Copyright (c) 2000-2005 Ivan Kohler -Copyright (c) 2007-2010 Freeside Internet Services, Inc. +Copyright (c) 2007-2013 Freeside Internet Services, Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/DBSchema/DBD/Pg.pm b/DBSchema/DBD/Pg.pm index 730f638..c3d818f 100644 --- a/DBSchema/DBD/Pg.pm +++ b/DBSchema/DBD/Pg.pm @@ -1,18 +1,16 @@ package DBIx::DBSchema::DBD::Pg; +use base qw(DBIx::DBSchema::DBD); use strict; -use vars qw($VERSION @ISA %typemap); use DBD::Pg 1.32; -use DBIx::DBSchema::DBD; -$VERSION = '0.18'; -@ISA = qw(DBIx::DBSchema::DBD); +our $VERSION = '0.19'; die "DBD::Pg version 1.32 or 1.41 (or later) required--". "this is only version $DBD::Pg::VERSION\n" if $DBD::Pg::VERSION != 1.32 && $DBD::Pg::VERSION < 1.41; -%typemap = ( +our %typemap = ( 'BLOB' => 'BYTEA', 'LONG VARBINARY' => 'BYTEA', 'TIMESTAMP' => 'TIMESTAMP WITH TIME ZONE', @@ -170,6 +168,50 @@ END $row->{'indisunique'}; } +#using this +#******** QUERY ********** +#SELECT conname, +# pg_catalog.pg_get_constraintdef(r.oid, true) as condef +#FROM pg_catalog.pg_constraint r +#WHERE r.conrelid = '16457' AND r.contype = 'f' ORDER BY 1; +#************************** + +# what's this do? +#********* QUERY ********** +#SELECT conname, conrelid::pg_catalog.regclass, +# pg_catalog.pg_get_constraintdef(c.oid, true) as condef +#FROM pg_catalog.pg_constraint c +#WHERE c.confrelid = '16457' AND c.contype = 'f' ORDER BY 1; +#************************** + +sub constraints { + my($proto, $dbh, $table) = @_; + my $sth = $dbh->prepare(<errstr; + SELECT conname, pg_catalog.pg_get_constraintdef(r.oid, true) as condef + FROM pg_catalog.pg_constraint r + WHERE r.conrelid = ( SELECT oid FROM pg_class + WHERE relname = '$table' + AND pg_catalog.pg_table_is_visible(oid) + ) + AND r.contype = 'f' +END + $sth->execute; + + map { $_->{condef} + =~ /^FOREIGN KEY \(([\w\, ]+)\) REFERENCES (\w+)\(([\w\, ]+)\)\s*(.*)$/ + or die "unparsable constraint: ". $_->{condef}; + my($columns, $table, $references, $etc ) = ($1, $2, $3, $4); + +{ 'constraint' => $_->{conname}, + 'columns' => [ split(/,\s*/, $columns) ], + 'table' => $table, + 'references' => [ split(/,\s*/, $references) ], + #XXX $etc not handled yet for MATCH, ON DELETE, ON UPDATE + }; + } + grep $_->{condef} =~ /^\s*FOREIGN\s+KEY/, + @{ $sth->fetchall_arrayref( {} ) }; +} + sub add_column_callback { my( $proto, $dbh, $table, $column_obj ) = @_; my $name = $column_obj->name; @@ -356,8 +398,6 @@ the same terms as Perl itself. =head1 BUGS -Yes. - columns doesn't return column default information. =head1 SEE ALSO diff --git a/DBSchema/ForeignKey.pm b/DBSchema/ForeignKey.pm new file mode 100644 index 0000000..282f8a3 --- /dev/null +++ b/DBSchema/ForeignKey.pm @@ -0,0 +1,262 @@ +package DBIx::DBSchema::ForeignKey; + +use strict; + +our $VERSION = '0.1'; +our $DEBUG = 0; + +=head1 NAME + +DBIx::DBSchema::ForeignKey - Foreign key objects + +=head1 SYNOPSIS + + use DBIx::DBSchema::ForeignKey; + + $foreign_key = new DBIx::DBSchema::ForeignKey ( + { 'columns' => [ 'column_name' ], + 'table' => 'foreign_table', + } + ); + + $foreign_key = new DBIx::DBSchema::ForeignKey ( + { 'columns' => [ 'column_name', 'column2' ], + 'table' => 'foreign_table', + 'references' => [ 'foreign_column', 'foreign_column2' ], + 'match' => 'MATCH FULL', # or MATCH SIMPLE + 'on_delete' => 'NO ACTION', # on clauses: NO ACTION / RESTRICT / + 'on_update' => 'RESTRICT', # CASCADE / SET NULL / SET DEFAULT + } + ); + +=head1 DESCRIPTION + +DBIx::DBSchema::ForeignKey objects represent a foreign key. + +=head1 METHODS + +=over 4 + +=item new HASHREF | OPTION, VALUE, ... + +Creates a new DBIx::DBschema::ForeignKey object. + +Accepts either a hashref or a list of options and values. + +Options are: + +=over 8 + +=item constraint - constraint name + +=item columns - List reference of column names + +=item table - Foreign table name + +=item references - List reference of column names in foreign table + +=item match - + +=item on_delete - + +=item on_update - + +=back + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %opt = ref($_[0]) ? %{$_[0]} : @_; #want a new reference + my $self = \%opt; + bless($self, $class); +} + +=item constraint [ CONSTRAINT_NAME ] + +Returns or sets the foreign table name + +=cut + +sub constraint { + my($self, $value) = @_; + if ( defined($value) ) { + $self->{constraint} = $value; + } else { + $self->{constraint}; + } +} + +=item table [ TABLE_NAME ] + +Returns or sets the foreign table name + +=cut + +sub table { + my($self, $value) = @_; + if ( defined($value) ) { + $self->{table} = $value; + } else { + $self->{table}; + } +} + +=item columns [ LISTREF ] + +Returns or sets the columns. + +=cut + +sub columns { + my($self, $value) = @_; + if ( defined($value) ) { + $self->{columns} = $value; + } else { + $self->{columns}; + } +} + +=item columns_sql + +Returns a comma-joined list of columns, suitable for an SQL statement. + +=cut + +sub columns_sql { + my $self = shift; + join(', ', @{ $self->columns } ); +} + +=item references [ LISTREF ] + +Returns or sets the referenced columns. + +=cut + +sub references { + my($self, $value) = @_; + if ( defined($value) ) { + $self->{references} = $value; + } else { + $self->{references}; + } +} + +=item references_sql + +Returns a comma-joined list of referenced columns, suitable for an SQL +statement. + +=cut + +sub references_sql { + my $self = shift; + join(', ', @{ $self->references || $self->columns } ); +} + +=item match [ TABLE_NAME ] + +Returns or sets the MATCH clause + +=cut + +sub match { + my($self, $value) = @_; + if ( defined($value) ) { + $self->{match} = $value; + } else { + $self->{match}; + } +} + +=item on_delete [ ACTION ] + +Returns or sets the ON DELETE clause + +=cut + +sub on_delete { + my($self, $value) = @_; + if ( defined($value) ) { + $self->{on_delete} = $value; + } else { + $self->{on_delete}; + } +} + +=item on_update [ ACTION ] + +Returns or sets the ON UPDATE clause + +=cut + +sub on_update { + my($self, $value) = @_; + if ( defined($value) ) { + $self->{on_update} = $value; + } else { + $self->{on_update}; + } +} + + + +=item sql_foreign_key + +Returns an SQL FOREIGN KEY statement. + +=cut + +sub sql_foreign_key { + my( $self ) = @_; + + my $table = $self->table; + my $col_sql = $self->columns_sql; + my $ref_sql = $self->references_sql; + + "FOREIGN KEY ( $col_sql ) REFERENCES $table ( $ref_sql ) ". + join ' ', grep $_, map $self->$_, qw( match on_delete on_update ); +} + +=item cmp OTHER_INDEX_OBJECT + +Compares this object to another supplied object. Returns true if they are +have the same table, columns and references. + +=cut + +sub cmp { + my( $self, $other ) = @_; + + $self->table eq $other->table + and $self->columns_sql eq $other->columns_sql + and $self->references_sql eq $other->references_sql + ; +} + +=back + +=head1 AUTHOR + +Ivan Kohler + +Copyright (c) 2013 Freeside Internet Services, Inc. +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +Should give in and Mo or Moo. + +=head1 SEE ALSO + +L, L, L + +=cut + +1; + + diff --git a/DBSchema/Table.pm b/DBSchema/Table.pm index d32ae99..57b9c11 100644 --- a/DBSchema/Table.pm +++ b/DBSchema/Table.pm @@ -1,17 +1,14 @@ package DBIx::DBSchema::Table; use strict; -use vars qw($VERSION $DEBUG %create_params); use Carp; -#use Exporter; use DBIx::DBSchema::_util qw(_load_driver _dbh _parse_opt); use DBIx::DBSchema::Column 0.14; use DBIx::DBSchema::Index; -use DBIx::DBSchema::ColGroup::Unique; -use DBIx::DBSchema::ColGroup::Index; +use DBIx::DBSchema::ForeignKey; -$VERSION = '0.08'; -$DEBUG = 0; +our $VERSION = '0.09'; +our $DEBUG = 0; =head1 NAME @@ -24,12 +21,13 @@ DBIx::DBSchema::Table - Table objects #new style (preferred), pass a hashref of parameters $table = new DBIx::DBSchema::Table ( { - name => "table_name", - primary_key => "primary_key", - columns => \@dbix_dbschema_column_objects, + name => "table_name", + primary_key => "primary_key", + columns => \@dbix_dbschema_column_objects, #deprecated# unique => $dbix_dbschema_colgroup_unique_object, #deprecated# 'index' => $dbix_dbschema_colgroup_index_object, - indices => \@dbix_dbschema_index_objects, + indices => \@dbix_dbschema_index_objects, + foreign_keys => \@dbix_dbschema_foreign_key_objects, } ); @@ -92,24 +90,24 @@ hash reference of named parameters. columns => COLUMNS, indices => INDICES, local_options => OPTIONS, - #deprecated# unique => UNIQUE, - #deprecated# index => INDEX, } -TABLE_NAME is the name of the table. PRIMARY_KEY is the primary key (may be -empty). COLUMNS is a reference to an array of DBIx::DBSchema::Column objects -(see L). INDICES is a reference to an array of -DBIx::DBSchema::Index objects (see L), or a hash -reference of index names (keys) and DBIx::DBSchema::Index objects (values). -OPTIONS is a scalar of database-specific table options, such as "WITHOUT OIDS" -for Pg or "TYPE=InnoDB" for mysql. +TABLE_NAME is the name of the table. + +PRIMARY_KEY is the primary key (may be empty). + +COLUMNS is a reference to an array of DBIx::DBSchema::Column objects +(see L). + +INDICES is a reference to an array of DBIx::DBSchema::Index objects +(see L), or a hash reference of index names (keys) and +DBIx::DBSchema::Index objects (values). -Deprecated options: +FOREIGN_KEYS is a references to an array of DBIx::DBSchema::ForeignKey objects +(see L). -UNIQUE was a DBIx::DBSchema::ColGroup::Unique object (see -L). INDEX was a -DBIx::DBSchema::ColGroup::Index object (see -L). +OPTIONS is a scalar of database-specific table options, such as "WITHOUT OIDS" +for Pg or "TYPE=InnoDB" for mysql. =cut @@ -127,6 +125,8 @@ sub new { $self->{indices} = { map { $_->name, $_ } @{$self->{indices}} } if ref($self->{indices}) eq 'ARRAY'; + $self->{foreign_keys} ||= []; + } else { carp "Old-style $class creation without named parameters is deprecated!"; @@ -145,6 +145,7 @@ sub new { 'index' => $index, 'columns' => \%columns, 'column_order' => \@column_order, + 'foreign_keys' => [], }; } @@ -175,7 +176,7 @@ have to have ODBC installed or connect to the database via ODBC. =cut -%create_params = ( +our %create_params = ( # undef => sub { '' }, '' => sub { '' }, 'max length' => sub { $_[0]->{PRECISION}->[$_[1]]; }, @@ -235,19 +236,7 @@ sub new_odbc { ], - #old-style indices - #DBIx::DBSchema::ColGroup::Unique->new( - # $driver - # ? [values %{eval "DBIx::DBSchema::DBD::$driver->unique(\$dbh, \$name)"}] - # : [] - #), - #DBIx::DBSchema::ColGroup::Index->new( - # $driver - # ? [ values %{eval "DBIx::DBSchema::DBD::$driver->index(\$dbh, \$name)"} ] - # : [] - #), - - #new-style indices + #indices 'indices' => { map { my $indexname = $_; $indexname => DBIx::DBSchema::Index->new($indices_hr->{$indexname}) @@ -272,6 +261,9 @@ sub new_native { my( $proto, $dbh, $name) = @_; my $driver = _load_driver($dbh); + my $primary_key = + scalar(eval "DBIx::DBSchema::DBD::$driver->primary_key(\$dbh, \$name)"), + my $indices_hr = ( $driver ? eval "DBIx::DBSchema::DBD::$driver->indices(\$dbh, \$name)" @@ -279,23 +271,14 @@ sub new_native { ); $proto->new({ - 'name' => $name, - 'primary_key' => scalar(eval "DBIx::DBSchema::DBD::$driver->primary_key(\$dbh, \$name)"), - 'columns' => [ - + 'name' => $name, + 'primary_key' => $primary_key, + + 'columns' => [ map DBIx::DBSchema::Column->new( @{$_} ), eval "DBIx::DBSchema::DBD::$driver->columns(\$dbh, \$name)" ], - #old-style indices - #DBIx::DBSchema::ColGroup::Unique->new( - # [ values %{eval "DBIx::DBSchema::DBD::$driver->unique(\$dbh, \$name)"} ] - #), - #DBIx::DBSchema::ColGroup::Index->new( - # [ values %{eval "DBIx::DBSchema::DBD::$driver->index(\$dbh, \$name)"} ] - #), - - #new-style indices 'indices' => { map { my $indexname = $_; $indexname => DBIx::DBSchema::Index->new($indices_hr->{$indexname}) @@ -303,6 +286,12 @@ sub new_native { keys %$indices_hr }, + 'foreign_keys' => [ + map DBIx::DBSchema::ForeignKey->new( $_ ), + eval "DBIx::DBSchema::DBD::$driver->constraints(\$dbh, \$name)" + ], + + }); } @@ -385,66 +374,6 @@ sub primary_key { } } -=item unique [ UNIQUE ] - -This method is deprecated and included for backwards-compatibility only. -See L for the current method to access unique and non-unique index -objects. - -Returns or sets the DBIx::DBSchema::ColGroup::Unique object. - -=cut - -sub unique { - my $self = shift; - - carp ref($self) . "->unique method is deprecated; see ->indices"; - #croak ref($self). "->unique method is deprecated; see ->indices"; - - $self->_unique(@_); -} - -sub _unique { - - my ($self,$value)=@_; - - if ( defined($value) ) { - $self->{unique} = $value; - } else { - $self->{unique}; - } -} - -=item index [ INDEX ] - -This method is deprecated and included for backwards-compatibility only. -See L for the current method to access unique and non-unique index -objects. - -Returns or sets the DBIx::DBSchema::ColGroup::Index object. - -=cut - -sub index { - my $self = shift; - - carp ref($self). "->index method is deprecated; see ->indices"; - #croak ref($self). "->index method is deprecated; see ->indices"; - - $self->_index(@_); -} - - -sub _index { - my($self,$value)=@_; - - if ( defined($value) ) { - $self->{'index'} = $value; - } else { - $self->{'index'}; - } -} - =item columns Returns a list consisting of the names of all columns. @@ -470,7 +399,7 @@ sub column { $self->{'columns'}->{$column}; } -=item indices COLUMN_NAME +=item indices Returns a list of key-value pairs suitable for assigning to a hash. Keys are index names, and values are index objects (see L). @@ -546,6 +475,8 @@ sub sql_create_table { push @columns, "PRIMARY KEY (". $self->primary_key. ")" if $self->primary_key && ! grep /PRIMARY KEY/i, @columns; + push @columns, $self->foreign_keys_sql; + my $indexnum = 1; my @r = ( @@ -725,12 +656,25 @@ sub sql_alter_table { } - unshift @r, "ALTER TABLE $table ". join(', ', @at) if @at; + ### + # foreign keys (add) + ### + + foreach my $foreign_key ( $new->foreign_keys ) { + + next if grep $foreign_key->cmp($_), $self->foreign_keys; + + push @at, 'ADD '. $foreign_key->sql_foreign_key; + } + + # XXX foreign keys modify / drop ### # return the statements ### - + + unshift @r, "ALTER TABLE $table ". join(', ', @at) if @at; + push @r, @r_later; warn join('', map "$_\n", @r) @@ -748,6 +692,29 @@ sub sql_drop_table { ("DROP TABLE $name"); } +=item foreign_keys_sql + +=cut + +sub foreign_keys_sql { + my $self = shift; + map $_->sql_foreign_key, $self->foreign_keys; +} + +=item foreign_keys + +Returns a list of foreign keys (DBIx::DBSchema::ForeignKey objects). + +=cut + +sub foreign_keys { + my $self = shift; + exists( $self->{'foreign_keys'} ) + ? @{ $self->{'foreign_keys'} } + : (); +} + + sub _null_sth { my($dbh, $table) = @_; my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0") @@ -793,8 +760,8 @@ indices method should be a setter, not just a getter? =head1 SEE ALSO -L, L, -L, L, L +L, L, L, +L, L =cut diff --git a/MANIFEST b/MANIFEST index 470cdb4..f2e6e95 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,8 +1,5 @@ Changes DBSchema.pm -DBSchema/ColGroup.pm -DBSchema/ColGroup/Index.pm -DBSchema/ColGroup/Unique.pm DBSchema/Column.pm DBSchema/DBD.pm DBSchema/DBD/Oracle.pm @@ -10,6 +7,7 @@ DBSchema/DBD/Pg.pm DBSchema/DBD/SQLite.pm DBSchema/DBD/Sybase.pm DBSchema/DBD/mysql.pm +DBSchema/ForeignKey.pm DBSchema/Index.pm DBSchema/Table.pm DBSchema/_util.pm