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.13';
   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 sub _column_value_needs_quoting {
 267   my($proto, $col) = @_;
 268   $col->type !~ m{^(
 269                     int(?:2|4|8)?
 270                   | smallint
 271                   | integer
 272                   | bigint
 273                   | (?:numeric|decimal)(?:\(\d+(?:\s*\,\s*\d+\))?)?
 274                   | real
 275                   | double\s+precision
 276                   | float(?:\(\d+\))?
 277                   | serial(?:4|8)?
 278                   | bigserial
 279                   )$}x;
 280 }
 281
 282
 283 =head1 AUTHOR
 284
 285 Ivan Kohler <ivan-dbix-dbschema@420.am>
 286
 287 =head1 COPYRIGHT
 288
 289 Copyright (c) 2000 Ivan Kohler
 290 Copyright (c) 2000 Mail Abuse Prevention System LLC
 291 Copyright (c) 2007 Freeside Internet Services, Inc.
 292 All rights reserved.
 293 This program is free software; you can redistribute it and/or modify it under
 294 the same terms as Perl itself.
 295
 296 =head1 BUGS
 297
 298 Yes.
 299
 300 columns doesn't return column default information.
 301
 302 =head1 SEE ALSO
 303
 304 L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD>
 305
 306 =cut
 307
 308 1;
 309