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.17';
   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 $type = $_->{'typname'};
  56     $type = 'char' if $type eq 'bpchar';
  57
  58     my $len = '';
  59     if ( $_->{attlen} == -1 && $_->{atttypmod} != -1
  60          && $_->{typname} ne 'text'                  ) {
  61       $len = $_->{atttypmod} - 4;
  62       if ( $_->{typname} eq 'numeric' ) {
  63         $len = ($len >> 16). ','. ($len & 0xffff);
  64       }
  65     }
  66
  67     my $default = '';
  68     if ( $_->{atthasdef} ) {
  69       my $attnum = $_->{attnum};
  70       my $d_sth = $dbh->prepare(<<END) or die $dbh->errstr;
  71         SELECT substring(d.adsrc for 128) FROM pg_attrdef d, pg_class c
  72         WHERE c.relname = '$table' AND c.oid = d.adrelid AND d.adnum = $attnum
  73 END
  74       $d_sth->execute or die $d_sth->errstr;
  75
  76       $default = $d_sth->fetchrow_arrayref->[0];
  77
  78       if ( _type_needs_quoting($type) ) {
  79         $default =~ s/::([\w ]+)$//; #save typecast info?
  80         if ( $default =~ /^'(.*)'$/ ) {
  81           $default = $1;
  82           $default = \"''" if $default eq '';
  83         } else {
  84           my $value = $default;
  85           $default = \$value;
  86         }
  87       } elsif ( $default =~ /^[a-z]/i ) { #sloppy, but it'll do
  88         my $value = $default;
  89         $default = \$value;
  90       }
  91
  92     }
  93
  94     [
  95       $_->{'attname'},
  96       $type,
  97       ! $_->{'attnotnull'},
  98       $len,
  99       $default,
 100       ''  #local
 101     ];
 102
 103   } @{ $sth->fetchall_arrayref({}) };
 104 }
 105
 106 sub primary_key {
 107   my($proto, $dbh, $table) = @_;
 108   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
 109     SELECT a.attname, a.attnum
 110     FROM pg_class c, pg_attribute a, pg_type t
 111     WHERE c.relname = '${table}_pkey'
 112       AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid
 113 END
 114   $sth->execute or die $sth->errstr;
 115   my $row = $sth->fetchrow_hashref or return '';
 116   $row->{'attname'};
 117 }
 118
 119 sub unique {
 120   my($proto, $dbh, $table) = @_;
 121   my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] }
 122       grep { $proto->_is_unique($dbh, $_ ) }
 123         $proto->_all_indices($dbh, $table)
 124   };
 125 }
 126
 127 sub index {
 128   my($proto, $dbh, $table) = @_;
 129   my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] }
 130       grep { ! $proto->_is_unique($dbh, $_ ) }
 131         $proto->_all_indices($dbh, $table)
 132   };
 133 }
 134
 135 sub _all_indices {
 136   my($proto, $dbh, $table) = @_;
 137   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
 138     SELECT c2.relname
 139     FROM pg_class c, pg_class c2, pg_index i
 140     WHERE c.relname = '$table' AND c.oid = i.indrelid AND i.indexrelid = c2.oid
 141 END
 142   $sth->execute or die $sth->errstr;
 143   map { $_->{'relname'} }
 144     grep { $_->{'relname'} !~ /_pkey$/ }
 145       @{ $sth->fetchall_arrayref({}) };
 146 }
 147
 148 sub _index_fields {
 149   my($proto, $dbh, $index) = @_;
 150   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
 151     SELECT a.attname, a.attnum
 152     FROM pg_class c, pg_attribute a, pg_type t
 153     WHERE c.relname = '$index'
 154       AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid
 155     ORDER BY a.attnum
 156 END
 157   $sth->execute or die $sth->errstr;
 158   map { $_->{'attname'} } @{ $sth->fetchall_arrayref({}) };
 159 }
 160
 161 sub _is_unique {
 162   my($proto, $dbh, $index) = @_;
 163   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
 164     SELECT i.indisunique
 165     FROM pg_index i, pg_class c, pg_am a
 166     WHERE i.indexrelid = c.oid AND c.relname = '$index' AND c.relam = a.oid
 167 END
 168   $sth->execute or die $sth->errstr;
 169   my $row = $sth->fetchrow_hashref or die 'guru meditation #420';
 170   $row->{'indisunique'};
 171 }
 172
 173 sub add_column_callback {
 174   my( $proto, $dbh, $table, $column_obj ) = @_;
 175   my $name = $column_obj->name;
 176
 177   my $pg_server_version = $dbh->{'pg_server_version'};
 178   my $warning = '';
 179   unless ( $pg_server_version =~ /\d/ ) {
 180     $warning = "WARNING: no pg_server_version!  Assuming >= 7.3\n";
 181     $pg_server_version = 70300;
 182   }
 183
 184   my $hashref = { 'sql_after' => [], };
 185
 186   if ( $column_obj->type =~ /^(\w*)SERIAL$/i ) {
 187
 188     $hashref->{'effective_type'} = uc($1).'INT';
 189
 190     #needs more work for old Pg?
 191
 192     my $nextval;
 193     warn $warning if $warning;
 194     if ( $pg_server_version >= 70300 ) {
 195       my $db_schema  = default_db_schema();
 196       $nextval = "nextval('$db_schema.${table}_${name}_seq'::text)";
 197     } else {
 198       $nextval = "nextval('${table}_${name}_seq'::text)";
 199     }
 200
 201     push @{ $hashref->{'sql_after'} },
 202       "ALTER TABLE $table ALTER COLUMN $name SET DEFAULT $nextval",
 203       "CREATE SEQUENCE ${table}_${name}_seq",
 204       "UPDATE $table SET $name = $nextval WHERE $name IS NULL",
 205     ;
 206
 207   }
 208
 209   if ( ! $column_obj->null ) {
 210     $hashref->{'effective_null'} = 'NULL';
 211
 212     warn $warning if $warning;
 213     if ( $pg_server_version >= 70300 ) {
 214
 215       push @{ $hashref->{'sql_after'} },
 216         "ALTER TABLE $table ALTER $name SET NOT NULL";
 217
 218     } else {
 219
 220       push @{ $hashref->{'sql_after'} },
 221         "UPDATE pg_attribute SET attnotnull = TRUE ".
 222         " WHERE attname = '$name' ".
 223         " AND attrelid = ( SELECT oid FROM pg_class WHERE relname = '$table' )";
 224
 225     }
 226
 227   }
 228
 229   $hashref;
 230
 231 }
 232
 233 sub alter_column_callback {
 234   my( $proto, $dbh, $table, $old_column, $new_column ) = @_;
 235   my $name = $old_column->name;
 236
 237   my %canonical = (
 238     'SMALLINT'  => 'INT2',
 239     'INT'       => 'INT4',
 240     'BIGINT'    => 'INT8',
 241     'SERIAL'    => 'INT4',
 242     'BIGSERIAL' => 'INT8',
 243     'DECIMAL'   => 'NUMERIC',
 244     'REAL'      => 'FLOAT4',
 245     'BLOB'      => 'BYTEA',
 246     'TIMESTAMP' => 'TIMESTAMPTZ',
 247   );
 248   foreach ($old_column, $new_column) {
 249     $_->type($canonical{uc($_->type)}) if $canonical{uc($_->type)};
 250   }
 251
 252   my $pg_server_version = $dbh->{'pg_server_version'};
 253   my $warning = '';
 254   unless ( $pg_server_version =~ /\d/ ) {
 255     $warning = "WARNING: no pg_server_version!  Assuming >= 7.3\n";
 256     $pg_server_version = 70300;
 257   }
 258
 259   my $hashref = {};
 260
 261   #change type
 262   if ( ( $canonical{uc($old_column->type)} || uc($old_column->type) )
 263          ne ( $canonical{uc($new_column->type)} || uc($new_column->type) )
 264        || $old_column->length ne $new_column->length
 265      )
 266   {
 267
 268     warn $warning if $warning;
 269     if ( $pg_server_version >= 80000 ) {
 270
 271       $hashref->{'sql_alter_type'} =
 272         "ALTER TABLE $table ALTER COLUMN ". $new_column->name.
 273         " TYPE ". $new_column->type.
 274         ( ( defined($new_column->length) && $new_column->length )
 275               ? '('.$new_column->length.')'
 276               : ''
 277         )
 278
 279     } else {
 280       warn "WARNING: can't yet change column types for Pg < version 8\n";
 281     }
 282
 283   }
 284
 285   # change nullability from NOT NULL to NULL
 286   if ( ! $old_column->null && $new_column->null ) {
 287
 288     warn $warning if $warning;
 289     if ( $pg_server_version < 70300 ) {
 290       $hashref->{'sql_alter_null'} =
 291         "UPDATE pg_attribute SET attnotnull = FALSE
 292           WHERE attname = '$name'
 293             AND attrelid = ( SELECT oid FROM pg_class
 294                                WHERE relname = '$table'
 295                            )";
 296     }
 297
 298   }
 299
 300   # change nullability from NULL to NOT NULL...
 301   # this one could be more complicated, need to set a DEFAULT value and update
 302   # the table first...
 303   if ( $old_column->null && ! $new_column->null ) {
 304
 305     warn $warning if $warning;
 306     if ( $pg_server_version < 70300 ) {
 307       $hashref->{'sql_alter_null'} =
 308         "UPDATE pg_attribute SET attnotnull = TRUE
 309            WHERE attname = '$name'
 310              AND attrelid = ( SELECT oid FROM pg_class
 311                                 WHERE relname = '$table'
 312                             )";
 313     }
 314
 315   }
 316
 317   $hashref;
 318
 319 }
 320
 321 sub column_value_needs_quoting {
 322   my($proto, $col) = @_;
 323   _type_needs_quoting($col->type);
 324 }
 325
 326 sub _type_needs_quoting {
 327   my $type = shift;
 328   $type !~ m{^(
 329                int(?:2|4|8)?
 330              | smallint
 331              | integer
 332              | bigint
 333              | (?:numeric|decimal)(?:\(\d+(?:\s*\,\s*\d+\))?)?
 334              | real
 335              | double\s+precision
 336              | float(?:\(\d+\))?
 337              | serial(?:4|8)?
 338              | bigserial
 339              )$}ix;
 340 }
 341
 342
 343 =head1 AUTHOR
 344
 345 Ivan Kohler <ivan-dbix-dbschema@420.am>
 346
 347 =head1 COPYRIGHT
 348
 349 Copyright (c) 2000 Ivan Kohler
 350 Copyright (c) 2000 Mail Abuse Prevention System LLC
 351 Copyright (c) 2009-2010 Freeside Internet Services, Inc.
 352 All rights reserved.
 353 This program is free software; you can redistribute it and/or modify it under
 354 the same terms as Perl itself.
 355
 356 =head1 BUGS
 357
 358 Yes.
 359
 360 columns doesn't return column default information.
 361
 362 =head1 SEE ALSO
 363
 364 L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD>
 365
 366 =cut
 367
 368 1;
 369