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.15';
   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       my $db_schema  = default_db_schema();
 181       $nextval = "nextval('$db_schema.${table}_${name}_seq'::text)";
 182     } else {
 183       $nextval = "nextval('${table}_${name}_seq'::text)";
 184     }
 185
 186     push @{ $hashref->{'sql_after'} },
 187       "ALTER TABLE $table ALTER COLUMN $name SET DEFAULT $nextval",
 188       "CREATE SEQUENCE ${table}_${name}_seq",
 189       "UPDATE $table SET $name = $nextval WHERE $name IS NULL",
 190     ;
 191
 192   }
 193
 194   if ( ! $column_obj->null ) {
 195     $hashref->{'effective_null'} = 'NULL';
 196
 197     warn $warning if $warning;
 198     if ( $pg_server_version >= 70300 ) {
 199
 200       push @{ $hashref->{'sql_after'} },
 201         "ALTER TABLE $table ALTER $name SET NOT NULL";
 202
 203     } else {
 204
 205       push @{ $hashref->{'sql_after'} },
 206         "UPDATE pg_attribute SET attnotnull = TRUE ".
 207         " WHERE attname = '$name' ".
 208         " AND attrelid = ( SELECT oid FROM pg_class WHERE relname = '$table' )";
 209
 210     }
 211
 212   }
 213
 214   $hashref;
 215
 216 }
 217
 218 sub alter_column_callback {
 219   my( $proto, $dbh, $table, $old_column, $new_column ) = @_;
 220   my $name = $old_column->name;
 221
 222   my %canonical = (
 223     'SMALLINT'  => 'INT2',
 224     'INT'       => 'INT4',
 225     'BIGINT'    => 'INT8',
 226     'SERIAL'    => 'INT4',
 227     'BIGSERIAL' => 'INT8',
 228     'DECIMAL'   => 'NUMERIC',
 229     'REAL'      => 'FLOAT4',
 230     'BLOB'      => 'BYTEA',
 231     'TIMESTAMP' => 'TIMESTAMPTZ',
 232   );
 233   foreach ($old_column, $new_column) {
 234     $_->type($canonical{uc($_->type)}) if $canonical{uc($_->type)};
 235   }
 236
 237   my $pg_server_version = $dbh->{'pg_server_version'};
 238   my $warning = '';
 239   unless ( $pg_server_version =~ /\d/ ) {
 240     $warning = "WARNING: no pg_server_version!  Assuming >= 7.3\n";
 241     $pg_server_version = 70300;
 242   }
 243
 244   my $hashref = {};
 245
 246   #change type
 247   if ( ( $canonical{uc($old_column->type)} || uc($old_column->type) )
 248          ne ( $canonical{uc($new_column->type)} || uc($new_column->type) )
 249        || $old_column->length ne $new_column->length
 250      )
 251   {
 252
 253     warn $warning if $warning;
 254     if ( $pg_server_version >= 80000 ) {
 255
 256       $hashref->{'sql_alter_type'} =
 257         "ALTER TABLE $table ALTER COLUMN ". $new_column->name.
 258         " TYPE ". $new_column->type.
 259         ( ( defined($new_column->length) && $new_column->length )
 260               ? '('.$new_column->length.')'
 261               : ''
 262         )
 263
 264     } else {
 265       warn "WARNING: can't yet change column types for Pg < version 8\n";
 266     }
 267
 268   }
 269
 270   # change nullability from NOT NULL to NULL
 271   if ( ! $old_column->null && $new_column->null ) {
 272
 273     warn $warning if $warning;
 274     if ( $pg_server_version < 70300 ) {
 275       $hashref->{'sql_alter_null'} =
 276         "UPDATE pg_attribute SET attnotnull = FALSE
 277           WHERE attname = '$name'
 278             AND attrelid = ( SELECT oid FROM pg_class
 279                                WHERE relname = '$table'
 280                            )";
 281     }
 282
 283   }
 284
 285   # change nullability from NULL to NOT NULL...
 286   # this one could be more complicated, need to set a DEFAULT value and update
 287   # the table first...
 288   if ( $old_column->null && ! $new_column->null ) {
 289
 290     warn $warning if $warning;
 291     if ( $pg_server_version < 70300 ) {
 292       $hashref->{'sql_alter_null'} =
 293         "UPDATE pg_attribute SET attnotnull = TRUE
 294            WHERE attname = '$name'
 295              AND attrelid = ( SELECT oid FROM pg_class
 296                                 WHERE relname = '$table'
 297                             )";
 298     }
 299
 300   }
 301
 302   $hashref;
 303
 304 }
 305
 306 sub _column_value_needs_quoting {
 307   my($proto, $col) = @_;
 308   $col->type !~ m{^(
 309                     int(?:2|4|8)?
 310                   | smallint
 311                   | integer
 312                   | bigint
 313                   | (?:numeric|decimal)(?:\(\d+(?:\s*\,\s*\d+\))?)?
 314                   | real
 315                   | double\s+precision
 316                   | float(?:\(\d+\))?
 317                   | serial(?:4|8)?
 318                   | bigserial
 319                   )$}ix;
 320 }
 321
 322
 323 =head1 AUTHOR
 324
 325 Ivan Kohler <ivan-dbix-dbschema@420.am>
 326
 327 =head1 COPYRIGHT
 328
 329 Copyright (c) 2000 Ivan Kohler
 330 Copyright (c) 2000 Mail Abuse Prevention System LLC
 331 Copyright (c) 2009 Freeside Internet Services, Inc.
 332 All rights reserved.
 333 This program is free software; you can redistribute it and/or modify it under
 334 the same terms as Perl itself.
 335
 336 =head1 BUGS
 337
 338 Yes.
 339
 340 columns doesn't return column default information.
 341
 342 =head1 SEE ALSO
 343
 344 L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD>
 345
 346 =cut
 347
 348 1;
 349