DBSchema/DBD/Pg.pm

   1 package DBIx::DBSchema::DBD::Pg;
   2 use base qw(DBIx::DBSchema::DBD);
   3
   4 use strict;
   5 use DBD::Pg 1.32;
   6
   7 our $VERSION = '0.19';
   8
   9 die "DBD::Pg version 1.32 or 1.41 (or later) required--".
  10     "this is only version $DBD::Pg::VERSION\n"
  11   if $DBD::Pg::VERSION != 1.32 && $DBD::Pg::VERSION < 1.41;
  12
  13 our %typemap = (
  14   'BLOB'           => 'BYTEA',
  15   'LONG VARBINARY' => 'BYTEA',
  16   'TIMESTAMP'      => 'TIMESTAMP WITH TIME ZONE',
  17 );
  18
  19 =head1 NAME
  20
  21 DBIx::DBSchema::DBD::Pg - PostgreSQL native driver for DBIx::DBSchema
  22
  23 =head1 SYNOPSIS
  24
  25 use DBI;
  26 use DBIx::DBSchema;
  27
  28 $dbh = DBI->connect('dbi:Pg:dbname=database', 'user', 'pass');
  29 $schema = new_native DBIx::DBSchema $dbh;
  30
  31 =head1 DESCRIPTION
  32
  33 This module implements a PostgreSQL-native driver for DBIx::DBSchema.
  34
  35 =cut
  36
  37 sub default_db_schema  { 'public'; }
  38
  39 sub columns {
  40   my($proto, $dbh, $table) = @_;
  41   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
  42     SELECT a.attname, t.typname, a.attlen, a.atttypmod, a.attnotnull,
  43            a.atthasdef, a.attnum
  44     FROM pg_class c, pg_attribute a, pg_type t
  45     WHERE c.relname = '$table'
  46       AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid
  47     ORDER BY a.attnum
  48 END
  49   $sth->execute or die $sth->errstr;
  50
  51   map {
  52
  53     my $type = $_->{'typname'};
  54     $type = 'char' if $type eq 'bpchar';
  55
  56     my $len = '';
  57     if ( $_->{attlen} == -1 && $_->{atttypmod} != -1
  58          && $_->{typname} ne 'text'                  ) {
  59       $len = $_->{atttypmod} - 4;
  60       if ( $_->{typname} eq 'numeric' ) {
  61         $len = ($len >> 16). ','. ($len & 0xffff);
  62       }
  63     }
  64
  65     my $default = '';
  66     if ( $_->{atthasdef} ) {
  67       my $attnum = $_->{attnum};
  68       my $d_sth = $dbh->prepare(<<END) or die $dbh->errstr;
  69         SELECT substring(d.adsrc for 128) FROM pg_attrdef d, pg_class c
  70         WHERE c.relname = '$table' AND c.oid = d.adrelid AND d.adnum = $attnum
  71 END
  72       $d_sth->execute or die $d_sth->errstr;
  73
  74       $default = $d_sth->fetchrow_arrayref->[0];
  75
  76       if ( _type_needs_quoting($type) ) {
  77         $default =~ s/::([\w ]+)$//; #save typecast info?
  78         if ( $default =~ /^'(.*)'$/ ) {
  79           $default = $1;
  80           $default = \"''" if $default eq '';
  81         } else {
  82           my $value = $default;
  83           $default = \$value;
  84         }
  85       } elsif ( $default =~ /^[a-z]/i ) { #sloppy, but it'll do
  86         my $value = $default;
  87         $default = \$value;
  88       }
  89
  90     }
  91
  92     [
  93       $_->{'attname'},
  94       $type,
  95       ! $_->{'attnotnull'},
  96       $len,
  97       $default,
  98       ''  #local
  99     ];
 100
 101   } @{ $sth->fetchall_arrayref({}) };
 102 }
 103
 104 sub primary_key {
 105   my($proto, $dbh, $table) = @_;
 106   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
 107     SELECT a.attname, a.attnum
 108     FROM pg_class c, pg_attribute a, pg_type t
 109     WHERE c.relname = '${table}_pkey'
 110       AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid
 111 END
 112   $sth->execute or die $sth->errstr;
 113   my $row = $sth->fetchrow_hashref or return '';
 114   $row->{'attname'};
 115 }
 116
 117 sub unique {
 118   my($proto, $dbh, $table) = @_;
 119   my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] }
 120       grep { $proto->_is_unique($dbh, $_ ) }
 121         $proto->_all_indices($dbh, $table)
 122   };
 123 }
 124
 125 sub index {
 126   my($proto, $dbh, $table) = @_;
 127   my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] }
 128       grep { ! $proto->_is_unique($dbh, $_ ) }
 129         $proto->_all_indices($dbh, $table)
 130   };
 131 }
 132
 133 sub _all_indices {
 134   my($proto, $dbh, $table) = @_;
 135   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
 136     SELECT c2.relname
 137     FROM pg_class c, pg_class c2, pg_index i
 138     WHERE c.relname = '$table' AND c.oid = i.indrelid AND i.indexrelid = c2.oid
 139 END
 140   $sth->execute or die $sth->errstr;
 141   map { $_->{'relname'} }
 142     grep { $_->{'relname'} !~ /_pkey$/ }
 143       @{ $sth->fetchall_arrayref({}) };
 144 }
 145
 146 sub _index_fields {
 147   my($proto, $dbh, $index) = @_;
 148   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
 149     SELECT a.attname, a.attnum
 150     FROM pg_class c, pg_attribute a, pg_type t
 151     WHERE c.relname = '$index'
 152       AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid
 153     ORDER BY a.attnum
 154 END
 155   $sth->execute or die $sth->errstr;
 156   map { $_->{'attname'} } @{ $sth->fetchall_arrayref({}) };
 157 }
 158
 159 sub _is_unique {
 160   my($proto, $dbh, $index) = @_;
 161   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
 162     SELECT i.indisunique
 163     FROM pg_index i, pg_class c, pg_am a
 164     WHERE i.indexrelid = c.oid AND c.relname = '$index' AND c.relam = a.oid
 165 END
 166   $sth->execute or die $sth->errstr;
 167   my $row = $sth->fetchrow_hashref or die 'guru meditation #420';
 168   $row->{'indisunique'};
 169 }
 170
 171 #using this
 172 #******** QUERY **********
 173 #SELECT conname,
 174 #  pg_catalog.pg_get_constraintdef(r.oid, true) as condef
 175 #FROM pg_catalog.pg_constraint r
 176 #WHERE r.conrelid = '16457' AND r.contype = 'f' ORDER BY 1;
 177 #**************************
 178
 179 # what's this do?
 180 #********* QUERY **********
 181 #SELECT conname, conrelid::pg_catalog.regclass,
 182 #  pg_catalog.pg_get_constraintdef(c.oid, true) as condef
 183 #FROM pg_catalog.pg_constraint c
 184 #WHERE c.confrelid = '16457' AND c.contype = 'f' ORDER BY 1;
 185 #**************************
 186
 187 sub constraints {
 188   my($proto, $dbh, $table) = @_;
 189   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
 190     SELECT conname, pg_catalog.pg_get_constraintdef(r.oid, true) as condef
 191       FROM pg_catalog.pg_constraint r
 192         WHERE r.conrelid = ( SELECT oid FROM pg_class
 193                                WHERE relname = '$table'
 194                                  AND pg_catalog.pg_table_is_visible(oid)
 195                            )
 196           AND r.contype = 'f'
 197 END
 198   $sth->execute;
 199
 200   map { $_->{condef}
 201           =~ /^FOREIGN KEY \(([\w\, ]+)\) REFERENCES (\w+)\(([\w\, ]+)\)\s*(.*)$/
 202             or die "unparsable constraint: ". $_->{condef};
 203         my($columns, $table, $references, $etc ) = ($1, $2, $3, $4);
 204         +{ 'constraint' => $_->{conname},
 205            'columns'    => [ split(/,\s*/, $columns) ],
 206            'table'      => $table,
 207            'references' => [ split(/,\s*/, $references) ],
 208            #XXX $etc not handled yet for MATCH, ON DELETE, ON UPDATE
 209          };
 210       }
 211     grep $_->{condef} =~ /^\s*FOREIGN\s+KEY/,
 212       @{ $sth->fetchall_arrayref( {} ) };
 213 }
 214
 215 sub add_column_callback {
 216   my( $proto, $dbh, $table, $column_obj ) = @_;
 217   my $name = $column_obj->name;
 218
 219   my $pg_server_version = $dbh->{'pg_server_version'};
 220   my $warning = '';
 221   unless ( $pg_server_version =~ /\d/ ) {
 222     $warning = "WARNING: no pg_server_version!  Assuming >= 7.3\n";
 223     $pg_server_version = 70300;
 224   }
 225
 226   my $hashref = { 'sql_after' => [], };
 227
 228   if ( $column_obj->type =~ /^(\w*)SERIAL$/i ) {
 229
 230     $hashref->{'effective_type'} = uc($1).'INT';
 231
 232     #needs more work for old Pg?
 233
 234     my $nextval;
 235     warn $warning if $warning;
 236     if ( $pg_server_version >= 70300 ) {
 237       my $db_schema  = default_db_schema();
 238       $nextval = "nextval('$db_schema.${table}_${name}_seq'::text)";
 239     } else {
 240       $nextval = "nextval('${table}_${name}_seq'::text)";
 241     }
 242
 243     push @{ $hashref->{'sql_after'} },
 244       "ALTER TABLE $table ALTER COLUMN $name SET DEFAULT $nextval",
 245       "CREATE SEQUENCE ${table}_${name}_seq",
 246       "UPDATE $table SET $name = $nextval WHERE $name IS NULL",
 247     ;
 248
 249   }
 250
 251   if ( ! $column_obj->null ) {
 252     $hashref->{'effective_null'} = 'NULL';
 253
 254     warn $warning if $warning;
 255     if ( $pg_server_version >= 70300 ) {
 256
 257       push @{ $hashref->{'sql_after'} },
 258         "ALTER TABLE $table ALTER $name SET NOT NULL";
 259
 260     } else {
 261
 262       push @{ $hashref->{'sql_after'} },
 263         "UPDATE pg_attribute SET attnotnull = TRUE ".
 264         " WHERE attname = '$name' ".
 265         " AND attrelid = ( SELECT oid FROM pg_class WHERE relname = '$table' )";
 266
 267     }
 268
 269   }
 270
 271   $hashref;
 272
 273 }
 274
 275 sub alter_column_callback {
 276   my( $proto, $dbh, $table, $old_column, $new_column ) = @_;
 277   my $name = $old_column->name;
 278
 279   my %canonical = (
 280     'SMALLINT'         => 'INT2',
 281     'INT'              => 'INT4',
 282     'BIGINT'           => 'INT8',
 283     'SERIAL'           => 'INT4',
 284     'BIGSERIAL'        => 'INT8',
 285     'DECIMAL'          => 'NUMERIC',
 286     'REAL'             => 'FLOAT4',
 287     'DOUBLE PRECISION' => 'FLOAT8',
 288     'BLOB'             => 'BYTEA',
 289     'TIMESTAMP'        => 'TIMESTAMPTZ',
 290   );
 291   foreach ($old_column, $new_column) {
 292     $_->type($canonical{uc($_->type)}) if $canonical{uc($_->type)};
 293   }
 294
 295   my $pg_server_version = $dbh->{'pg_server_version'};
 296   my $warning = '';
 297   unless ( $pg_server_version =~ /\d/ ) {
 298     $warning = "WARNING: no pg_server_version!  Assuming >= 7.3\n";
 299     $pg_server_version = 70300;
 300   }
 301
 302   my $hashref = {};
 303
 304   #change type
 305   if ( ( $canonical{uc($old_column->type)} || uc($old_column->type) )
 306          ne ( $canonical{uc($new_column->type)} || uc($new_column->type) )
 307        || $old_column->length ne $new_column->length
 308      )
 309   {
 310
 311     warn $warning if $warning;
 312     if ( $pg_server_version >= 80000 ) {
 313
 314       $hashref->{'sql_alter_type'} =
 315         "ALTER COLUMN ". $new_column->name.
 316         " TYPE ". $new_column->type.
 317         ( ( defined($new_column->length) && $new_column->length )
 318               ? '('.$new_column->length.')'
 319               : ''
 320         )
 321
 322     } else {
 323       warn "WARNING: can't yet change column types for Pg < version 8\n";
 324     }
 325
 326   }
 327
 328   # change nullability from NOT NULL to NULL
 329   if ( ! $old_column->null && $new_column->null ) {
 330
 331     warn $warning if $warning;
 332     if ( $pg_server_version < 70300 ) {
 333       $hashref->{'sql_alter_null'} =
 334         "UPDATE pg_attribute SET attnotnull = FALSE
 335           WHERE attname = '$name'
 336             AND attrelid = ( SELECT oid FROM pg_class
 337                                WHERE relname = '$table'
 338                            )";
 339     }
 340
 341   }
 342
 343   # change nullability from NULL to NOT NULL...
 344   # this one could be more complicated, need to set a DEFAULT value and update
 345   # the table first...
 346   if ( $old_column->null && ! $new_column->null ) {
 347
 348     warn $warning if $warning;
 349     if ( $pg_server_version < 70300 ) {
 350       $hashref->{'sql_alter_null'} =
 351         "UPDATE pg_attribute SET attnotnull = TRUE
 352            WHERE attname = '$name'
 353              AND attrelid = ( SELECT oid FROM pg_class
 354                                 WHERE relname = '$table'
 355                             )";
 356     }
 357
 358   }
 359
 360   $hashref;
 361
 362 }
 363
 364 sub column_value_needs_quoting {
 365   my($proto, $col) = @_;
 366   _type_needs_quoting($col->type);
 367 }
 368
 369 sub _type_needs_quoting {
 370   my $type = shift;
 371   $type !~ m{^(
 372                int(?:2|4|8)?
 373              | smallint
 374              | integer
 375              | bigint
 376              | (?:numeric|decimal)(?:\(\d+(?:\s*\,\s*\d+\))?)?
 377              | real
 378              | double\s+precision
 379              | float(?:\(\d+\))?
 380              | serial(?:4|8)?
 381              | bigserial
 382              )$}ix;
 383 }
 384
 385
 386 =head1 AUTHOR
 387
 388 Ivan Kohler <ivan-dbix-dbschema@420.am>
 389
 390 =head1 COPYRIGHT
 391
 392 Copyright (c) 2000 Ivan Kohler
 393 Copyright (c) 2000 Mail Abuse Prevention System LLC
 394 Copyright (c) 2009-2013 Freeside Internet Services, Inc.
 395 All rights reserved.
 396 This program is free software; you can redistribute it and/or modify it under
 397 the same terms as Perl itself.
 398
 399 =head1 BUGS
 400
 401 columns doesn't return column default information.
 402
 403 =head1 SEE ALSO
 404
 405 L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD>
 406
 407 =cut
 408
 409 1;
 410