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