DBSchema/DBD/Pg.pm

   1 package DBIx::DBSchema::DBD::Pg;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA %typemap);
   5 use DBD::Pg 1.32;
   6 use DBIx::DBSchema::DBD;
   7
   8 $VERSION = '0.12';
   9 @ISA = qw(DBIx::DBSchema::DBD);
  10
  11 die "DBD::Pg version 1.32 or 1.41 (or later) required--".
  12     "this is only version $DBD::Pg::VERSION\n"
  13   if $DBD::Pg::VERSION != 1.32 && $DBD::Pg::VERSION < 1.41;
  14
  15 %typemap = (
  16   'BLOB'           => 'BYTEA',
  17   'LONG VARBINARY' => 'BYTEA',
  18   'TIMESTAMP'      => 'TIMESTAMP WITH TIME ZONE',
  19 );
  20
  21 =head1 NAME
  22
  23 DBIx::DBSchema::DBD::Pg - PostgreSQL native driver for DBIx::DBSchema
  24
  25 =head1 SYNOPSIS
  26
  27 use DBI;
  28 use DBIx::DBSchema;
  29
  30 $dbh = DBI->connect('dbi:Pg:dbname=database', 'user', 'pass');
  31 $schema = new_native DBIx::DBSchema $dbh;
  32
  33 =head1 DESCRIPTION
  34
  35 This module implements a PostgreSQL-native driver for DBIx::DBSchema.
  36
  37 =cut
  38
  39 sub default_db_schema  { 'public'; }
  40
  41 sub columns {
  42   my($proto, $dbh, $table) = @_;
  43   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
  44     SELECT a.attname, t.typname, a.attlen, a.atttypmod, a.attnotnull,
  45            a.atthasdef, a.attnum
  46     FROM pg_class c, pg_attribute a, pg_type t
  47     WHERE c.relname = '$table'
  48       AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid
  49     ORDER BY a.attnum
  50 END
  51   $sth->execute or die $sth->errstr;
  52
  53   map {
  54
  55     my $default = '';
  56     if ( $_->{atthasdef} ) {
  57       my $attnum = $_->{attnum};
  58       my $d_sth = $dbh->prepare(<<END) or die $dbh->errstr;
  59         SELECT substring(d.adsrc for 128) FROM pg_attrdef d, pg_class c
  60         WHERE c.relname = '$table' AND c.oid = d.adrelid AND d.adnum = $attnum
  61 END
  62       $d_sth->execute or die $d_sth->errstr;
  63
  64       $default = $d_sth->fetchrow_arrayref->[0];
  65     };
  66
  67     my $len = '';
  68     if ( $_->{attlen} == -1 && $_->{atttypmod} != -1
  69          && $_->{typname} ne 'text'                  ) {
  70       $len = $_->{atttypmod} - 4;
  71       if ( $_->{typname} eq 'numeric' ) {
  72         $len = ($len >> 16). ','. ($len & 0xffff);
  73       }
  74     }
  75
  76     my $type = $_->{'typname'};
  77     $type = 'char' if $type eq 'bpchar';
  78
  79     [
  80       $_->{'attname'},
  81       $type,
  82       ! $_->{'attnotnull'},
  83       $len,
  84       $default,
  85       ''  #local
  86     ];
  87
  88   } @{ $sth->fetchall_arrayref({}) };
  89 }
  90
  91 sub primary_key {
  92   my($proto, $dbh, $table) = @_;
  93   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
  94     SELECT a.attname, a.attnum
  95     FROM pg_class c, pg_attribute a, pg_type t
  96     WHERE c.relname = '${table}_pkey'
  97       AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid
  98 END
  99   $sth->execute or die $sth->errstr;
 100   my $row = $sth->fetchrow_hashref or return '';
 101   $row->{'attname'};
 102 }
 103
 104 sub unique {
 105   my($proto, $dbh, $table) = @_;
 106   my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] }
 107       grep { $proto->_is_unique($dbh, $_ ) }
 108         $proto->_all_indices($dbh, $table)
 109   };
 110 }
 111
 112 sub index {
 113   my($proto, $dbh, $table) = @_;
 114   my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] }
 115       grep { ! $proto->_is_unique($dbh, $_ ) }
 116         $proto->_all_indices($dbh, $table)
 117   };
 118 }
 119
 120 sub _all_indices {
 121   my($proto, $dbh, $table) = @_;
 122   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
 123     SELECT c2.relname
 124     FROM pg_class c, pg_class c2, pg_index i
 125     WHERE c.relname = '$table' AND c.oid = i.indrelid AND i.indexrelid = c2.oid
 126 END
 127   $sth->execute or die $sth->errstr;
 128   map { $_->{'relname'} }
 129     grep { $_->{'relname'} !~ /_pkey$/ }
 130       @{ $sth->fetchall_arrayref({}) };
 131 }
 132
 133 sub _index_fields {
 134   my($proto, $dbh, $index) = @_;
 135   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
 136     SELECT a.attname, a.attnum
 137     FROM pg_class c, pg_attribute a, pg_type t
 138     WHERE c.relname = '$index'
 139       AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid
 140     ORDER BY a.attnum
 141 END
 142   $sth->execute or die $sth->errstr;
 143   map { $_->{'attname'} } @{ $sth->fetchall_arrayref({}) };
 144 }
 145
 146 sub _is_unique {
 147   my($proto, $dbh, $index) = @_;
 148   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
 149     SELECT i.indisunique
 150     FROM pg_index i, pg_class c, pg_am a
 151     WHERE i.indexrelid = c.oid AND c.relname = '$index' AND c.relam = a.oid
 152 END
 153   $sth->execute or die $sth->errstr;
 154   my $row = $sth->fetchrow_hashref or die 'guru meditation #420';
 155   $row->{'indisunique'};
 156 }
 157
 158 sub add_column_callback {
 159   my( $proto, $dbh, $table, $column_obj ) = @_;
 160   my $name = $column_obj->name;
 161
 162   my $pg_server_version = $dbh->{'pg_server_version'};
 163   my $warning = '';
 164   unless ( $pg_server_version =~ /\d/ ) {
 165     $warning = "WARNING: no pg_server_version!  Assuming >= 7.3\n";
 166     $pg_server_version = 70300;
 167   }
 168
 169   my $hashref = { 'sql_after' => [], };
 170
 171   if ( $column_obj->type =~ /^(\w*)SERIAL$/i ) {
 172
 173     $hashref->{'effective_type'} = uc($1).'INT';
 174
 175     #needs more work for old Pg?
 176
 177     my $nextval;
 178     warn $warning if $warning;
 179     if ( $pg_server_version >= 70300 ) {
 180       $nextval = "nextval('public.${table}_${name}_seq'::text)";
 181     } else {
 182       $nextval = "nextval('${table}_${name}_seq'::text)";
 183     }
 184
 185     push @{ $hashref->{'sql_after'} },
 186       "ALTER TABLE $table ALTER COLUMN $name SET DEFAULT $nextval",
 187       "CREATE SEQUENCE ${table}_${name}_seq",
 188       "UPDATE $table SET $name = $nextval WHERE $name IS NULL",
 189     ;
 190
 191   }
 192
 193   if ( ! $column_obj->null ) {
 194     $hashref->{'effective_null'} = 'NULL';
 195
 196     warn $warning if $warning;
 197     if ( $pg_server_version >= 70300 ) {
 198
 199       push @{ $hashref->{'sql_after'} },
 200         "ALTER TABLE $table ALTER $name SET NOT NULL";
 201
 202     } else {
 203
 204       push @{ $hashref->{'sql_after'} },
 205         "UPDATE pg_attribute SET attnotnull = TRUE ".
 206         " WHERE attname = '$name' ".
 207         " AND attrelid = ( SELECT oid FROM pg_class WHERE relname = '$table' )";
 208
 209     }
 210
 211   }
 212
 213   $hashref;
 214
 215 }
 216
 217 sub alter_column_callback {
 218   my( $proto, $dbh, $table, $old_column, $new_column ) = @_;
 219   my $name = $old_column->name;
 220
 221   my $pg_server_version = $dbh->{'pg_server_version'};
 222   my $warning = '';
 223   unless ( $pg_server_version =~ /\d/ ) {
 224     $warning = "WARNING: no pg_server_version!  Assuming >= 7.3\n";
 225     $pg_server_version = 70300;
 226   }
 227
 228   my $hashref = {};
 229
 230   # change nullability from NOT NULL to NULL
 231   if ( ! $old_column->null && $new_column->null ) {
 232
 233     warn $warning if $warning;
 234     if ( $pg_server_version < 70300 ) {
 235       $hashref->{'sql_alter_null'} =
 236         "UPDATE pg_attribute SET attnotnull = FALSE
 237           WHERE attname = '$name'
 238             AND attrelid = ( SELECT oid FROM pg_class
 239                                WHERE relname = '$table'
 240                            )";
 241     }
 242
 243   }
 244
 245   # change nullability from NULL to NOT NULL...
 246   # this one could be more complicated, need to set a DEFAULT value and update
 247   # the table first...
 248   if ( $old_column->null && ! $new_column->null ) {
 249
 250     warn $warning if $warning;
 251     if ( $pg_server_version < 70300 ) {
 252       $hashref->{'sql_alter_null'} =
 253         "UPDATE pg_attribute SET attnotnull = TRUE
 254            WHERE attname = '$name'
 255              AND attrelid = ( SELECT oid FROM pg_class
 256                                 WHERE relname = '$table'
 257                             )";
 258     }
 259
 260   }
 261
 262   $hashref;
 263
 264 }
 265
 266 =head1 AUTHOR
 267
 268 Ivan Kohler <ivan-dbix-dbschema@420.am>
 269
 270 =head1 COPYRIGHT
 271
 272 Copyright (c) 2000 Ivan Kohler
 273 Copyright (c) 2000 Mail Abuse Prevention System LLC
 274 Copyright (c) 2007 Freeside Internet Services, Inc.
 275 All rights reserved.
 276 This program is free software; you can redistribute it and/or modify it under
 277 the same terms as Perl itself.
 278
 279 =head1 BUGS
 280
 281 Yes.
 282
 283 columns doesn't return column default information.
 284
 285 =head1 SEE ALSO
 286
 287 L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD>
 288
 289 =cut
 290
 291 1;
 292