X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=DBSchema%2FDBD%2FPg.pm;h=430c1004fee9ac8ce7ba59238acf477f8e2b3c54;hb=50b3fe05a9ec6c677bb1ee45765d560f1897a559;hp=76bcf2d12d4d1b2c17fa08dfd58809184ab10569;hpb=3ee0daa906b3be8938a5a1afbed0b86fad7e5013;p=DBIx-DBSchema.git diff --git a/DBSchema/DBD/Pg.pm b/DBSchema/DBD/Pg.pm index 76bcf2d..430c100 100644 --- a/DBSchema/DBD/Pg.pm +++ b/DBSchema/DBD/Pg.pm @@ -2,14 +2,20 @@ package DBIx::DBSchema::DBD::Pg; use strict; use vars qw($VERSION @ISA %typemap); +use DBD::Pg 1.32; use DBIx::DBSchema::DBD; -$VERSION = '0.03'; +$VERSION = '0.14'; @ISA = qw(DBIx::DBSchema::DBD); +die "DBD::Pg version 1.32 or 1.41 (or later) required--". + "this is only version $DBD::Pg::VERSION\n" + if $DBD::Pg::VERSION != 1.32 && $DBD::Pg::VERSION < 1.41; + %typemap = ( - 'BLOB' => 'BYTEA', + 'BLOB' => 'BYTEA', 'LONG VARBINARY' => 'BYTEA', + 'TIMESTAMP' => 'TIMESTAMP WITH TIME ZONE', ); =head1 NAME @@ -30,28 +36,55 @@ 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 + 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 $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]; + }; + + my $len = ''; + if ( $_->{attlen} == -1 && $_->{atttypmod} != -1 + && $_->{typname} ne 'text' ) { + $len = $_->{atttypmod} - 4; + if ( $_->{typname} eq 'numeric' ) { + $len = ($len >> 16). ','. ($len & 0xffff); + } + } + + my $type = $_->{'typname'}; + $type = 'char' if $type eq 'bpchar'; + [ $_->{'attname'}, - $_->{'typname'}, + $type, ! $_->{'attnotnull'}, - ( $_->{'attlen'} == -1 - ? $_->{'atttypmod'} - 4 - : '' - ), - '', #default + $len, + $default, '' #local - ] + ]; + } @{ $sth->fetchall_arrayref({}) }; } @@ -104,6 +137,7 @@ sub _index_fields { 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({}) }; @@ -121,6 +155,171 @@ END $row->{'indisunique'}; } +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', + '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 TABLE $table 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) = @_; + $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; +} + + =head1 AUTHOR Ivan Kohler @@ -129,6 +328,7 @@ Ivan Kohler Copyright (c) 2000 Ivan Kohler Copyright (c) 2000 Mail Abuse Prevention System LLC +Copyright (c) 2009 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.