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
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
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
}
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";
'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' => $_,
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
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<DBIx::DBSchema::Table>, L<DBIx::DBSchema::Index>,
package DBIx::DBSchema::DBD;
use strict;
-use vars qw($VERSION);
-$VERSION = '0.07';
+our $VERSION = '0.08';
=head1 NAME
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.
=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.
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',
$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(<<END) or die $dbh->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;
=head1 BUGS
-Yes.
-
columns doesn't return column default information.
=head1 SEE ALSO
--- /dev/null
+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 <ivan-dbix-dbschema@420.am>
+
+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<DBIx::DBSchema::Table>, L<DBIx::DBSchema>, L<DBI>
+
+=cut
+
+1;
+
+
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
#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,
}
);
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<DBIx::DBSchema::Column>). INDICES is a reference to an array of
-DBIx::DBSchema::Index objects (see L<DBIx::DBSchema::Index>), 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<DBIx::DBSchema::Column>).
+
+INDICES is a reference to an array of DBIx::DBSchema::Index objects
+(see L<DBIx::DBSchema::Index>), 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<DBIx::DBSchema::ForeignKey>).
-UNIQUE was a DBIx::DBSchema::ColGroup::Unique object (see
-L<DBIx::DBSchema::ColGroup::Unique>). INDEX was a
-DBIx::DBSchema::ColGroup::Index object (see
-L<DBIx::DBSchema::ColGroup::Index>).
+OPTIONS is a scalar of database-specific table options, such as "WITHOUT OIDS"
+for Pg or "TYPE=InnoDB" for mysql.
=cut
$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!";
'index' => $index,
'columns' => \%columns,
'column_order' => \@column_order,
+ 'foreign_keys' => [],
};
}
=cut
-%create_params = (
+our %create_params = (
# undef => sub { '' },
'' => sub { '' },
'max length' => sub { $_[0]->{PRECISION}->[$_[1]]; },
],
- #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})
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)"
);
$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})
keys %$indices_hr
},
+ 'foreign_keys' => [
+ map DBIx::DBSchema::ForeignKey->new( $_ ),
+ eval "DBIx::DBSchema::DBD::$driver->constraints(\$dbh, \$name)"
+ ],
+
+
});
}
}
}
-=item unique [ UNIQUE ]
-
-This method is deprecated and included for backwards-compatibility only.
-See L</indices> 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</indices> 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.
$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<DBIx::DBSchema::Index>).
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 = (
}
- 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)
("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")
=head1 SEE ALSO
-L<DBIx::DBSchema>, L<DBIx::DBSchema::ColGroup::Unique>,
-L<DBIx::DBSchema::ColGroup::Index>, L<DBIx::DBSchema::Column>, L<DBI>
+L<DBIx::DBSchema>, L<DBIx::DBSchema::Column>, L<DBI>,
+L<DBIx::DBSchema::Index>, L<DBIx::DBSchema::FoeignKey>
=cut
Changes
DBSchema.pm
-DBSchema/ColGroup.pm
-DBSchema/ColGroup/Index.pm
-DBSchema/ColGroup/Unique.pm
DBSchema/Column.pm
DBSchema/DBD.pm
DBSchema/DBD/Oracle.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
projects / DBIx-DBSchema.git / commitdiff