DBIx-DBSchema-0.45/0000755000175000017500000000000012522572660012317 5ustar ivanivanDBIx-DBSchema-0.45/META.yml0000644000175000017500000000071512522572660013573 0ustar ivanivan--- abstract: unknown author: - unknown build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.142690' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: DBIx-DBSchema no_index: directory: - t - inc requires: DBI: '0' Storable: '0' version: '0.45' DBIx-DBSchema-0.45/MANIFEST0000644000175000017500000000105712522572660013453 0ustar ivanivanChanges DBSchema.pm DBSchema/Column.pm DBSchema/DBD.pm DBSchema/DBD/Oracle.pm 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 MANIFEST MANIFEST.SKIP Makefile.PL README t/load-mysql.t t/load-oracle.t t/load-pg.t t/load-sqlite.t t/load-sybase.t t/load.t t/mysql-text-default.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) DBIx-DBSchema-0.45/META.json0000644000175000017500000000152712522572660013745 0ustar ivanivan{ "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.142690", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "DBIx-DBSchema", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "DBI" : "0", "Storable" : "0" } } }, "release_status" : "stable", "version" : "0.45" } DBIx-DBSchema-0.45/Makefile.PL0000644000175000017500000000064012235772532014272 0ustar ivanivanuse ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'DBIx::DBSchema', 'VERSION_FROM' => 'DBSchema.pm', # finds $VERSION 'PREREQ_PM' => { 'DBI' => 0, #'FreezeThaw' => 0, 'Storable' => 0, }, ); DBIx-DBSchema-0.45/t/0000755000175000017500000000000012522572660012562 5ustar ivanivanDBIx-DBSchema-0.45/t/load-mysql.t0000644000175000017500000000021011772176132015022 0ustar ivanivanBEGIN { $| = 1; print "1..1\n"; } END {print "not ok 1\n" unless $loaded;} use DBIx::DBSchema::DBD::mysql; $loaded = 1; print "ok 1\n"; DBIx-DBSchema-0.45/t/load.t0000644000175000017500000000017411772176132013670 0ustar ivanivanBEGIN { $| = 1; print "1..1\n"; } END {print "not ok 1\n" unless $loaded;} use DBIx::DBSchema; $loaded = 1; print "ok 1\n"; DBIx-DBSchema-0.45/t/load-sybase.t0000644000175000017500000000021111772176132015144 0ustar ivanivanBEGIN { $| = 1; print "1..1\n"; } END {print "not ok 1\n" unless $loaded;} use DBIx::DBSchema::DBD::Sybase; $loaded = 1; print "ok 1\n"; DBIx-DBSchema-0.45/t/load-oracle.t0000644000175000017500000000021111772176132015123 0ustar ivanivanBEGIN { $| = 1; print "1..1\n"; } END {print "not ok 1\n" unless $loaded;} use DBIx::DBSchema::DBD::Oracle; $loaded = 1; print "ok 1\n"; DBIx-DBSchema-0.45/t/load-pg.t0000644000175000017500000000037011772176132014272 0ustar ivanivanprint "1..1\n"; eval "use DBD::Pg 1.32"; if ( length($@) ) { print "ok 1 # Skipped: DBD::Pg 1.32 required for Pg"; } else { eval "use DBIx::DBSchema::DBD::Pg;"; if ( length($@) ) { print "not ok 1\n"; } else { print "ok 1\n"; } } DBIx-DBSchema-0.45/t/mysql-text-default.t0000644000175000017500000000053712272310444016515 0ustar ivanivan#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 2; use_ok 'DBIx::DBSchema::Column'; my $col = DBIx::DBSchema::Column->new({ name => 'bar', type => 'text', default => "'bat'" }); my $sql = $col->line("DBI:mysql:test"); diag "Generated: $sql"; unlike $sql, qr/default/i, "column bar doesn't have a default"; DBIx-DBSchema-0.45/t/load-sqlite.t0000644000175000017500000000021111772176132015157 0ustar ivanivanBEGIN { $| = 1; print "1..1\n"; } END {print "not ok 1\n" unless $loaded;} use DBIx::DBSchema::DBD::SQLite; $loaded = 1; print "ok 1\n"; DBIx-DBSchema-0.45/DBSchema.pm0000644000175000017500000004235112522572431014264 0ustar ivanivanpackage DBIx::DBSchema; use strict; 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::ForeignKey; our $VERSION = '0.45'; $VERSION = eval $VERSION; # modperlstyle: convert the string into a number our $DEBUG = 0; our $errstr; =head1 NAME DBIx::DBSchema - Database-independent schema objects =head1 SYNOPSIS use DBIx::DBSchema; $schema = new DBIx::DBSchema @dbix_dbschema_table_objects; $schema = new_odbc DBIx::DBSchema $dbh; $schema = new_odbc DBIx::DBSchema $dsn, $user, $pass; $schema = new_native DBIx::DBSchema $dbh; $schema = new_native DBIx::DBSchema $dsn, $user, $pass; $schema->save("filename"); $schema = load DBIx::DBSchema "filename" or die $DBIx::DBSchema::errstr; $schema->addtable($dbix_dbschema_table_object); @table_names = $schema->tables; $DBIx_DBSchema_table_object = $schema->table("table_name"); @sql = $schema->sql($dbh); @sql = $schema->sql($dsn, $username, $password); @sql = $schema->sql($dsn); #doesn't connect to database - less reliable $perl_code = $schema->pretty_print; %hash = eval $perl_code; use DBI qw(:sql_types); $schema = pretty_read DBIx::DBSchema \%hash; =head1 DESCRIPTION DBIx::DBSchema objects are collections of DBIx::DBSchema::Table objects and represent a database schema. This module implements an OO-interface to database schemas. Using this module, 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. You can 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 generic SQL syntax for other databases. Assistance adding support for other databases is welcomed. See L, "Driver Writer's Guide and Base Class". =head1 METHODS =over 4 =item new TABLE_OBJECT, TABLE_OBJECT, ... Creates a new DBIx::DBSchema object. =cut sub new { my($proto, @tables) = @_; my %tables = map { $_->name, $_ } @tables; #check for duplicates? my $class = ref($proto) || $proto; my $self = { 'tables' => \%tables, }; bless ($self, $class); } =item new_odbc DATABASE_HANDLE | DATA_SOURCE USERNAME PASSWORD [ ATTR ] Creates a new DBIx::DBSchema object from an existing data source, which can be specified by passing an open DBI database handle, or by passing the DBI data source name, username, and password. This uses the experimental DBI type_info method to create a schema with standard (ODBC) SQL column types that most closely correspond to any non-portable column types. Use this to import a schema that you wish to use with many different database engines. Although primary key and (unique) index information will only be read from databases with DBIx::DBSchema::DBD drivers (currently MySQL and PostgreSQL), import of column names and attributes *should* work for any database. Note that this method only uses "ODBC" column types; it does not require or use an ODBC driver. =cut sub new_odbc { my($proto, $dbh) = ( shift, _dbh(@_) ); $proto->new( map { new_odbc DBIx::DBSchema::Table $dbh, $_ } _tables_from_dbh($dbh) ); } =item new_native DATABASE_HANDLE | DATA_SOURCE USERNAME PASSWORD [ ATTR ] Creates a new DBIx::DBSchema object from an existing data source, which can be specified by passing an open DBI database handle, or by passing the DBI data source name, username and password. This uses database-native methods to read the schema, and will preserve any non-portable column types. The method is only available if there is a DBIx::DBSchema::DBD for the corresponding database engine (currently, MySQL and PostgreSQL). =cut sub new_native { my($proto, $dbh) = (shift, _dbh(@_) ); $proto->new( map { new_native DBIx::DBSchema::Table ( $dbh, $_ ) } _tables_from_dbh($dbh) ); } =item load FILENAME Loads a DBIx::DBSchema object from a file. If there is an error, returns false and puts an error message in $DBIx::DBSchema::errstr; =cut sub load { my($proto,$file)=@_; #use $proto ? my $self; #first try Storable eval { $self = Storable::retrieve($file); }; if ( $@ && $@ =~ /not.*storable/i ) { #then try FreezeThaw my $olderror = $@; eval "use FreezeThaw;"; if ( $@ ) { $@ = $olderror; } else { open(FILE,"<$file") or do { $errstr = "Can't open $file: $!"; return ''; }; my $string = join('',); close FILE or do { $errstr = "Can't close $file: $!"; return ''; }; ($self) = FreezeThaw::thaw($string); } } unless ( $self ) { $errstr = $@; } $self; } =item save FILENAME Saves a DBIx::DBSchema object to a file. =cut sub save { #my($self, $file) = @_; Storable::nstore(@_); } =item addtable TABLE_OBJECT Adds the given DBIx::DBSchema::Table object to this DBIx::DBSchema. =cut sub addtable { my($self,$table)=@_; $self->{'tables'}->{$table->name} = $table; #check for dupliates? } =item tables Returns a list of the names of all tables. =cut sub tables { my($self)=@_; keys %{$self->{'tables'}}; } =item table TABLENAME Returns the specified DBIx::DBSchema::Table object. =cut sub table { my($self,$table)=@_; $self->{'tables'}->{$table}; } =item sql [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ] Returns a list of SQL `CREATE' statements for this schema. The data source can be specified by passing an open DBI database handle, or by passing the DBI data source name, username and password. Although the username and password are optional, it is best to call this method with a database handle or data source including a valid username and password - a DBI connection will be opened and used to check the database version as well as for more reliable quoting and type mapping. Note that the database connection will be used passively, B to actually run the CREATE statements. If passed a DBI data source (or handle) such as `DBI:mysql:database' or `DBI:Pg:dbname=database', will use syntax specific to that database engine. Currently supported databases are MySQL and PostgreSQL. If not passed a data source (or handle), or if there is no driver for the specified database, will attempt to use generic SQL syntax. =cut sub sql { my($self, $dbh) = ( shift, _dbh(@_) ); ( ( map { $self->table($_)->sql_create_table($dbh); } $self->tables ), ( map { $self->table($_)->sql_add_constraints($dbh); } $self->tables ), ); } =item sql_update_schema [ OPTIONS_HASHREF, ] PROTOTYPE_SCHEMA [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ] Returns a list of SQL statements to update this schema so that it is idential to the provided prototype schema, also a DBIx::DBSchema object. Right now this method knows how to add new tables and alter existing tables, including indices. If specifically requested by passing an options hashref with B set true before all other arguments, it will also drop tables. See L, L and L for additional specifics and limitations. The data source can be specified by passing an open DBI database handle, or by passing the DBI data source name, username and password. Although the username and password are optional, it is best to call this method with a database handle or data source including a valid username and password - a DBI connection will be opened and used to check the database version as well as for more reliable quoting and type mapping. Note that the database connection will be used passively, B to actually run the CREATE statements. If passed a DBI data source (or handle) such as `DBI:mysql:database' or `DBI:Pg:dbname=database', will use syntax specific to that database engine. Currently supported databases are MySQL and PostgreSQL. If not passed a data source (or handle), or if there is no driver for the specified database, will attempt to use generic SQL syntax. =cut #gosh, false laziness w/DBSchema::Table::sql_alter_schema sub sql_update_schema { my($self, $opt, $new, $dbh) = ( shift, _parse_opt(\@_), shift, _dbh(@_) ); my @r = (); my @later = (); foreach my $table ( $new->tables ) { if ( $self->table($table) ) { warn "$table exists\n" if $DEBUG > 1; push @r, $self->table($table)->sql_alter_table( $new->table($table), $dbh, $opt ); push @later, $self->table($table)->sql_alter_constraints( $new->table($table), $dbh, $opt ); } else { warn "table $table does not exist.\n" if $DEBUG; push @r, $new->table($table)->sql_create_table( $dbh ); push @later, $new->table($table)->sql_add_constraints( $dbh ); } } if ( $opt->{'drop_tables'} ) { warn "drop_tables enabled\n" if $DEBUG; # drop tables not in $new foreach my $table ( grep !$new->table($_), $self->tables ) { warn "table $table should be dropped.\n" if $DEBUG; push @r, $self->table($table)->sql_drop_table( $dbh ); } } push @r, @later; warn join("\n", @r). "\n" if $DEBUG > 1; @r; } =item update_schema [ OPTIONS_HASHREF, ] PROTOTYPE_SCHEMA, DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] Same as sql_update_schema, except actually runs the SQL commands to update the schema. Throws a fatal error if any statement fails. =cut sub update_schema { #my($self, $new, $dbh) = ( shift, shift, _dbh(@_) ); my($self, $opt, $new, $dbh) = ( shift, _parse_opt(\@_), shift, _dbh(@_) ); foreach my $statement ( $self->sql_update_schema( $opt, $new, $dbh ) ) { $dbh->do( $statement ) or die "Error: ". $dbh->errstr. "\n executing: $statement"; } } =item pretty_print Returns the data in this schema as Perl source, suitable for assigning to a hash. =cut sub pretty_print { my($self) = @_; join("},\n\n", map { my $tablename = $_; my $table = $self->table($tablename); my %indices = $table->indices; "'$tablename' => {\n". " 'columns' => [\n". join("", map { #cant because -w complains about , in qw() # (also biiiig problems with empty lengths) #" qw( $_ ". #$table->column($_)->type. " ". #( $table->column($_)->null ? 'NULL' : 0 ). " ". #$table->column($_)->length. " ),\n" " '$_', ". "'". $table->column($_)->type. "', ". "'". $table->column($_)->null. "', ". "'". $table->column($_)->length. "', ". ( ref($table->column($_)->default) ? "\\'". ${ $table->column($_)->default }. "'" : "'". $table->column($_)->default. "'" ).', '. "'". $table->column($_)->local. "',\n" } $table->columns ). " ],\n". " 'primary_key' => '". $table->primary_key. "',\n". #old style index representation.. ( $table->{'unique'} # $table->_unique ? " 'unique' => [ ". join(', ', map { "[ '". join("', '", @{$_}). "' ]" } @{$table->_unique->lol_ref} ). " ],\n" : '' ). ( $table->{'index'} # $table->_index ? " 'index' => [ ". join(', ', map { "[ '". join("', '", @{$_}). "' ]" } @{$table->_index->lol_ref} ). " ],\n" : '' ). #new style indices " 'indices' => { ". join( ",\n ", map { my $iname = $_; my $index = $indices{$iname}; "'$iname' => { \n". ( $index->using ? " 'using' => '". $index->using ."',\n" : '' ). " 'unique' => ". $index->unique .",\n". " 'columns' => [ '". join("', '", @{$index->columns} ). "' ],\n". " },\n"; } keys %indices ). "\n }, \n". #foreign_keys " 'foreign_keys' => [ ". join( ",\n ", map { my $name = $_->constraint; "'$name' => { \n". " },\n"; } $table->foreign_keys ). "\n ], \n" ; } $self->tables ). "}\n"; } =item pretty_read HASHREF This method is B recommended. If you need to load and save your schema to a file, see the L and L methods. Creates a schema as specified by a data structure such as that created by B method. =cut sub pretty_read { my($proto, $href) = @_; my $schema = $proto->new( map { my $tablename = $_; my $info = $href->{$tablename}; my @columns; while ( @{$info->{'columns'}} ) { push @columns, DBIx::DBSchema::Column->new( splice @{$info->{'columns'}}, 0, 6 ); } DBIx::DBSchema::Table->new({ 'name' => $tablename, 'primary_key' => $info->{'primary_key'}, 'columns' => \@columns, #indices 'indices' => [ map { my $idx_info = $info->{'indices'}{$_}; DBIx::DBSchema::Index->new({ 'name' => $_, #'using' => 'unique' => $idx_info->{'unique'}, 'columns' => $idx_info->{'columns'}, }); } keys %{ $info->{'indices'} } ], } ); } (keys %{$href}) ); } # private subroutines sub _tables_from_dbh { my($dbh) = @_; my $driver = _load_driver($dbh); my $db_catalog = scalar(eval "DBIx::DBSchema::DBD::$driver->default_db_catalog"); my $db_schema = scalar(eval "DBIx::DBSchema::DBD::$driver->default_db_schema"); my $sth = $dbh->table_info($db_catalog, $db_schema, '', 'TABLE') or die $dbh->errstr; #map { $_->{TABLE_NAME} } grep { $_->{TABLE_TYPE} eq 'TABLE' } # @{ $sth->fetchall_arrayref({ TABLE_NAME=>1, TABLE_TYPE=>1}) }; map { $_->[0] } grep { $_->[1] =~ /^TABLE$/i } @{ $sth->fetchall_arrayref([2,3]) }; } =back =head1 AUTHORS Ivan Kohler Charles Shapiro and Mitchell Friedman contributed the start of a Sybase driver. Daniel Hanks contributed the Oracle driver. Jesse Vincent contributed the SQLite driver and fixes to quiet down internal usage of the old API. Slaven Rezic contributed column and table dropping, Pg bugfixes and more. =head1 CONTRIBUTIONS Contributions are welcome! I'm especially keen on any interest in the top items/projects below under BUGS. =head1 REPOSITORY The code is available from our public git repository: git clone git://git.freeside.biz/DBIx-DBSchema.git Or on the web: http://freeside.biz/gitweb/?p=DBIx-DBSchema.git Or: http://freeside.biz/gitlist/DBIx-DBSchema.git =head1 COPYRIGHT Copyright (c) 2000-2007 Ivan Kohler Copyright (c) 2000 Mail Abuse Prevention System LLC Copyright (c) 2007-2015 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 AND TODO Multiple primary keys are not yet supported. 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 alternative to using pretty_print/pretty_read pretty_read is pretty ugly too. pretty_read should *not* create and pass in old-style unique/index indices 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. perhaps we should just get rid of pretty_read entirely. pretty_print is useful for debugging, but pretty_read is pretty bunk. =head1 SEE ALSO L, L, L, L, L, L, L, L =cut 1; DBIx-DBSchema-0.45/README0000644000175000017500000000245012475137253013202 0ustar ivanivanDBIx::DBSchema Copyright (c) 2000-2007 Ivan Kohler Copyright (c) 2000 Mail Abuse Prevention System LLC Copyright (c) 2007-2015 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. This module implements an OO-interface to database schemas. Using this module, 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 from different process. You can write SQL CREATE statements statements for different databases from a single source. You can 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 generic SQL syntax for other databases. Assistance adding support for other databases is welcomed. See the DBIx::DBSchema::DBD manpage, "Driver Writer's Guide and Base Class". To install: perl Makefile.PL make make test # nothing substantial yet make install Documentation will then be available via `man DBIx::DBSchema' or `perldoc DBIx::DBSchema'. Homepage: DBIx-DBSchema-0.45/DBSchema/0000755000175000017500000000000012522572660013725 5ustar ivanivanDBIx-DBSchema-0.45/DBSchema/Index.pm0000644000175000017500000000653711772176132015345 0ustar ivanivanpackage DBIx::DBSchema::Index; use strict; use vars qw($VERSION $DEBUG); $VERSION = 0.1; $DEBUG = 0; =head1 NAME DBIx::DBSchema::Index - Index objects =head1 SYNOPSYS use DBIx::DBSchema::Index; $index = new DBIx::DBSchema::Index ( { } ); =head1 DESCRIPTION DBIx::DBSchema::Index objects represent a unique or non-unique database index. =head1 METHODS =over 4 =item new HASHREF | OPTION, VALUE, ... Creates a new DBIx::DBschema::Index object. Accepts either a hashref or a list of options and values. Options are: =over 8 =item name - Index name =item using - Optional index method =item unique - Boolean indicating whether or not this is a unique index. =item columns - List reference of column names (or expressions) =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 name [ INDEX_NAME ] Returns or sets the index name. =cut sub name { my($self, $value) = @_; if ( defined($value) ) { $self->{name} = $value; } else { $self->{name}; } } =item using [ INDEX_METHOD ] Returns or sets the optional index method. =cut sub using { my($self, $value) = @_; if ( defined($value) ) { $self->{using} = $value; } else { defined($self->{using}) ? $self->{using} : ''; } } =item unique [ BOOL ] Returns or sets the unique flag. =cut sub unique { my($self, $value) = @_; if ( defined($value) ) { $self->{unique} = $value; } else { #$self->{unique}; $self->{unique} ? 1 : 0; } } =item columns [ LISTREF ] Returns or sets the indexed columns (or expressions). =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 sql_create_index TABLENAME Returns an SQL statment to create this index on the specified table. =cut sub sql_create_index { my( $self, $table ) = @_; my $unique = $self->unique ? 'UNIQUE' : ''; my $name = $self->name; my $col_sql = $self->columns_sql; "CREATE $unique INDEX $name ON $table ( $col_sql )"; } =item cmp OTHER_INDEX_OBJECT Compares this object to another supplied object. Returns true if they are identical, or false otherwise. =cut sub cmp { my( $self, $other ) = @_; $self->name eq $other->name and $self->cmp_noname($other); } =item cmp_noname OTHER_INDEX_OBJECT Compares this object to another supplied object. Returns true if they are identical, disregarding index name, or false otherwise. =cut sub cmp_noname { my( $self, $other ) = @_; $self->using eq $other->using and $self->unique == $other->unique and $self->columns_sql eq $other->columns_sql; } =back =head1 AUTHOR Ivan Kohler Copyright (c) 2007 Ivan Kohler Copyright (c) 2007 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 Is there any situation in which sql_create_index needs to return a list of multiple statements? =head1 SEE ALSO L, L, L =cut 1; DBIx-DBSchema-0.45/DBSchema/DBD.pm0000644000175000017500000001753012235402767014663 0ustar ivanivanpackage DBIx::DBSchema::DBD; use strict; our $VERSION = '0.08'; =head1 NAME DBIx::DBSchema::DBD - DBIx::DBSchema Driver Writer's Guide and Base Class =head1 SYNOPSIS perldoc DBIx::DBSchema::DBD package DBIx::DBSchema::DBD::FooBase use DBIx::DBSchema::DBD; @ISA = qw(DBIx::DBSchema::DBD); =head1 DESCRIPTION Drivers should be named DBIx::DBSchema::DBD::DatabaseName, where DatabaseName is the same as the DBD:: driver for this database. Drivers should implement the following class methods: =over 4 =item columns CLASS DBI_DBH TABLE Given an active DBI database handle, return a listref of listrefs (see L), each containing six elements: column name, column type, nullability, column length, column default, and a field reserved for driver-specific use. =item column CLASS DBI_DBH TABLE COLUMN Same as B above, except return the listref for a single column. You can inherit from DBIx::DBSchema::DBD to provide this function. =cut sub column { my($proto, $dbh, $table, $column) = @_; #@a = grep { $_->[0] eq $column } @{ $proto->columns( $dbh, $table ) }; #$a[0]; @{ [ grep { $_->[0] eq $column } @{ $proto->columns( $dbh, $table ) } ] }[0]; #force list context on grep, return scalar of first element } =item primary_key CLASS DBI_DBH TABLE Given an active DBI database handle, return the primary key for the specified table. =item unique CLASS DBI_DBH TABLE Deprecated method - see the B method for new drivers. Given an active DBI database handle, return a hashref of unique indices. The keys of the hashref are index names, and the values are arrayrefs which point a list of column names for each. See L and L. =item index CLASS DBI_DBH TABLE Deprecated method - see the B method for new drivers. Given an active DBI database handle, return a hashref of (non-unique) indices. The keys of the hashref are index names, and the values are arrayrefs which point a list of column names for each. See L and L. =item indices CLASS DBI_DBH TABLE Given an active DBI database handle, return a hashref of all indices, both unique and non-unique. The keys of the hashref are index names, and the values are again hashrefs with the following keys: =over 8 =item name - Index name (redundant) =item using - Optional index method =item unique - Boolean indicating whether or not this is a unique index =item columns - List reference of column names (or expressions) =back (See L) New drivers are advised to implement this method, and existing drivers are advised to (eventually) provide this method instead of B and B. For backwards-compatibility with current drivers, the base DBIx::DBSchema::DBD class provides an B method which uses the old B and B methods to provide this data. =cut sub indices { #my($proto, $dbh, $table) = @_; my($proto, @param) = @_; my $unique_hr = $proto->unique( @param ); my $index_hr = $proto->index( @param ); scalar( { ( map { $_ => { 'name' => $_, 'unique' => 1, 'columns' => $unique_hr->{$_}, }, } keys %$unique_hr ), ( map { $_ => { 'name' => $_, 'unique' => 0, 'columns' => $index_hr->{$_}, }, } keys %$index_hr ), } ); } =item default_db_catalog Returns the default database catalog for the DBI table_info command. Inheriting from DBIx::DBSchema::DBD will provide the default empty string. =cut sub default_db_catalog { ''; } =item default_db_schema Returns the default database schema for the DBI table_info command. Inheriting from DBIx::DBSchema::DBD will provide the default empty string. =cut 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. Should return a hash reference, empty for no action, or with one or more of the following keys defined: effective_type - Optional type override used during column creation. explicit_null - Set true to have the column definition declare NULL columns explicitly effective_default - Optional default override used during column creation. effective_local - Optional local override used during column creation. =cut sub column_callback { {}; } =item add_column_callback DBH TABLE_NAME COLUMN_OBJ Optional callback for additional SQL statments to be called when adding columns to an existing table. Should return a hash reference, empty for no action, or with one or more of the following keys defined: effective_type - Optional type override used during column creation. effective_null - Optional nullability override used during column creation. sql_after - Array reference of SQL statements to be executed after the column is added. =cut sub add_column_callback { {}; } =item alter_column_callback DBH TABLE_NAME OLD_COLUMN_OBJ NEW_COLUMN_OBJ Optional callback for overriding the SQL statments to be called when altering columns to an existing table. Should return a hash reference, empty for no action, or with one or more of the following keys defined: sql_alter - Alter SQL statement(s) for changing everything about a column. Specifying this overrides processing of individual changes (type, nullability, default, etc.). sql_alter_type - Alter SQL statement(s) for changing type and length (there is no default). sql_alter_null - Alter SQL statement(s) for changing nullability to be used instead of the default. =cut sub alter_column_callback { {}; } =item column_value_needs_quoting COLUMN_OBJ Optional callback for determining if a column's default value require quoting. Returns true if it does, false otherwise. =cut sub column_value_needs_quoting { my($proto, $col) = @_; my $class = ref($proto) || $proto; # type mapping my %typemap = eval "\%${class}::typemap"; my $type = defined( $typemap{uc($col->type)} ) ? $typemap{uc($col->type)} : $col->type; # false laziness: nicked from FS::Record::_quote $col->default !~ /^\-?\d+(\.\d+)?$/ || $type =~ /(char|binary|blob|text)$/i; } =back =head1 TYPE MAPPING You can define a %typemap array for your driver to map "standard" data types to database-specific types. For example, the MySQL TIMESTAMP field has non-standard auto-updating semantics; the MySQL DATETIME type is what other databases and the ODBC standard call TIMESTAMP, so one of the entries in the MySQL %typemap is: 'TIMESTAMP' => 'DATETIME', Another example is the Pg %typemap which maps the standard types BLOB and LONG VARBINARY to the Pg-specific BYTEA: 'BLOB' => 'BYTEA', 'LONG VARBINARY' => 'BYTEA', Make sure you use all uppercase-keys. =head1 AUTHOR Ivan Kohler =head1 COPYRIGHT Copyright (c) 2000-2005 Ivan Kohler 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. =head1 BUGS =head1 SEE ALSO L, L, L, L, L, L, L, L =cut 1; DBIx-DBSchema-0.45/DBSchema/DBD/0000755000175000017500000000000012522572660014316 5ustar ivanivanDBIx-DBSchema-0.45/DBSchema/DBD/Oracle.pm0000644000175000017500000000640011772176132016061 0ustar ivanivanpackage DBIx::DBSchema::DBD::Oracle; use strict; use vars qw($VERSION @ISA %typemap); use DBIx::DBSchema::DBD; $VERSION = '0.01'; @ISA = qw(DBIx::DBSchema::DBD); %typemap = ( 'VARCHAR' => 'VARCHAR2', 'SERIAL' => 'INTEGER', 'LONG VARBINARY' => 'BLOB', 'TIMESTAMP' => 'DATE', 'BOOL' => 'INTEGER' ); =head1 NAME DBIx::DBSchema::DBD::Oracle - Oracle native driver for DBIx::DBSchema =head1 SYNOPSIS use DBI; use DBIx::DBSchema; $dbh = DBI->connect('dbi:Oracle:tns_service_name', 'user','pass'); $schema = new_native DBIx::DBSchema $dbh; =head1 DESCRIPTION This module implements a Oracle-native driver for DBIx::DBSchema. =head1 AUTHOR Daniel Hanks =cut ### Return column name, column type, nullability, column length, column default, ### and a field reserved for driver-specific use sub columns { my ($proto, $dbh, $table) = @_; return $proto->_column_info($dbh, $table); } sub column { my ($proto, $dbh, $table, $column) = @_; return $proto->_column_info($dbh, $table, $column); } sub _column_info { my ($proto, $dbh, $table, $column) = @_; my $sql = "SELECT column_name, data_type, CASE WHEN nullable = 'Y' THEN 1 WHEN nullable = 'N' THEN 0 ELSE 1 END AS nullable, data_length, data_default, NULL AS reserved FROM user_tab_columns WHERE table_name = ?"; $sql .= " AND column_name = ?" if defined($column); if(defined($column)) { return $dbh->selectrow_arrayref($sql, undef, $table, $column); } else { ### Assume columns return $dbh->selectall_arrayref($sql, undef, $table); } } ### This is broken. Primary keys can be comprised of any subset of a tables ### fields, not just one field, as this module assumes. sub primary_key { my ($proto, $dbh, $table) = @_; my $sql = "SELECT column_name FROM user_constraints uc, user_cons_columns ucc WHERE uc.constraint_name = ucc.constraint_name AND uc.constraint_type = 'P' AND uc.table_name = ?"; my ($key) = $dbh->selectrow_array($sql, undef, $table); return $key; } ### Wraoper around _index_info sub unique { my ($proto, $dbh, $table) = @_; return $proto->_index_info($dbh, $table, 'UNIQUE'); } ### Wrapper around _index_info sub index { my ($proto, $dbh, $table) = @_; return $proto->_index_info($dbh, $table, 'NONUNIQUE'); } ### Collect info about unique or non-unique indexes ### $type must be 'UNIQUE' or 'NONUNIQUE' sub _index_info { my ($proto, $dbh, $table, $type) = @_; ### Sanity-check die "\$type must be 'UNIQUE' or 'NONUNIQUE'" unless $type =~ /^(NON)?UNIQUE$/; ### Set up the query my $sql = "SELECT ui.index_name, uic.column_name FROM user_indexes ui, user_ind_columns uic WHERE ui.index_name = uic.index_name AND ui.uniqueness = ? AND table_name = ?"; my $sth = $dbh->prepare($sql); $sth->execute($table, $type); ### Now collect the results my $results = {}; while(my ($idx, $col) = $sth->fetchrow_array()) { if(!exists($results->{$idx})) { $results->{$idx} = []; } push @{$results->{$idx}}, $col; } return $results; } DBIx-DBSchema-0.45/DBSchema/DBD/mysql.pm0000644000175000017500000001261212272310360016010 0ustar ivanivanpackage DBIx::DBSchema::DBD::mysql; use strict; use vars qw($VERSION @ISA %typemap); use DBIx::DBSchema::DBD; $VERSION = '0.09'; @ISA = qw(DBIx::DBSchema::DBD); %typemap = ( 'TIMESTAMP' => 'DATETIME', 'SERIAL' => 'INTEGER', 'BIGSERIAL' => 'BIGINT', 'BOOL' => 'TINYINT', 'LONG VARBINARY' => 'LONGBLOB', 'TEXT' => 'LONGTEXT', ); =head1 NAME DBIx::DBSchema::DBD::mysql - MySQL native driver for DBIx::DBSchema =head1 SYNOPSIS use DBI; use DBIx::DBSchema; $dbh = DBI->connect('dbi:mysql:database', 'user', 'pass'); $schema = new_native DBIx::DBSchema $dbh; =head1 DESCRIPTION This module implements a MySQL-native driver for DBIx::DBSchema. =cut use Data::Dumper; sub columns { my($proto, $dbh, $table ) = @_; my $oldkhv=$dbh->{FetchHashKeyName}; $dbh->{FetchHashKeyName}="NAME"; my $sth = $dbh->prepare("SHOW COLUMNS FROM $table") or die $dbh->errstr; $sth->execute or die $sth->errstr; my @r = map { #warn Dumper($_); $_->{'Type'} =~ /^(\w+)\(?([^)]+)?\)?( \d+)?$/ or die "Illegal type: ". $_->{'Type'}. "\n"; my($type, $length) = ($1, $2); my $default = $_->{'Default'}; if ( defined($default) ) { $default = \"''" if $default eq ''; $default = \0 if $default eq '0'; $default = \'NOW()' if uc($default) eq 'CURRENT_TIMESTAMP'; } else { $default = ''; } [ $_->{'Field'}, $type, ( $_->{'Null'} =~ /^YES$/i ? 'NULL' : '' ), $length, $default, $_->{'Extra'} ] } @{ $sth->fetchall_arrayref( {} ) }; $dbh->{FetchHashKeyName}=$oldkhv; @r; } #sub primary_key { # my($proto, $dbh, $table ) = @_; # my $primary_key = ''; # my $sth = $dbh->prepare("SHOW INDEX FROM $table") # or die $dbh->errstr; # $sth->execute or die $sth->errstr; # my @pkey = map { $_->{'Column_name'} } grep { # $_->{'Key_name'} eq "PRIMARY" # } @{ $sth->fetchall_arrayref( {} ) }; # scalar(@pkey) ? $pkey[0] : ''; #} sub primary_key { my($proto, $dbh, $table) = @_; my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table); $pkey; } sub unique { my($proto, $dbh, $table) = @_; my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table); $unique_href; } sub index { my($proto, $dbh, $table) = @_; my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table); $index_href; } sub _show_index { my($proto, $dbh, $table ) = @_; my $oldkhv=$dbh->{FetchHashKeyName}; $dbh->{FetchHashKeyName}="NAME"; my $sth = $dbh->prepare("SHOW INDEX FROM $table") or die $dbh->errstr; $sth->execute or die $sth->errstr; my $pkey = ''; my(%index, %unique); foreach my $row ( @{ $sth->fetchall_arrayref({}) } ) { if ( $row->{'Key_name'} eq 'PRIMARY' ) { $pkey = $row->{'Column_name'}; } elsif ( $row->{'Non_unique'} ) { #index push @{ $index{ $row->{'Key_name'} } }, $row->{'Column_name'}; } else { #unique push @{ $unique{ $row->{'Key_name'} } }, $row->{'Column_name'}; } } $dbh->{FetchHashKeyName}=$oldkhv; ( $pkey, \%unique, \%index ); } sub column_callback { my( $proto, $dbh, $table, $column_obj ) = @_; my $hashref = { 'explicit_null' => 1, }; $hashref->{'effective_local'} = 'AUTO_INCREMENT' if $column_obj->type =~ /^(\w*)SERIAL$/i; if ( $column_obj->quoted_default =~ /^(NOW)\(\)$/i && $column_obj->type =~ /^(TIMESTAMP|DATETIME)$/i ) { $hashref->{'effective_default'} = 'CURRENT_TIMESTAMP'; $hashref->{'effective_type'} = 'TIMESTAMP'; } # MySQL no longer supports defaults for text/blob columns if ( $column_obj->type =~ /(TEXT|BLOB)/i and defined $column_obj->default ) { # There's no way to unset the default cleanly. # An empty string isn't quite right. $column_obj->{'default'} = undef; } $hashref; } sub alter_column_callback { my( $proto, $dbh, $table, $old_column, $new_column ) = @_; my $old_name = $old_column->name; my $new_def = $new_column->line($dbh); my $hashref = {}; my %canonical = ( 'INTEGER' => 'INT', 'SERIAL' => 'INT', 'BIGSERIAL' => 'BIGINT', 'REAL' => 'DOUBLE', #'FLOAT', 'DOUBLE PRECISION' => 'DOUBLE', ); foreach ($old_column, $new_column) { $_->type($canonical{uc($_->type)}) if $canonical{uc($_->type)}; } my %canonical_length = ( 'INT' => 11, 'BIGINT' => 20, 'DECIMAL' => '10,0', ); $new_column->length( $canonical_length{uc($new_column->type)} ) if $canonical_length{uc($new_column->type)} && ($new_column->length||'') eq ''; #change type/length if ( uc($old_column->type) ne uc($new_column->type) || ($old_column->length||'') ne ($new_column->length||'') ) { my $old_def = $old_column->line($dbh); $hashref->{'sql_alter_type'} = "CHANGE $old_name $new_def"; } #change nullability if ( $old_column->null ne $new_column->null ) { $hashref->{'sql_alter_null'} = "ALTER TABLE $table MODIFY $new_def"; } $hashref; } =head1 AUTHOR Ivan Kohler =head1 COPYRIGHT Copyright (c) 2000 Ivan Kohler Copyright (c) 2000 Mail Abuse Prevention System LLC 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. =head1 BUGS =head1 SEE ALSO L, L, L, L =cut 1; DBIx-DBSchema-0.45/DBSchema/DBD/Pg.pm0000644000175000017500000002606512522572307015231 0ustar ivanivanpackage DBIx::DBSchema::DBD::Pg; use base qw(DBIx::DBSchema::DBD); use strict; use DBD::Pg 1.41; our $VERSION = '0.20'; our %typemap = ( 'BLOB' => 'BYTEA', 'LONG VARBINARY' => 'BYTEA', 'TIMESTAMP' => 'TIMESTAMP WITH TIME ZONE', ); =head1 NAME DBIx::DBSchema::DBD::Pg - PostgreSQL native driver for DBIx::DBSchema =head1 SYNOPSIS use DBI; use DBIx::DBSchema; $dbh = DBI->connect('dbi:Pg:dbname=database', 'user', 'pass'); $schema = new_native DBIx::DBSchema $dbh; =head1 DESCRIPTION This module implements a PostgreSQL-native driver for DBIx::DBSchema. =cut sub default_db_schema { 'public'; } sub columns { my($proto, $dbh, $table) = @_; my $sth = $dbh->prepare(<errstr; SELECT a.attname, t.typname, a.attlen, a.atttypmod, a.attnotnull, a.atthasdef, a.attnum FROM pg_class c, pg_attribute a, pg_type t WHERE c.relname = '$table' AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid ORDER BY a.attnum END $sth->execute or die $sth->errstr; map { my $type = $_->{'typname'}; $type = 'char' if $type eq 'bpchar'; my $len = ''; if ( $_->{attlen} == -1 && $_->{atttypmod} != -1 && $_->{typname} ne 'text' ) { $len = $_->{atttypmod} - 4; if ( $_->{typname} eq 'numeric' ) { $len = ($len >> 16). ','. ($len & 0xffff); } } my $default = ''; if ( $_->{atthasdef} ) { my $attnum = $_->{attnum}; my $d_sth = $dbh->prepare(<errstr; SELECT substring(d.adsrc for 128) FROM pg_attrdef d, pg_class c WHERE c.relname = '$table' AND c.oid = d.adrelid AND d.adnum = $attnum END $d_sth->execute or die $d_sth->errstr; $default = $d_sth->fetchrow_arrayref->[0]; if ( _type_needs_quoting($type) ) { $default =~ s/::([\w ]+)$//; #save typecast info? if ( $default =~ /^'(.*)'$/ ) { $default = $1; $default = \"''" if $default eq ''; } else { my $value = $default; $default = \$value; } } elsif ( $default =~ /^[a-z]/i ) { #sloppy, but it'll do my $value = $default; $default = \$value; } } [ $_->{'attname'}, $type, ! $_->{'attnotnull'}, $len, $default, '' #local ]; } @{ $sth->fetchall_arrayref({}) }; } sub primary_key { my($proto, $dbh, $table) = @_; my $sth = $dbh->prepare(<errstr; SELECT a.attname, a.attnum FROM pg_class c, pg_attribute a, pg_type t WHERE c.relname = '${table}_pkey' AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid END $sth->execute or die $sth->errstr; my $row = $sth->fetchrow_hashref or return ''; $row->{'attname'}; } sub unique { my($proto, $dbh, $table) = @_; my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] } grep { $proto->_is_unique($dbh, $_ ) } $proto->_all_indices($dbh, $table) }; } sub index { my($proto, $dbh, $table) = @_; my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] } grep { ! $proto->_is_unique($dbh, $_ ) } $proto->_all_indices($dbh, $table) }; } sub _all_indices { my($proto, $dbh, $table) = @_; my $sth = $dbh->prepare(<errstr; SELECT c2.relname FROM pg_class c, pg_class c2, pg_index i WHERE c.relname = '$table' AND c.oid = i.indrelid AND i.indexrelid = c2.oid END $sth->execute or die $sth->errstr; map { $_->{'relname'} } grep { $_->{'relname'} !~ /_pkey$/ } @{ $sth->fetchall_arrayref({}) }; } sub _index_fields { my($proto, $dbh, $index) = @_; my $sth = $dbh->prepare(<errstr; SELECT a.attname, a.attnum FROM pg_class c, pg_attribute a, pg_type t WHERE c.relname = '$index' AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid ORDER BY a.attnum END $sth->execute or die $sth->errstr; map { $_->{'attname'} } @{ $sth->fetchall_arrayref({}) }; } sub _is_unique { my($proto, $dbh, $index) = @_; my $sth = $dbh->prepare(<errstr; SELECT i.indisunique FROM pg_index i, pg_class c, pg_am a WHERE i.indexrelid = c.oid AND c.relname = '$index' AND c.relam = a.oid END $sth->execute or die $sth->errstr; my $row = $sth->fetchrow_hashref or die 'guru meditation #420'; $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*(.*)$/i or die "unparsable constraint: ". $_->{condef}; my($columns, $table, $references, $etc ) = ($1, $2, $3, $4); my $match = ( $etc =~ /MATCH (\w+)/i ) ? "MATCH $1" : ''; my $on_delete = ( $etc =~ /ON DELETE ((NO |SET )?\w+)/i ) ? $1 : ''; my $on_update = ( $etc =~ /ON UPDATE ((NO |SET )?\w+)/i ) ? $1 : ''; +{ 'constraint' => $_->{conname}, 'columns' => [ split(/,\s*/, $columns) ], 'table' => $table, 'references' => [ split(/,\s*/, $references) ], 'match' => $match, 'on_delete' => $on_delete, 'on_update' => $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; my $pg_server_version = $dbh->{'pg_server_version'}; my $warning = ''; unless ( $pg_server_version =~ /\d/ ) { $warning = "WARNING: no pg_server_version! Assuming >= 7.3\n"; $pg_server_version = 70300; } my $hashref = { 'sql_after' => [], }; if ( $column_obj->type =~ /^(\w*)SERIAL$/i ) { $hashref->{'effective_type'} = uc($1).'INT'; #needs more work for old Pg? my $nextval; warn $warning if $warning; if ( $pg_server_version >= 70300 ) { my $db_schema = default_db_schema(); $nextval = "nextval('$db_schema.${table}_${name}_seq'::text)"; } else { $nextval = "nextval('${table}_${name}_seq'::text)"; } push @{ $hashref->{'sql_after'} }, "ALTER TABLE $table ALTER COLUMN $name SET DEFAULT $nextval", "CREATE SEQUENCE ${table}_${name}_seq", "UPDATE $table SET $name = $nextval WHERE $name IS NULL", ; } if ( ! $column_obj->null ) { $hashref->{'effective_null'} = 'NULL'; warn $warning if $warning; if ( $pg_server_version >= 70300 ) { push @{ $hashref->{'sql_after'} }, "ALTER TABLE $table ALTER $name SET NOT NULL"; } else { push @{ $hashref->{'sql_after'} }, "UPDATE pg_attribute SET attnotnull = TRUE ". " WHERE attname = '$name' ". " AND attrelid = ( SELECT oid FROM pg_class WHERE relname = '$table' )"; } } $hashref; } sub alter_column_callback { my( $proto, $dbh, $table, $old_column, $new_column ) = @_; my $name = $old_column->name; my %canonical = ( 'SMALLINT' => 'INT2', 'INT' => 'INT4', 'BIGINT' => 'INT8', 'SERIAL' => 'INT4', 'BIGSERIAL' => 'INT8', 'DECIMAL' => 'NUMERIC', 'REAL' => 'FLOAT4', 'DOUBLE PRECISION' => 'FLOAT8', 'BLOB' => 'BYTEA', 'TIMESTAMP' => 'TIMESTAMPTZ', ); foreach ($old_column, $new_column) { $_->type($canonical{uc($_->type)}) if $canonical{uc($_->type)}; } my $pg_server_version = $dbh->{'pg_server_version'}; my $warning = ''; unless ( $pg_server_version =~ /\d/ ) { $warning = "WARNING: no pg_server_version! Assuming >= 7.3\n"; $pg_server_version = 70300; } my $hashref = {}; #change type if ( ( $canonical{uc($old_column->type)} || uc($old_column->type) ) ne ( $canonical{uc($new_column->type)} || uc($new_column->type) ) || $old_column->length ne $new_column->length ) { warn $warning if $warning; if ( $pg_server_version >= 80000 ) { $hashref->{'sql_alter_type'} = "ALTER COLUMN ". $new_column->name. " TYPE ". $new_column->type. ( ( defined($new_column->length) && $new_column->length ) ? '('.$new_column->length.')' : '' ) } else { warn "WARNING: can't yet change column types for Pg < version 8\n"; } } # change nullability from NOT NULL to NULL if ( ! $old_column->null && $new_column->null ) { warn $warning if $warning; if ( $pg_server_version < 70300 ) { $hashref->{'sql_alter_null'} = "UPDATE pg_attribute SET attnotnull = FALSE WHERE attname = '$name' AND attrelid = ( SELECT oid FROM pg_class WHERE relname = '$table' )"; } } # change nullability from NULL to NOT NULL... # this one could be more complicated, need to set a DEFAULT value and update # the table first... if ( $old_column->null && ! $new_column->null ) { warn $warning if $warning; if ( $pg_server_version < 70300 ) { $hashref->{'sql_alter_null'} = "UPDATE pg_attribute SET attnotnull = TRUE WHERE attname = '$name' AND attrelid = ( SELECT oid FROM pg_class WHERE relname = '$table' )"; } } $hashref; } sub column_value_needs_quoting { my($proto, $col) = @_; _type_needs_quoting($col->type); } sub _type_needs_quoting { my $type = shift; $type !~ m{^( int(?:2|4|8)? | smallint | integer | bigint | (?:numeric|decimal)(?:\(\d+(?:\s*\,\s*\d+\))?)? | real | double\s+precision | float(?:\(\d+\))? | serial(?:4|8)? | bigserial )$}ix; } =head1 AUTHOR Ivan Kohler =head1 COPYRIGHT Copyright (c) 2000 Ivan Kohler Copyright (c) 2000 Mail Abuse Prevention System LLC Copyright (c) 2009-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 columns doesn't return column default information. =head1 SEE ALSO L, L, L, L =cut 1; DBIx-DBSchema-0.45/DBSchema/DBD/Sybase.pm0000755000175000017500000000560312332112366016101 0ustar ivanivanpackage DBIx::DBSchema::DBD::Sybase; use strict; use vars qw($VERSION @ISA %typemap); use DBIx::DBSchema::DBD; $VERSION = '0.03'; @ISA = qw(DBIx::DBSchema::DBD); %typemap = ( # 'empty' => 'empty' ); =head1 NAME DBIx::DBSchema::DBD::Sybase - Sybase database driver for DBIx::DBSchema =head1 SYNOPSIS use DBI; use DBIx::DBSchema; $dbh = DBI->connect('dbi:Sybase:dbname=database', 'user', 'pass'); $schema = new_native DBIx::DBSchema $dbh; =head1 DESCRIPTION This module implements a Sybase driver for DBIx::DBSchema. =cut sub columns { my($proto, $dbh, $table) = @_; my $sth = $dbh->prepare("sp_columns \@table_name=$table") or die $dbh->errstr; $sth->execute or die $sth->errstr; my @cols = map { [ $_->{'column_name'}, $_->{'type_name'}, ($_->{'nullable'} ? 1 : ''), $_->{'length'}, '', #default '' #local ] } @{ $sth->fetchall_arrayref({}) }; $sth->finish; @cols; } sub primary_key { return("StubbedPrimaryKey"); } sub unique { my($proto, $dbh, $table) = @_; my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $table, $_ ) ] } grep { $proto->_is_unique($dbh, $_ ) } $proto->_all_indices($dbh, $table) }; } sub index { my($proto, $dbh, $table) = @_; my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $table, $_ ) ] } grep { ! $proto->_is_unique($dbh, $_ ) } $proto->_all_indices($dbh, $table) }; } sub _all_indices { my($proto, $dbh, $table) = @_; my $sth = $dbh->prepare_cached(<errstr; SELECT name FROM sysindexes WHERE id = object_id('$table') and indid between 1 and 254 END $sth->execute or die $sth->errstr; my @indices = map { $_->[0] } @{ $sth->fetchall_arrayref() }; $sth->finish; $sth = undef; @indices; } sub _index_fields { my($proto, $dbh, $table, $index) = @_; my @keys; my ($indid) = $dbh->selectrow_array("select indid from sysindexes where id = object_id('$table') and name = '$index'"); for (1..30) { push @keys, $dbh->selectrow_array("select index_col('$table', $indid, $_)") || (); } return @keys; } sub _is_unique { my($proto, $dbh, $table, $index) = @_; my ($isunique) = $dbh->selectrow_array("select status & 2 from sysindexes where id = object_id('$table') and name = '$index'"); return $isunique; } =head1 AUTHOR Charles Shapiro (courtesy of Ivan Kohler ) Mitchell Friedman Bernd Dulfer =head1 COPYRIGHT Copyright (c) 2001 Charles Shapiro, Mitchell J. Friedman Copyright (c) 2001 nuMethods LLC. 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 Yes. The B method does not yet work. =head1 SEE ALSO L, L, L, L =cut 1; DBIx-DBSchema-0.45/DBSchema/DBD/SQLite.pm0000644000175000017500000000767412522567652016040 0ustar ivanivanpackage DBIx::DBSchema::DBD::SQLite; use base qw( DBIx::DBSchema::DBD ); use strict; use vars qw($VERSION %typemap); $VERSION = '0.03'; %typemap = ( 'SERIAL' => 'INTEGER PRIMARY KEY AUTOINCREMENT', ); =head1 NAME DBIx::DBSchema::DBD::SQLite - SQLite native driver for DBIx::DBSchema =head1 SYNOPSIS use DBI; use DBIx::DBSchema; $dbh = DBI->connect('dbi:SQLite:tns_service_name', 'user','pass'); $schema = new_native DBIx::DBSchema $dbh; =head1 DESCRIPTION This module implements a SQLite-native driver for DBIx::DBSchema. =head1 AUTHOR Jesse Vincent =cut =head1 API =over =item columns CLASS DBI_DBH TABLE Given an active DBI database handle, return a listref of listrefs (see L), each containing six elements: column name, column type, nullability, column length, column default, and a field reserved for driver-specific use (which for sqlite is whether this col is a primary key) =cut sub columns { my ( $proto, $dbh, $table ) = @_; my $sth = $dbh->prepare("PRAGMA table_info($table)"); $sth->execute(); my $rows = []; while ( my $row = $sth->fetchrow_hashref ) { # notnull # pk # name # type # cid # dflt_value push @$rows, [ $row->{'name'}, $row->{'type'}, ( $row->{'notnull'} ? 0 : 1 ), undef, $row->{'dflt_value'}, $row->{'pk'} ]; } return $rows; } =item primary_key CLASS DBI_DBH TABLE Given an active DBI database handle, return the primary key for the specified table. =cut sub primary_key { my ($proto, $dbh, $table) = @_; my $cols = $proto->columns($dbh,$table); foreach my $col (@$cols) { return ($col->[1]) if ($col->[5]); } return undef; } =item unique CLASS DBI_DBH TABLE Given an active DBI database handle, return a hashref of unique indices. The keys of the hashref are index names, and the values are arrayrefs which point a list of column names for each. See L and L. =cut sub unique { my ($proto, $dbh, $table) = @_; my @names; my $indexes = $proto->_index_info($dbh, $table); foreach my $row (@$indexes) { push @names, $row->{'name'} if ($row->{'unique'}); } my $info = {}; foreach my $name (@names) { $info->{'name'} = $proto->_index_cols($dbh, $name); } return $info; } =item index CLASS DBI_DBH TABLE Given an active DBI database handle, return a hashref of (non-unique) indices. The keys of the hashref are index names, and the values are arrayrefs which point a list of column names for each. See L and L. =cut sub index { my ($proto, $dbh, $table) = @_; my @names; my $indexes = $proto->_index_info($dbh, $table); foreach my $row (@$indexes) { push @names, $row->{'name'} if not ($row->{'unique'}); } my $info = {}; foreach my $name (@names) { $info->{'name'} = $proto->_index_cols($dbh, $name); } return $info; } sub _index_list { my $proto = shift; my $dbh = shift; my $table = shift; my $sth = $dbh->prepare('PRAGMA index_list($table)'); $sth->execute(); my $rows = []; while ( my $row = $sth->fetchrow_hashref ) { # Keys are "name" and "unique" push @$rows, $row; } return $rows; } sub _index_cols { my $proto = shift; my $dbh = shift; my $index = shift; my $sth = $dbh->prepare('PRAGMA index_info($index)'); $sth->execute(); my $data = {}; while ( my $row = $sth->fetchrow_hashref ) { # Keys are "name" and "seqno" $data->{$row->{'seqno'}} = $data->{'name'}; } my @results; foreach my $key (sort keys %$data) { push @results, $data->{$key}; } return \@results; } =pod =back =cut 1; DBIx-DBSchema-0.45/DBSchema/_util.pm0000644000175000017500000000206311772176132015400 0ustar ivanivan# internal utility subroutines used by multiple classes package DBIx::DBSchema::_util; use strict; use vars qw(@ISA @EXPORT_OK); use Exporter; use Carp qw(confess); use DBI; @ISA = qw(Exporter); @EXPORT_OK = qw( _load_driver _dbh _parse_opt ); sub _load_driver { my($dbh) = @_; my $driver; if ( ref($dbh) ) { $driver = $dbh->{Driver}->{Name}; } else { $dbh =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i #nicked from DBI->connect or '' =~ /()/; # ensure $1 etc are empty if match fails $driver = $1 or confess "can't parse data source: $dbh"; } #require "DBIx/DBSchema/DBD/$driver.pm"; #$driver; eval 'require "DBIx/DBSchema/DBD/$driver.pm"' and $driver or die $@; } #sub _dbh_or_dbi_connect_args { sub _dbh { my($dbh) = shift; my $created_dbh = 0; unless ( ref($dbh) || ! @_ ) { $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr; $created_dbh = 1; } ( $dbh, $created_dbh ); } sub _parse_opt { my $optref = shift; if ( ref( $optref->[0] ) eq 'HASH' ) { shift @$optref; } else { {}; } } 1; DBIx-DBSchema-0.45/DBSchema/Column.pm0000644000175000017500000003263512233023215015513 0ustar ivanivanpackage DBIx::DBSchema::Column; use strict; use vars qw($VERSION); use Carp; use DBIx::DBSchema::_util qw(_load_driver _dbh _parse_opt); $VERSION = '0.14'; =head1 NAME DBIx::DBSchema::Column - Column objects =head1 SYNOPSIS use DBIx::DBSchema::Column; #named params with a hashref (preferred) $column = new DBIx::DBSchema::Column ( { 'name' => 'column_name', 'type' => 'varchar' 'null' => 'NOT NULL', 'length' => 64, 'default' => '', 'local' => '', } ); #list $column = new DBIx::DBSchema::Column ( $name, $sql_type, $nullability, $length, $default, $local ); $name = $column->name; $column->name( 'name' ); $sql_type = $column->type; $column->type( 'sql_type' ); $null = $column->null; $column->null( 'NULL' ); $column->null( 'NOT NULL' ); $column->null( '' ); $length = $column->length; $column->length( '10' ); $column->length( '8,2' ); $default = $column->default; $column->default( 'Roo' ); $sql_line = $column->line; $sql_line = $column->line($datasrc); $sql_add_column = $column->sql_add_column; $sql_add_column = $column->sql_add_column($datasrc); =head1 DESCRIPTION DBIx::DBSchema::Column objects represent columns in tables (see L). =head1 METHODS =over 4 =item new HASHREF =item new [ name [ , type [ , null [ , length [ , default [ , local ] ] ] ] ] ] Creates a new DBIx::DBSchema::Column object. Takes a hashref of named parameters, or a list. B is the name of the column. B is the SQL data type. B is the nullability of the column (intrepreted using Perl's rules for truth, with one exception: `NOT NULL' is false). B is the SQL length of the column. B is the default value of the column. B is reserved for database-specific information. Note: If you pass a scalar reference as the B rather than a scalar value, it will be dereferenced and quoting will be forced off. This can be used to pass SQL functions such as C or explicit empty strings as C<''> as defaults. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self; if ( ref($_[0]) ) { $self = shift; } else { #carp "Old-style $class creation without named parameters is deprecated!"; #croak "FATAL: old-style $class creation no longer supported;". # " use named parameters"; $self = { map { $_ => shift } qw(name type null length default local) }; } #croak "Illegal name: ". $self->{'name'} # if grep $self->{'name'} eq $_, @reserved_words; $self->{'null'} =~ s/^NOT NULL$//i; $self->{'null'} = 'NULL' if $self->{'null'}; bless ($self, $class); } =item name [ NAME ] Returns or sets the column name. =cut sub name { my($self,$value)=@_; if ( defined($value) ) { #croak "Illegal name: $name" if grep $name eq $_, @reserved_words; $self->{'name'} = $value; } else { $self->{'name'}; } } =item type [ TYPE ] Returns or sets the column type. =cut sub type { my($self,$value)=@_; if ( defined($value) ) { $self->{'type'} = $value; } else { $self->{'type'}; } } =item null [ NULL ] Returns or sets the column null flag (the empty string is equivalent to `NOT NULL') =cut sub null { my($self,$value)=@_; if ( defined($value) ) { $value =~ s/^NOT NULL$//i; $value = 'NULL' if $value; $self->{'null'} = $value; } else { $self->{'null'}; } } =item length [ LENGTH ] Returns or sets the column length. =cut sub length { my($self,$value)=@_; if ( defined($value) ) { $self->{'length'} = $value; } else { $self->{'length'}; } } =item default [ LOCAL ] Returns or sets the default value. =cut sub default { my($self,$value)=@_; if ( defined($value) ) { $self->{'default'} = $value; } else { $self->{'default'}; } } =item local [ LOCAL ] Returns or sets the database-specific field. =cut sub local { my($self,$value)=@_; if ( defined($value) ) { $self->{'local'} = $value; } else { $self->{'local'}; } } =item table_obj [ TABLE_OBJ ] Returns or sets the table object (see L). Typically set internally when a column object is added to a table object. =cut sub table_obj { my($self,$value)=@_; if ( defined($value) ) { $self->{'table_obj'} = $value; } else { $self->{'table_obj'}; } } =item table_name Returns the table name, or the empty string if this column has not yet been assigned to a table. =cut sub table_name { my $self = shift; $self->{'table_obj'} ? $self->{'table_obj'}->name : ''; } =item line [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ] Returns an SQL column definition. The data source can be specified by passing an open DBI database handle, or by passing the DBI data source name, username and password. Although the username and password are optional, it is best to call this method with a database handle or data source including a valid username and password - a DBI connection will be opened and the quoting and type mapping will be more reliable. If passed a DBI data source (or handle) such as `DBI:mysql:database' or `DBI:Pg:dbname=database', will use syntax specific to that database engine. Currently supported databases are MySQL and PostgreSQL. Non-standard syntax for other engines (if applicable) may also be supported in the future. =cut sub line { my($self, $dbh) = ( shift, _dbh(@_) ); my $driver = $dbh ? _load_driver($dbh) : ''; my $dbd = "DBIx::DBSchema::DBD::$driver"; ## # type mapping ## my %typemap; %typemap = eval "\%${dbd}::typemap" if $driver; my $type = defined( $typemap{uc($self->type)} ) ? $typemap{uc($self->type)} : $self->type; ## # callback into the database-specific driver ## my $hashref = $dbd->column_callback( $dbh, $self->table_name, $self ); $type = $hashref->{'effective_type'} if $hashref->{'effective_type'}; my $null = $self->null; #we seem to do this for mysql/Pg/SQLite, i think this should be the default #add something to $hashref if drivers need to overrdide? $null ||= "NOT NULL"; $null =~ s/^NULL$// unless $hashref->{'explicit_null'}; my $default = $hashref->{'effective_default'} || $self->quoted_default($dbh); $default = "DEFAULT $default" if $default ne ''; my $local = $self->local; $local = $hashref->{'effective_local'} if $hashref->{'effective_local'}; ## # return column line ## join(' ', $self->name, $type. ( ( defined($self->length) && $self->length ) ? '('.$self->length.')' : '' ), $null, $default, ( defined($local) ? $local : ''), ); } =item quoted_default DATABASE_HANDLE Returns this column's default value quoted for the database. =cut sub quoted_default { my($self, $dbh) = @_; my $driver = $dbh ? _load_driver($dbh) : ''; return ${$self->default} if ref($self->default); my $dbd = "DBIx::DBSchema::DBD::$driver"; return $dbh->quote($self->default) if defined($self->default) && $self->default ne '' && ref($dbh) && $dbd->column_value_needs_quoting($self); return $self->default; } =item sql_add_column [ DBH ] Returns SQL to add this column to an existing table. (To create a new table, see L instead.) NOTE: This interface has changed in 0.41 Returns two listrefs. The first is a list of column alteration SQL fragments for an ALTER TABLE statement. The second is a list of full SQL statements that should be run after the ALTER TABLE statement. The data source can be specified by passing an open DBI database handle, or by passing the DBI data source name, username and password. Although the username and password are optional, it is best to call this method with a database handle or data source including a valid username and password - a DBI connection will be opened and the quoting and type mapping will be more reliable. If passed a DBI data source (or handle) such as `DBI:Pg:dbname=database', will use PostgreSQL-specific syntax. Non-standard syntax for other engines (if applicable) may also be supported in the future. =cut sub sql_add_column { my($self, $dbh) = ( shift, _dbh(@_) ); die "$self: this column is not assigned to a table" unless $self->table_name; my $driver = $dbh ? _load_driver($dbh) : ''; my @alter_table = (); my @sql = (); my $table = $self->table_name; my $dbd = "DBIx::DBSchema::DBD::$driver"; my $hashref = $dbd->add_column_callback( $dbh, $table, $self ); my $real_type = ''; if ( $hashref->{'effective_type'} ) { $real_type = $self->type; $self->type($hashref->{'effective_type'}); } my $real_null = undef; if ( exists($hashref->{'effective_null'}) ) { $real_null = $self->null; $self->null($hashref->{'effective_null'}); } push @alter_table, "ADD COLUMN ". $self->line($dbh); push @sql, @{ $hashref->{'sql_after'} } if $hashref->{'sql_after'}; push @sql, "ALTER TABLE $table ADD PRIMARY KEY ( ". $self->table_obj->primary_key. " )" if $self->name eq $self->table_obj->primary_key; $self->type($real_type) if $real_type; $self->null($real_null) if defined $real_null; (\@alter_table, \@sql); } =item sql_alter_column PROTOTYPE_COLUMN [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ] Returns SQL to alter this column so that it is identical to the provided prototype column, also a DBIx::DBSchema::Column object. NOTE: This interface has changed in 0.41 Returns two listrefs. The first is a list of column alteration SQL fragments for an ALTER TABLE statement. The second is a list of full SQL statements that should be run after the ALTER TABLE statement. Optionally, the data source can be specified by passing an open DBI database handle, or by passing the DBI data source name, username and password. If passed a DBI data source (or handle) such as `DBI:Pg:dbname=database', will use PostgreSQL-specific syntax. Non-standard syntax for other engines (if applicable) may also be supported in the future. If not passed a data source (or handle), or if there is no driver for the specified database, will attempt to use generic SQL syntax. =cut sub sql_alter_column { my($self, $opt, $new, $dbh) = ( shift, _parse_opt(\@_), shift, _dbh(@_) ); my $table = $self->table_name; die "$self: this column is not assigned to a table" unless $table; my $name = $self->name; my $driver = $dbh ? _load_driver($dbh) : ''; my @alter_table = (); my @sql = (); my $dbd = "DBIx::DBSchema::DBD::$driver"; my $hashref = $dbd->alter_column_callback( $dbh, $table, $self, $new ); if ( $hashref->{'sql_alter'} ) { push @sql, $hashref->{'sql_alter'}; } else { # change the name... # not yet implemented. how do we tell which old column it was? # change the type... if ( $hashref->{'sql_alter_type'} ) { push @alter_table, $hashref->{'sql_alter_type'}; } # change nullability... if ( $hashref->{'sql_alter_null'} ) { push @sql, $hashref->{'sql_alter_null'}; } else { # change nullability from NOT NULL to NULL if ( ! $self->null && $new->null ) { push @alter_table, "ALTER COLUMN $name DROP NOT NULL"; } # change nullability from NULL to NOT NULL... # this one could be more complicated, need to set a DEFAULT value and update # the table first... if ( $self->null && ! $new->null ) { push @alter_table, "ALTER COLUMN $name SET NOT NULL"; } } # change default my $old_default = $self->quoted_default($dbh); my $new_default = $new->quoted_default($dbh); if ( $old_default ne $new_default && ( uc($old_default) ne 'NOW()' || uc($new_default) ne 'NOW()' ) ) { #warn "old default: $old_default / new default: $new_default\n"; my $alter = "ALTER COLUMN $name"; if ( $new_default ne '' ) { #warn "changing from $old_default to $new_default\n"; push @alter_table, "$alter SET DEFAULT $new_default"; } elsif ( $old_default !~ /^nextval/i ) { #Pg-specific :( push @alter_table, "$alter DROP DEFAULT"; push @sql, "UPDATE TABLE $table SET $name = NULL WHERE $name = ''" if $opt->{'nullify_default'} && $old_default eq "''" && $new->null; } } # change other stuff... (what next?) } (\@alter_table, \@sql); } =item sql_drop_column [ DBH ] Returns SQL to drop this column from an existing table. NOTE: This interface has changed in 0.41 Returns a list of column alteration SQL fragments for an ALTER TABLE statement. The optional database handle or DBI data source/username/password is not yet used. =cut sub sql_drop_column { my( $self, $dbh ) = ( shift, _dbh(@_) ); my $table = $self->table_name; my $name = $self->name; ("DROP COLUMN $name"); # XXX what about indexes??? } =back =head1 AUTHOR Ivan Kohler =head1 COPYRIGHT Copyright (c) 2000-2006 Ivan Kohler 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. =head1 BUGS The new() method should warn that "Old-style $class creation without named parameters is deprecated!" Better documentation is needed for sql_add_column sql_alter_column() has database-specific foo that should be abstracted info DBIx::DBSchema::DBD::Pg nullify_default option should be documented =head1 SEE ALSO L, L, L, L =cut 1; DBIx-DBSchema-0.45/DBSchema/ForeignKey.pm0000644000175000017500000001135312241547374016332 0ustar ivanivanpackage DBIx::DBSchema::ForeignKey; use strict; our $VERSION = '0.13'; 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 ( { 'constraint' => 'constraint_name', '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 constraint 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 { defined($self->{match}) ? $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 { defined($self->{on_delete}) ? $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 { defined($self->{on_update}) ? $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 ' ', map { (my $thing_sql = uc($_) ) =~ s/_/ /g; "$thing_sql ". $self->$_; } grep $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 and uc($self->match) eq uc($other->match) and uc($self->on_delete) eq uc($other->on_delete) and uc($self->on_update) eq uc($other->on_update) ; } =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; DBIx-DBSchema-0.45/DBSchema/Table.pm0000644000175000017500000005265312241547016015320 0ustar ivanivanpackage DBIx::DBSchema::Table; use strict; use Carp; use DBIx::DBSchema::_util qw(_load_driver _dbh _parse_opt); use DBIx::DBSchema::Column 0.14; use DBIx::DBSchema::Index; use DBIx::DBSchema::ForeignKey 0.13; our $VERSION = '0.11'; our $DEBUG = 0; =head1 NAME DBIx::DBSchema::Table - Table objects =head1 SYNOPSIS use DBIx::DBSchema::Table; #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, #deprecated# unique => $dbix_dbschema_colgroup_unique_object, #deprecated# 'index' => $dbix_dbschema_colgroup_index_object, indices => \@dbix_dbschema_index_objects, foreign_keys => \@dbix_dbschema_foreign_key_objects, } ); #old style (VERY deprecated) $table = new DBIx::DBSchema::Table ( "table_name", "primary_key", $dbix_dbschema_colgroup_unique_object, $dbix_dbschema_colgroup_index_object, @dbix_dbschema_column_objects, ); $table->addcolumn ( $dbix_dbschema_column_object ); $table_name = $table->name; $table->name("table_name"); $primary_key = $table->primary_key; $table->primary_key("primary_key"); #deprecated# $dbix_dbschema_colgroup_unique_object = $table->unique; #deprecated# $table->unique( $dbix_dbschema__colgroup_unique_object ); #deprecated# $dbix_dbschema_colgroup_index_object = $table->index; #deprecated# $table->index( $dbix_dbschema_colgroup_index_object ); %indices = $table->indices; $dbix_dbschema_index_object = $indices{'index_name'}; @all_index_names = keys %indices; @all_dbix_dbschema_index_objects = values %indices; @column_names = $table->columns; $dbix_dbschema_column_object = $table->column("column"); #preferred @sql_statements = $table->sql_create_table( $dbh ); @sql_statements = $table->sql_create_table( $datasrc, $username, $password ); #possible problems @sql_statements = $table->sql_create_table( $datasrc ); @sql_statements = $table->sql_create_table; =head1 DESCRIPTION DBIx::DBSchema::Table objects represent a single database table. =head1 METHODS =over 4 =item new HASHREF Creates a new DBIx::DBSchema::Table object. The preferred usage is to pass a hash reference of named parameters. { name => TABLE_NAME, primary_key => PRIMARY_KEY, columns => COLUMNS, indices => INDICES, local_options => OPTIONS, } 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). FOREIGN_KEYS is a references to an array of DBIx::DBSchema::ForeignKey objects (see L). OPTIONS is a scalar of database-specific table options, such as "WITHOUT OIDS" for Pg or "TYPE=InnoDB" for mysql. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self; if ( ref($_[0]) ) { $self = shift; $self->{column_order} = [ map { $_->name } @{$self->{columns}} ]; $self->{columns} = { map { $_->name, $_ } @{$self->{columns}} }; $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!"; #croak "FATAL: old-style $class creation no longer supported;". # " use named parameters"; my($name,$primary_key,$unique,$index,@columns) = @_; my %columns = map { $_->name, $_ } @columns; my @column_order = map { $_->name } @columns; $self = { 'name' => $name, 'primary_key' => $primary_key, 'unique' => $unique, 'index' => $index, 'columns' => \%columns, 'column_order' => \@column_order, 'foreign_keys' => [], }; } #check $primary_key, $unique and $index to make sure they are $columns ? # (and sanity check?) bless ($self, $class); $_->table_obj($self) foreach values %{ $self->{columns} }; $self; } =item new_odbc DATABASE_HANDLE TABLE_NAME Creates a new DBIx::DBSchema::Table object from the supplied DBI database handle for the specified table. This uses the experimental DBI type_info method to create a table with standard (ODBC) SQL column types that most closely correspond to any non-portable column types. Use this to import a schema that you wish to use with many different database engines. Although primary key and (unique) index information will only be imported from databases with DBIx::DBSchema::DBD drivers (currently MySQL and PostgreSQL), import of column names and attributes *should* work for any database. Note: the _odbc refers to the column types used and nothing else - you do not have to have ODBC installed or connect to the database via ODBC. =cut our %create_params = ( # undef => sub { '' }, '' => sub { '' }, 'max length' => sub { $_[0]->{PRECISION}->[$_[1]]; }, 'precision,scale' => sub { $_[0]->{PRECISION}->[$_[1]]. ','. $_[0]->{SCALE}->[$_[1]]; } ); sub new_odbc { my( $proto, $dbh, $name) = @_; my $driver = _load_driver($dbh); my $sth = _null_sth($dbh, $name); my $sthpos = 0; 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' => [ map { my $col_name = $_; my $type_info = scalar($dbh->type_info($sth->{TYPE}->[$sthpos])) or die "DBI::type_info ". $dbh->{Driver}->{Name}. " driver ". "returned no results for type ". $sth->{TYPE}->[$sthpos]; my $length = &{ $create_params{ $type_info->{CREATE_PARAMS} } } ( $sth, $sthpos++ ); my $default = ''; if ( $driver ) { $default = ${ [ eval "DBIx::DBSchema::DBD::$driver->column(\$dbh, \$name, \$_)" ] }[4]; } DBIx::DBSchema::Column->new({ 'name' => $col_name, #'type' => "SQL_". uc($type_info->{'TYPE_NAME'}), 'type' => $type_info->{'TYPE_NAME'}, 'null' => $sth->{NULLABLE}->[$sthpos], 'length' => $length, 'default' => $default, #'local' => # DB-local }); } @{$sth->{NAME}} ], #indices 'indices' => { map { my $indexname = $_; $indexname => DBIx::DBSchema::Index->new($indices_hr->{$indexname}) } keys %$indices_hr }, }); } =item new_native DATABASE_HANDLE TABLE_NAME Creates a new DBIx::DBSchema::Table object from the supplied DBI database handle for the specified table. This uses database-native methods to read the schema, and will preserve any non-portable column types. The method is only available if there is a DBIx::DBSchema::DBD for the corresponding database engine (currently, MySQL and PostgreSQL). =cut 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)" : {} ); $proto->new({ 'name' => $name, 'primary_key' => $primary_key, 'columns' => [ map DBIx::DBSchema::Column->new( @{$_} ), eval "DBIx::DBSchema::DBD::$driver->columns(\$dbh, \$name)" ], '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 addcolumn COLUMN Adds this DBIx::DBSchema::Column object. =cut sub addcolumn { my($self, $column) = @_; $column->table_obj($self); ${$self->{'columns'}}{$column->name} = $column; #sanity check? push @{$self->{'column_order'}}, $column->name; } =item delcolumn COLUMN_NAME Deletes this column. Returns false if no column of this name was found to remove, true otherwise. =cut sub delcolumn { my($self,$column) = @_; return 0 unless exists $self->{'columns'}{$column}; $self->{'columns'}{$column}->table_obj(''); delete $self->{'columns'}{$column}; @{$self->{'column_order'}}= grep { $_ ne $column } @{$self->{'column_order'}}; 1; } =item name [ TABLE_NAME ] Returns or sets the table name. =cut sub name { my($self,$value)=@_; if ( defined($value) ) { $self->{name} = $value; } else { $self->{name}; } } =item local_options [ OPTIONS ] Returns or sets the database-specific table options string. =cut sub local_options { my($self,$value)=@_; if ( defined($value) ) { $self->{local_options} = $value; } else { defined $self->{local_options} ? $self->{local_options} : ''; } } =item primary_key [ PRIMARY_KEY ] Returns or sets the primary key. =cut sub primary_key { my($self,$value)=@_; if ( defined($value) ) { $self->{primary_key} = $value; } else { #$self->{primary_key}; #hmm. maybe should untaint the entire structure when it comes off disk # cause if you don't trust that, ? $self->{primary_key} =~ /^(\w*)$/ #aah! or die "Illegal primary key: ", $self->{primary_key}; $1; } } =item columns Returns a list consisting of the names of all columns. =cut sub columns { my($self)=@_; #keys %{$self->{'columns'}}; #must preserve order @{ $self->{'column_order'} }; } =item column COLUMN_NAME Returns the column object (see L) for the specified COLUMN_NAME. =cut sub column { my($self,$column)=@_; $self->{'columns'}->{$column}; } =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). =cut sub indices { my $self = shift; exists( $self->{'indices'} ) ? %{ $self->{'indices'} } : (); } =item unique_singles Meet exciting and unique singles using this method! This method returns a list of column names that are indexed with their own, unique, non-compond (that's the "single" part) indices. =cut sub unique_singles { my $self = shift; my %indices = $self->indices; map { ${ $indices{$_}->columns }[0] } grep { $indices{$_}->unique && scalar(@{$indices{$_}->columns}) == 1 } keys %indices; } =item sql_create_table [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ] Returns a list of SQL statments to create this table. The data source can be specified by passing an open DBI database handle, or by passing the DBI data source name, username and password. Although the username and password are optional, it is best to call this method with a database handle or data source including a valid username and password - a DBI connection will be opened and the quoting and type mapping will be more reliable. If passed a DBI data source (or handle) such as `DBI:mysql:database', will use MySQL- or PostgreSQL-specific syntax. Non-standard syntax for other engines (if applicable) may also be supported in the future. =cut sub sql_create_table { my($self, $dbh) = ( shift, _dbh(@_) ); my $driver = _load_driver($dbh); #should be in the DBD somehwere :/ # my $saved_pkey = ''; # if ( $driver eq 'Pg' && $self->primary_key ) { # my $pcolumn = $self->column( ( # grep { $self->column($_)->name eq $self->primary_key } $self->columns # )[0] ); ##AUTO-INCREMENT# $pcolumn->type('serial') if lc($pcolumn->type) eq 'integer'; # $pcolumn->local( $pcolumn->local. ' PRIMARY KEY' ); # #my $saved_pkey = $self->primary_key; # #$self->primary_key(''); # #change it back afterwords :/ # } my @columns = map { $self->column($_)->line($dbh) } $self->columns; 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 = ( "CREATE TABLE ". $self->name. " (\n ". join(",\n ", @columns). "\n)\n". $self->local_options ); my %indices = $self->indices; #push @r, map { $indices{$_}->sql_create_index( $self->name ) } keys %indices; foreach my $index ( keys %indices ) { push @r, $indices{$index}->sql_create_index( $self->name ); } #$self->primary_key($saved_pkey) if $saved_pkey; @r; } =item sql_add_constraints [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ] Returns a list of SQL statments to add constraints (foreign keys) to this table. The data source can be specified by passing an open DBI database handle, or by passing the DBI data source name, username and password. Although the username and password are optional, it is best to call this method with a database handle or data source including a valid username and password - a DBI connection will be opened and the quoting and type mapping will be more reliable. If passed a DBI data source (or handle) such as `DBI:mysql:database', will use MySQL- or PostgreSQL-specific syntax. Non-standard syntax for other engines (if applicable) may also be supported in the future. =cut sub sql_add_constraints { my $self = shift; my @fks = $self->foreign_keys_sql or return (); ( 'ALTER TABLE '. $self->name. ' '. join(",\n ", map "ADD $_", @fks) ); } =item sql_alter_table PROTOTYPE_TABLE, [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ] Returns a list of SQL statements to alter this table so that it is identical to the provided table, also a DBIx::DBSchema::Table object. The data source can be specified by passing an open DBI database handle, or by passing the DBI data source name, username and password. Although the username and password are optional, it is best to call this method with a database handle or data source including a valid username and password - a DBI connection will be opened and used to check the database version as well as for more reliable quoting and type mapping. Note that the database connection will be used passively, B to actually run the CREATE statements. If passed a DBI data source (or handle) such as `DBI:mysql:database' or `DBI:Pg:dbname=database', will use syntax specific to that database engine. Currently supported databases are MySQL and PostgreSQL. If not passed a data source (or handle), or if there is no driver for the specified database, will attempt to use generic SQL syntax. =cut #gosh, false laziness w/DBSchema::sql_update_schema sub sql_alter_table { my($self, $opt, $new, $dbh) = ( shift, _parse_opt(\@_), shift, _dbh(@_) ); my $driver = _load_driver($dbh); my $table = $self->name; my @at = (); my @r = (); my @r_later = (); my $tempnum = 1; ### # columns (add/alter) ### foreach my $column ( $new->columns ) { if ( $self->column($column) ) { warn " $table.$column exists\n" if $DEBUG > 1; my ($alter_table, $sql) = $self->column($column)->sql_alter_column( $new->column($column), $dbh, $opt, ); push @at, @$alter_table; push @r, @$sql; } else { warn "column $table.$column does not exist.\n" if $DEBUG > 1; my ($alter_table, $sql) = $new->column($column)->sql_add_column( $dbh ); push @at, @$alter_table; push @r, @$sql; } } ### # indices ### my %old_indices = $self->indices; my %new_indices = $new->indices; foreach my $old ( keys %old_indices ) { if ( exists( $new_indices{$old} ) && $old_indices{$old}->cmp( $new_indices{$old} ) ) { warn "index $table.$old is identical; not changing\n" if $DEBUG > 1; delete $old_indices{$old}; delete $new_indices{$old}; } elsif ( $driver eq 'Pg' and $dbh->{'pg_server_version'} >= 80000 ) { my @same = grep { $old_indices{$old}->cmp_noname( $new_indices{$_} ) } keys %new_indices; if ( @same ) { #warn if there's more than one? my $same = shift @same; warn "index $table.$old is identical to $same; renaming\n" if $DEBUG > 1; my $temp = 'dbs_temp'.$tempnum++; push @r, "ALTER INDEX $old RENAME TO $temp"; push @r_later, "ALTER INDEX $temp RENAME TO $same"; delete $old_indices{$old}; delete $new_indices{$same}; } } } foreach my $old ( keys %old_indices ) { warn "removing obsolete index $table.$old ON ( ". $old_indices{$old}->columns_sql. " )\n" if $DEBUG > 1; push @r, "DROP INDEX $old". ( $driver eq 'mysql' ? " ON $table" : ''); } foreach my $new ( keys %new_indices ) { warn "creating new index $table.$new\n" if $DEBUG > 1; push @r, $new_indices{$new}->sql_create_index($table); } ### # columns (drop) ### foreach my $column ( grep !$new->column($_), $self->columns ) { warn "column $table.$column should be dropped.\n" if $DEBUG; push @at, $self->column($column)->sql_drop_column( $dbh ); } ### # return the statements ### unshift @r, "ALTER TABLE $table ". join(', ', @at) if @at; push @r, @r_later; warn join('', map "$_\n", @r) if $DEBUG && @r; @r; } =item sql_alter_constraints PROTOTYPE_TABLE, [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ] Returns a list of SQL statements to alter this table's constraints (foreign keys) so that they are identical to the provided table, also a DBIx::DBSchema::Table object. The data source can be specified by passing an open DBI database handle, or by passing the DBI data source name, username and password. Although the username and password are optional, it is best to call this method with a database handle or data source including a valid username and password - a DBI connection will be opened and used to check the database version as well as for more reliable quoting and type mapping. Note that the database connection will be used passively, B to actually run the CREATE statements. If passed a DBI data source (or handle) such as `DBI:mysql:database' or `DBI:Pg:dbname=database', will use syntax specific to that database engine. Currently supported databases are MySQL and PostgreSQL. If not passed a data source (or handle), or if there is no driver for the specified database, will attempt to use generic SQL syntax. =cut sub sql_alter_constraints { my($self, $opt, $new, $dbh) = ( shift, _parse_opt(\@_), shift, _dbh(@_) ); my $driver = _load_driver($dbh); my $table = $self->name; my @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; } #foreign keys (drop) foreach my $foreign_key ( $self->foreign_keys ) { next if grep $foreign_key->cmp($_), $new->foreign_keys; next unless $foreign_key->constraint; push @at, 'DROP CONSTRAINT '. $foreign_key->constraint; } return () unless @at; ( 'ALTER TABLE '. $self->name. ' '. join(",\n ", @at) ); } sub sql_drop_table { my( $self, $dbh ) = ( shift, _dbh(@_) ); my $name = $self->name; ("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") or die $dbh->errstr; $sth->execute or die $sth->errstr; $sth; } =back =head1 AUTHOR Ivan Kohler Thanks to Mark Ethan Trostler for a patch to allow tables with no indices. =head1 COPYRIGHT Copyright (c) 2000-2007 Ivan Kohler Copyright (c) 2000 Mail Abuse Prevention System LLC 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. =head1 BUGS sql_create_table() has database-specific foo that probably ought to be abstracted into the DBIx::DBSchema::DBD:: modules (or no? it doesn't anymore?). sql_alter_table() also has database-specific foo that ought to be abstracted into the DBIx::DBSchema::DBD:: modules. sql_create_table() may change or destroy the object's data. If you need to use the object after sql_create_table, make a copy beforehand. Some of the logic in new_odbc might be better abstracted into Column.pm etc. Add methods to get and set specific indices, by name? (like column COLUMN_NAME) indices method should be a setter, not just a getter? =head1 SEE ALSO L, L, L, L, L =cut 1; DBIx-DBSchema-0.45/Changes0000644000175000017500000002023212522572624013611 0ustar ivanivanRevision history for Perl module DBIx::DBSchema 0.45 Wed May 6 22:17:33 PDT 2015 - MySQL does not support DEFAULT for TEXT/BLOB columns, closes: CPAN#58505 - doc: Add repository information - fix SQLite reverse-engineering, closes: CPAN#95961 - fix Pg reverse-engineering of foreign key MATCH/ON DELETE/ON UPDATE clauses 0.44 2013-11-15 17:54:37 PST - POD fixes from Xavier Guimard and Damyan Ivanov of the Debian Perl Group, closes: CPAN#82187 - More foreign key support + Table alteration (removing foreign keys) + Fix MATCH / ON DELETE / ON UPDATE 0.43 2013-11-04 14:58;32 PST - Incorporate CPAN::Changes::Spec-compliant Changes file from Neil Bowers , closes: CPAN#90023, thanks! - Fix table creation broken by 0.42 - Create/alter tables before foreign key changes 0.42 2013-11-03 01:09:27 PST - Basic foreign key support + table creation + table alteration (adding new foreign keys) + reverse-engineering (Pg driver) 0.41_01 not released - consolidate multiple ADD/ALTER COLUMN statements into one ALTER TABLE 0.40 2011-12-17 17:03:51 PST - doc: sql_update_schema link to sql_add_column misspelled - Pg: fix mapping for DOUBLE PRECISION type to avoid needless alter cols - mysql: implement altering column types & lengths 0.39 2010-03-26 20:24:58 PDT - mysql: TEXT->LONGTEXT - mysql: when reverse engineering, transform a default of CURRENT_TIMESTAMP into the more common NOW() - mysql: fix reverse-engineering of empty string default 0.38 2010-01-14 15:26:13 PST - Bump version number for ->quoted_default availability & default reverse-engineering changes 0.37 not released - Patch from Slavin Rezic to prevent quoting around numeric defaults in Pg. - Pg: use default_db_schema when adding SERIAL columns instead of hardcoding "public". - Pg: Initial support for handling changes to a column's type or size. - Case sensitivity fix for Slavin's patch to prevent quoting around numeric defaults in Pg. - Column default values: refactor handling, improve Pg reverse engineering and implement schema changes. 0.36 2007-12-13 17:49:35 PST - Patch from ISHIGAKI@cpan.org to suppress unnecessary warnings about undefined local_options, thanks! - fix bug preventing adding new columns as primary keys under Pg 0.35 2007-10-29 18:58:36 PDT - Fix minor breakage (pretty_print) resulting from Jesse's changes. - Update mysql driver to handle BIGSERIAL columns - Update Column.pm, move all mysql and Pg-specific code to DBD driver callbacks - Update Table.pm, add local_options - Fix mysql NULL reverse-engineering and updating code 0.34 2007-08-19 10:08:51 PDT - More work on update schema from Slaven Rezic , thanks! + implement table dropping (closes: CPAN#27936) + implement column dropping (closes: CPAN#27896) - Fix to quiet warnings from internal use of old API from Jesse Vincent , thanks! (closes: CPAN#27958) - Make table dropping optional, not the default. 0.33 2007-06-28 18:46:15 PDT - Overhaul of index representation: indices (both normal and unique) now have names and are DBIx::DBSchema::Index objects - update_schema now handles indices! - Bump version numbers in Table.pm, Column.pm and DBD.pm - Pg reverse-engineering fix for column order in multi-column indices, to prevent needless drop/add of identical indices - mysql reverse-engineering patch from Brian Phillips , closes: CPAN#17582, thanks! - mysql NAME vs NAME_lc patch from Ralf Hack , closes: CPAN#16715, thanks! - mysql fix for additional column data from Chris Mungall , closes: CPAN#20859, thanks! - SQLite SERIAL patch from IN SUK JOUNG , and fix for mis-application of said patch from Slaven Rezic , thanks! - Update README wrt current CVS info and URL, closes: CPAN#27577 0.32 2007-04-18 15:02:25 PDT - increment the version numbers in Column.pm and Table.pm and the "use" statements accordingly - Error reporting for load constructor - Update documentation wrt supported databases and new update_schema stuff - Fixes for dropping nullability on old Pg (<= 7.2) - Fixes for adding nullability on old Pg (<= 7.3) - Throw a warning if pg_server_version is unavailable, assume >= 7.3 - fix POD error in DBSchema::DBD::SQLite that confused pod2man and prevented the documentation from being installed. Patch from Niko Tyni , thanks! 0.31 2006-03-30 05:28:20 PST - more schema update stuff: - added Column::sql_alter_column - added Table::sql_alter_table - added DBSchema::sql_update_schema and DBSchema::update_schema 0.30 2006-02-16 16:43:01 PST - "Too much uptime" - Remove buggy debugging from Column.pm - Remove removed TODO from MANIFEST 0.29 2006-02-16 13:54:42 PST - Column::sql_add_column fix when adding primary keys to Pg 7.2.x - workaround for PAUSE parsing of DBIx::DBSchema::DBD::Pg version: move DBD::Pg verison checking after $VERSION declaration, thanks Andreas! - kludge: allow scalar ref default to force quoting off, to add things like functions and empty values as defaults - Move TODO file to DBSchema.pm and DBS/Column.pm BUGS sections 0.28 2005-11-30 09:46:47 PST - Initial SQLite support from Jesse Vincent - fix typo in DBIx::DBSchema::DBD POD doc 0.27 2005-08-15 23:31:54 PDT - MySQL patch for enum types from Andy Orr - new Column::sql_add_column method! 0.26 2005-04-07 01:09:53 PDT - ask for "public" db schema only from Pg 0.25 2005-04-06 16:12:38 PDT - depend on DBD::Pg 1.32 or 1.41+ (1.40 was bunk) 0.24 2005-03-11 02:20:55 PST - Oracle driver from Daniel Hanks and Peter Bowen . - Switch from FreezeThaw to Storable, keep ability to read old files 0.23 2004-02-16 17:35:54 PST - Update Pg dependancy to 1.32 - Update the simple load test so it skips DBIx::DBSchema::DBD::Pg if DBD::Pg 1.32 is not installed. 0.22 2003-10-23 15:18:21 PDT - Pg reverse-engineering fix: varchar with no limit - Pg needs (unreleased) DBD::Pg 1.30 (or deb 1.22-2... interesting) 0.21 2002-09-19 05:04:18 PDT - Pg reverse-engineering fix: now sets default 0.20 2002-03-04 04:58:34 - documentation updates - fix Column->new when using named params - fix Pg driver reverse-engineering length of numeric columns: translate 655362 to 10,2, etc. - fix Pg driver reverse-engineering of text columns (don't have a length) 0.19 2001-10-23 08:49:12 - documentation for %typemap - preliminary Sybase driver from Charles Shapiro and Mitchell J. Friedman . - Fix Column::line to return a scalar as documented, not a list. - Should finally eliminate the Use of uninitialized value at ... DBIx/DBSchema/Column.pm line 251 0.18 2001-08-10 17:07:28 - Added Table::delcolumn - patch from Charles Shapiro to add `ORDER BY a.attnum' to the SQL in DBIx::DBSchema::DBD::Pg::columns 0.17 2001-07-07 17:55:33 - Rework Table->new interface for named params - Fixes for Pg blobs, yay! - MySQL doesn't need non-standard index syntax anymore (since 3.22). - patch from Mark Ethan Trostler for generating tables without indices. 0.16 2001-01-05 15:55:50 - Don't overflow index names. 0.15 2000-11-24 23:39:16 - MySQL handling of BOOL type (change to TINYINT) 0.14 2000-10-24 14:43:16 - MySQL handling of SERIAL type (change to INTEGER AUTO_INCREMENT) 0.13 2000-10-11 10:47:13 - fixed up type mapping foo, added default values, added named parameters to Column->new, fixed quoting of default values 0.11 2000-09-28 02:16:25 - oops, original verison got 0.10, so this one will get 0.11 0.01 2000-09-17 07:57:35 - original version; created by h2xs 1.19 DBIx-DBSchema-0.45/MANIFEST.SKIP0000644000175000017500000000001612235411632014202 0ustar ivanivan.git/ debian/