From 5cbdef56c923a0f25901585eb28d9d9f552f71f6 Mon Sep 17 00:00:00 2001 From: ivan Date: Sat, 9 Jan 2010 08:19:43 +0000 Subject: [PATCH] Column default values: refactor handling, improve Pg reverse engineering and implement schema changes --- Changes | 2 + DBSchema.pm | 15 +++---- DBSchema/Column.pm | 122 ++++++++++++++++++++++++++------------------------ DBSchema/DBD.pm | 25 ++++++++++- DBSchema/DBD/Pg.pm | 69 +++++++++++++++++----------- DBSchema/DBD/mysql.pm | 6 +-- DBSchema/Table.pm | 25 +++++------ README | 2 +- 8 files changed, 154 insertions(+), 112 deletions(-) diff --git a/Changes b/Changes index b9c3a05..740da93 100644 --- a/Changes +++ b/Changes @@ -8,6 +8,8 @@ Revision history for Perl extension DBIx::DBSchema. - 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 Thu Dec 13 17:49:35 PST 2007 - Patch from ISHIGAKI@cpan.org to suppress unnecessary warnings about diff --git a/DBSchema.pm b/DBSchema.pm index c91d0b3..a84246e 100644 --- a/DBSchema.pm +++ b/DBSchema.pm @@ -4,7 +4,7 @@ use strict; use vars qw($VERSION $DEBUG $errstr); use Storable; use DBIx::DBSchema::_util qw(_load_driver _dbh _parse_opt); -use DBIx::DBSchema::Table 0.05; +use DBIx::DBSchema::Table 0.08; use DBIx::DBSchema::Index; use DBIx::DBSchema::Column; use DBIx::DBSchema::ColGroup::Unique; @@ -276,7 +276,6 @@ specified database, will attempt to use generic SQL syntax. #gosh, false laziness w/DBSchema::Table::sql_alter_schema sub sql_update_schema { - #my($self, $new, $dbh) = ( shift, shift, _dbh(@_) ); my($self, $opt, $new, $dbh) = ( shift, _parse_opt(\@_), shift, _dbh(@_) ); my @r = (); @@ -287,8 +286,10 @@ sub sql_update_schema { warn "$table exists\n" if $DEBUG > 1; - push @r, - $self->table($table)->sql_alter_table( $new->table($table), $dbh ); + push @r, $self->table($table)->sql_alter_table( $new->table($table), + $dbh, + $opt + ); } else { @@ -516,7 +517,7 @@ items/projects below under BUGS. Copyright (c) 2000-2007 Ivan Kohler Copyright (c) 2000 Mail Abuse Prevention System LLC -Copyright (c) 2007 Freeside Internet Services, Inc. +Copyright (c) 2007-2010 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. @@ -527,9 +528,7 @@ Multiple primary keys are not yet supported. Foreign keys and other constraints are not yet supported. -Eventually it would be nice to have additional transformations (deleted, -modified columns). sql_update_schema doesn't deal with deleted or modified -columns yet. +sql_update_schema doesn't deal with deleted columns yet. Need to port and test with additional databases diff --git a/DBSchema/Column.pm b/DBSchema/Column.pm index 0d00159..1f0c016 100644 --- a/DBSchema/Column.pm +++ b/DBSchema/Column.pm @@ -3,9 +3,9 @@ package DBIx::DBSchema::Column; use strict; use vars qw($VERSION); use Carp; -use DBIx::DBSchema::_util qw(_load_driver _dbh); +use DBIx::DBSchema::_util qw(_load_driver _dbh _parse_opt); -$VERSION = '0.13'; +$VERSION = '0.14'; =head1 NAME @@ -72,7 +72,7 @@ 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<$now()> or explicit empty strings as C<''> as +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 @@ -248,55 +248,24 @@ sub line { my($self, $dbh) = ( shift, _dbh(@_) ); my $driver = $dbh ? _load_driver($dbh) : ''; - my $driver_class = "DBIx::DBSchema::DBD::${driver}"; + my $dbd = "DBIx::DBSchema::DBD::$driver"; ## # type mapping ## my %typemap; - %typemap = eval "\%${driver_class}::typemap" if $driver; + %typemap = eval "\%${dbd}::typemap" if $driver; my $type = defined( $typemap{uc($self->type)} ) ? $typemap{uc($self->type)} : $self->type; ## - # set default for the callback... - ## - - my $default; - my $orig_default = $self->default; - if ( $driver_class->can("_column_value_needs_quoting") ) { - if ( $driver_class->_column_value_needs_quoting($self) - && !ref($self->default) - ) - { - $default = $dbh->quote($self->default); - } else { - $default = ref($self->default) ? ${$self->default} : $self->default; - } - } elsif ( defined($self->default) && !ref($self->default) && $self->default ne '' - && ref($dbh) - # false laziness: nicked from FS::Record::_quote - && ( $self->default !~ /^\-?\d+(\.\d+)?$/ - || $type =~ /(char|binary|blob|text)$/i - ) - ) { - $default = $dbh->quote($self->default); - } else { - $default = ref($self->default) ? ${$self->default} : $self->default; - } - $self->default($default); - - ## # callback into the database-specific driver ## - my $dbd = "DBIx::DBSchema::DBD::$driver"; my $hashref = $dbd->column_callback( $dbh, $self->table_name, $self ); - $self->default($orig_default); - $type = $hashref->{'effective_type'} if $hashref->{'effective_type'}; @@ -308,8 +277,8 @@ sub line { $null =~ s/^NULL$// unless $hashref->{'explicit_null'}; - $default = $hashref->{'effective_default'} - if $hashref->{'effective_default'}; + my $default = $hashref->{'effective_default'} || $self->quoted_default($dbh); + $default = "DEFAULT $default" if $default ne ''; my $local = $self->local; $local = $hashref->{'effective_local'} @@ -326,15 +295,36 @@ sub line { : '' ), $null, - ( ( defined($default) && $default ne '' ) - ? 'DEFAULT '. $default - : '' - ), + $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 a list of SQL statements to add this column to an existing table. (To @@ -400,24 +390,20 @@ sub sql_add_column { Returns a list of SQL statements to alter this column so that it is identical to the provided prototype column, also a DBIx::DBSchema::Column object. - #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. +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. -Or should, someday. Right now it knows how to change NOT NULL into NULL and -vice-versa. +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, $new, $dbh ) = ( shift, shift, _dbh(@_) ); + 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" @@ -473,14 +459,32 @@ sub sql_alter_column { } # change default + my $old_default = $self->quoted_default($dbh); + my $new_default = $new->quoted_default($dbh); + if ( $old_default ne $new_default ) { - # change other stuff... + my $alter = "ALTER TABLE $table ALTER COLUMN $name"; + + if ( $new_default ne '' ) { + #warn "changing from $old_default to $new_default\n"; + push @sql, "$alter SET DEFAULT $new_default"; + } elsif ( $old_default !~ /^nextval/i ) { #Pg-specific :( + push @sql, "$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?) } @sql; } + =item sql_drop_column [ DBH ] Returns a list of SQL statements to drop this column from an existing table. @@ -508,7 +512,7 @@ Ivan Kohler =head1 COPYRIGHT Copyright (c) 2000-2006 Ivan Kohler -Copyright (c) 2007 Freeside Internet Services, Inc. +Copyright (c) 2007-2010 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. @@ -520,8 +524,10 @@ The new() method should warn that Better documentation is needed for sql_add_column -line() and sql_add_column() hav database-specific foo that should be abstracted -into the DBIx::DBSchema:DBD:: modules. +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 diff --git a/DBSchema/DBD.pm b/DBSchema/DBD.pm index 1a421d2..7a34e3c 100644 --- a/DBSchema/DBD.pm +++ b/DBSchema/DBD.pm @@ -3,7 +3,7 @@ package DBIx::DBSchema::DBD; use strict; use vars qw($VERSION); -$VERSION = '0.06'; +$VERSION = '0.07'; =head1 NAME @@ -208,8 +208,29 @@ sql_alter_null - Alter SQL statement(s) for changing nullability to be used inst 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 @@ -237,7 +258,7 @@ Ivan Kohler =head1 COPYRIGHT Copyright (c) 2000-2005 Ivan Kohler -Copyright (c) 2007 Freeside Internet Services, Inc. +Copyright (c) 2007-2010 Freeside Internet Services, Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/DBSchema/DBD/Pg.pm b/DBSchema/DBD/Pg.pm index df7407e..26adde4 100644 --- a/DBSchema/DBD/Pg.pm +++ b/DBSchema/DBD/Pg.pm @@ -5,7 +5,7 @@ use vars qw($VERSION @ISA %typemap); use DBD::Pg 1.32; use DBIx::DBSchema::DBD; -$VERSION = '0.15'; +$VERSION = '0.16'; @ISA = qw(DBIx::DBSchema::DBD); die "DBD::Pg version 1.32 or 1.41 (or later) required--". @@ -52,6 +52,18 @@ END 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}; @@ -62,19 +74,21 @@ END $d_sth->execute or die $d_sth->errstr; $default = $d_sth->fetchrow_arrayref->[0]; - }; - my $len = ''; - if ( $_->{attlen} == -1 && $_->{atttypmod} != -1 - && $_->{typname} ne 'text' ) { - $len = $_->{atttypmod} - 4; - if ( $_->{typname} eq 'numeric' ) { - $len = ($len >> 16). ','. ($len & 0xffff); + 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 + $default = \$default; } - } - my $type = $_->{'typname'}; - $type = 'char' if $type eq 'bpchar'; + } [ $_->{'attname'}, @@ -303,20 +317,25 @@ sub alter_column_callback { } -sub _column_value_needs_quoting { +sub column_value_needs_quoting { my($proto, $col) = @_; - $col->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; + _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; } @@ -328,7 +347,7 @@ Ivan Kohler Copyright (c) 2000 Ivan Kohler Copyright (c) 2000 Mail Abuse Prevention System LLC -Copyright (c) 2009 Freeside Internet Services, Inc. +Copyright (c) 2009-2010 Freeside Internet Services, Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/DBSchema/DBD/mysql.pm b/DBSchema/DBD/mysql.pm index 0bda38d..38d663b 100644 --- a/DBSchema/DBD/mysql.pm +++ b/DBSchema/DBD/mysql.pm @@ -4,7 +4,7 @@ use strict; use vars qw($VERSION @ISA %typemap); use DBIx::DBSchema::DBD; -$VERSION = '0.06'; +$VERSION = '0.07'; @ISA = qw(DBIx::DBSchema::DBD); %typemap = ( @@ -120,7 +120,7 @@ sub column_callback { $hashref->{'effective_local'} = 'AUTO_INCREMENT' if $column_obj->type =~ /^(\w*)SERIAL$/i; - if ( $column_obj->default =~ /^(NOW)\(\)$/i + if ( $column_obj->quoted_default =~ /^(NOW)\(\)$/i && $column_obj->type =~ /^(TIMESTAMP|DATETIME)$/i ) { $hashref->{'effective_default'} = 'CURRENT_TIMESTAMP'; @@ -162,7 +162,7 @@ Ivan Kohler Copyright (c) 2000 Ivan Kohler Copyright (c) 2000 Mail Abuse Prevention System LLC -Copyright (c) 2007 Freeside Internet Services, Inc. +Copyright (c) 2007-2010 Freeside Internet Services, Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/DBSchema/Table.pm b/DBSchema/Table.pm index 225bcbb..8d047de 100644 --- a/DBSchema/Table.pm +++ b/DBSchema/Table.pm @@ -4,13 +4,13 @@ use strict; use vars qw($VERSION $DEBUG %create_params); use Carp; #use Exporter; -use DBIx::DBSchema::_util qw(_load_driver _dbh); -use DBIx::DBSchema::Column 0.07; +use DBIx::DBSchema::_util qw(_load_driver _dbh _parse_opt); +use DBIx::DBSchema::Column 0.14; use DBIx::DBSchema::Index; use DBIx::DBSchema::ColGroup::Unique; use DBIx::DBSchema::ColGroup::Index; -$VERSION = '0.07'; +$VERSION = '0.08'; $DEBUG = 0; =head1 NAME @@ -617,7 +617,7 @@ specified database, will attempt to use generic SQL syntax. #gosh, false laziness w/DBSchema::sql_update_schema sub sql_alter_table { - my( $self, $new, $dbh ) = ( shift, shift, _dbh(@_) ); + my($self, $opt, $new, $dbh) = ( shift, _parse_opt(\@_), shift, _dbh(@_) ); my $driver = _load_driver($dbh); @@ -636,23 +636,20 @@ sub sql_alter_table { if ( $self->column($column) ) { warn " $table.$column exists\n" if $DEBUG > 1; - - push @r, - $self->column($column)->sql_alter_column( $new->column($column), $dbh ); + push @r, $self->column($column)->sql_alter_column( $new->column($column), + $dbh, + $opt, + ); } else { warn "column $table.$column does not exist.\n" if $DEBUG > 1; - - push @r, - $new->column($column)->sql_add_column( $dbh ); + push @r, $new->column($column)->sql_add_column( $dbh ); } } - #should eventually drop columns not in $new... - ### # indices ### @@ -764,7 +761,7 @@ with no indices. Copyright (c) 2000-2007 Ivan Kohler Copyright (c) 2000 Mail Abuse Prevention System LLC -Copyright (c) 2007 Freeside Internet Services, Inc. +Copyright (c) 2007-2010 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. @@ -782,8 +779,6 @@ 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. -sql_alter_table ought to drop columns not in $new - Add methods to get and set specific indices, by name? (like column COLUMN_NAME) indices method should be a setter, not just a getter? diff --git a/README b/README index 6fde3a2..6f5bb20 100644 --- a/README +++ b/README @@ -2,7 +2,7 @@ DBIx::DBSchema Copyright (c) 2000-2007 Ivan Kohler Copyright (c) 2000 Mail Abuse Prevention System LLC -Copyright (c) 2007 Freeside Internet Services, Inc. +Copyright (c) 2007-2010 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. -- 2.11.0