X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=DBSchema%2FColumn.pm;h=1f0c016b9342c3001ba29ac19a91d21ba2139f1d;hb=5cbdef56c923a0f25901585eb28d9d9f552f71f6;hp=14351ece6957bded993cd6d4861f2e7dfd25d4e8;hpb=7d32dbb1d615e1b675857c81fbb8361493b61e6b;p=DBIx-DBSchema.git diff --git a/DBSchema/Column.pm b/DBSchema/Column.pm index 14351ec..1f0c016 100644 --- a/DBSchema/Column.pm +++ b/DBSchema/Column.pm @@ -1,15 +1,11 @@ package DBIx::DBSchema::Column; use strict; -use vars qw(@ISA $VERSION); -#use Carp; -#use Exporter; -use DBIx::DBSchema::_util qw(_load_driver _dbh); +use vars qw($VERSION); +use Carp; +use DBIx::DBSchema::_util qw(_load_driver _dbh _parse_opt); -#@ISA = qw(Exporter); -@ISA = qw(); - -$VERSION = '0.08'; +$VERSION = '0.14'; =head1 NAME @@ -76,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 @@ -89,6 +85,10 @@ sub new { 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) }; } @@ -248,36 +248,45 @@ 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 "\%DBIx::DBSchema::DBD::${driver}::typemap" if $driver; + %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; - my $default; - if ( 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; - } + #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"; - #this should be a callback into the driver - if ( $driver eq 'mysql' ) { #yucky mysql hack - $null ||= "NOT NULL"; - $self->local('AUTO_INCREMENT') if uc($self->type) eq 'SERIAL'; - } elsif ( $driver =~ /^(?:Pg|SQLite)$/ ) { #yucky Pg/SQLite hack - $null ||= "NOT NULL"; - $null =~ s/^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, @@ -286,18 +295,36 @@ sub line { : '' ), $null, - ( ( defined($default) && $default ne '' ) - ? 'DEFAULT '. $default - : '' - ), - ( ( $driver eq 'mysql' && defined($self->local) ) - ? $self->local - : '' - ), + $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 @@ -325,78 +352,36 @@ sub sql_add_column { my $driver = $dbh ? _load_driver($dbh) : ''; - my @after_add = (); - - my $real_type = ''; - if ( $driver eq 'Pg' && $self->type eq 'serial' ) { - $real_type = 'serial'; - $self->type('int'); - - push @after_add, sub { - my($table, $column) = @_; - - #needs more work for old Pg - - my $nextval; - if ( $dbh->{'pg_server_version'} > 70300 ) { - $nextval = "nextval('public.${table}_${column}_seq'::text)"; - } else { - $nextval = "nextval('${table}_${column}_seq'::text)"; - } - - ( - "ALTER TABLE $table ALTER COLUMN $column SET DEFAULT $nextval", - "CREATE SEQUENCE ${table}_${column}_seq", - "UPDATE $table SET $column = $nextval WHERE $column IS NULL", - #"ALTER TABLE $table ALTER $column SET NOT NULL", - ); + 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 ( $driver eq 'Pg' && ! $self->null ) { + if ( exists($hashref->{'effective_null'}) ) { $real_null = $self->null; - $self->null('NULL'); - - #if ( $dbh->{'pg_server_version'} > 70300 ) { #this seemed to work on 7.3 - if ( $dbh->{'pg_server_version'} > 70400 ) { #after all... - - push @after_add, sub { - my($table, $column) = @_; - "ALTER TABLE $table ALTER $column SET NOT NULL"; - }; - - } else { - - push @after_add, sub { - my($table, $column) = @_; - "UPDATE pg_attribute SET attnotnull = TRUE ". - " WHERE attname = '$column' ". - " AND attrelid = ( SELECT oid FROM pg_class WHERE relname = '$table' )"; - }; - - } - + $self->null($hashref->{'effective_null'}); } - my @r = (); - my $table = $self->table_name; - my $column = $self->name; - - push @r, "ALTER TABLE $table ADD COLUMN ". $self->line($dbh); + push @sql, "ALTER TABLE $table ADD COLUMN ". $self->line($dbh); - push @r, &{$_}($table, $column) foreach @after_add; + push @sql, @{ $hashref->{'sql_after'} } if $hashref->{'sql_after'}; - push @r, "ALTER TABLE $table ADD PRIMARY KEY ( ". + 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; - @r; + @sql; } @@ -405,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" @@ -432,37 +413,94 @@ sub sql_alter_column { my $driver = $dbh ? _load_driver($dbh) : ''; - my @r = (); + my @sql = (); - # change the name... + my $dbd = "DBIx::DBSchema::DBD::$driver"; + my $hashref = $dbd->alter_column_callback( $dbh, $table, $self, $new ); - # change the type... + if ( $hashref->{'sql_alter'} ) { - # change nullability from NOT NULL to NULL - if ( ! $self->null && $new->null ) { + 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 @sql, $hashref->{'sql_alter_type'}; + } + + # change nullability... + + if ( $hashref->{'sql_alter_null'} ) { + + push @sql, $hashref->{'sql_alter_null'}; - if ( $driver eq 'Pg' && $dbh->{'pg_server_version'} < 70300 ) { - push @r, "UPDATE pg_attribute SET attnotnull = FALSE - WHERE attname = '$name' - AND attrelid = ( SELECT oid FROM pg_class - WHERE relname = '$table' - )"; } else { - push @r, "ALTER TABLE $table ALTER COLUMN $name DROP NOT NULL"; + + # change nullability from NOT NULL to NULL + if ( ! $self->null && $new->null ) { + + push @sql, "ALTER TABLE $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 @sql, "ALTER TABLE $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 ) { + + 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 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 @r, "ALTER TABLE $table ALTER COLUMN $name SET NOT NULL"; + # change other stuff... (what next?) + } - # change other stuff... + @sql; + +} + +=item sql_drop_column [ DBH ] + +Returns a list of SQL statements to drop this column from an existing table. - @r; +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; + + ("ALTER TABLE $table DROP COLUMN $name"); # XXX what about indexes??? } =back @@ -474,16 +512,22 @@ Ivan Kohler =head1 COPYRIGHT Copyright (c) 2000-2006 Ivan Kohler +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. =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 -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