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.20';
   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 substring(d.adsrc for 128) 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         warn $etc if $etc;
 204         +{ 'constraint' => $_->{conname},
 205            'columns'    => [ split(/,\s*/, $columns) ],
 206            'table'      => $table,
 207            'references' => [ split(/,\s*/, $references) ],
 208            'match'      => $match,
 209            'on_delete'  => $on_delete,
 210            'on_update'  => $on_update,
 211          };
 212       }
 213     grep $_->{condef} =~ /^\s*FOREIGN\s+KEY/,
 214       @{ $sth->fetchall_arrayref( {} ) };
 215 }
 216
 217 sub add_column_callback {
 218   my( $proto, $dbh, $table, $column_obj ) = @_;
 219   my $name = $column_obj->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 = { 'sql_after' => [], };
 229
 230   if ( $column_obj->type =~ /^(\w*)SERIAL$/i ) {
 231
 232     $hashref->{'effective_type'} = uc($1).'INT';
 233
 234     #needs more work for old Pg?
 235
 236     my $nextval;
 237     warn $warning if $warning;
 238     if ( $pg_server_version >= 70300 ) {
 239       my $db_schema  = default_db_schema();
 240       $nextval = "nextval('$db_schema.${table}_${name}_seq'::text)";
 241     } else {
 242       $nextval = "nextval('${table}_${name}_seq'::text)";
 243     }
 244
 245     push @{ $hashref->{'sql_after'} },
 246       "ALTER TABLE $table ALTER COLUMN $name SET DEFAULT $nextval",
 247       "CREATE SEQUENCE ${table}_${name}_seq",
 248       "UPDATE $table SET $name = $nextval WHERE $name IS NULL",
 249     ;
 250
 251   }
 252
 253   if ( ! $column_obj->null ) {
 254     $hashref->{'effective_null'} = 'NULL';
 255
 256     warn $warning if $warning;
 257     if ( $pg_server_version >= 70300 ) {
 258
 259       push @{ $hashref->{'sql_after'} },
 260         "ALTER TABLE $table ALTER $name SET NOT NULL";
 261
 262     } else {
 263
 264       push @{ $hashref->{'sql_after'} },
 265         "UPDATE pg_attribute SET attnotnull = TRUE ".
 266         " WHERE attname = '$name' ".
 267         " AND attrelid = ( SELECT oid FROM pg_class WHERE relname = '$table' )";
 268
 269     }
 270
 271   }
 272
 273   $hashref;
 274
 275 }
 276
 277 sub alter_column_callback {
 278   my( $proto, $dbh, $table, $old_column, $new_column ) = @_;
 279   my $name = $old_column->name;
 280
 281   my %canonical = (
 282     'SMALLINT'         => 'INT2',
 283     'INT'              => 'INT4',
 284     'BIGINT'           => 'INT8',
 285     'SERIAL'           => 'INT4',
 286     'BIGSERIAL'        => 'INT8',
 287     'DECIMAL'          => 'NUMERIC',
 288     'REAL'             => 'FLOAT4',
 289     'DOUBLE PRECISION' => 'FLOAT8',
 290     'BLOB'             => 'BYTEA',
 291     'TIMESTAMP'        => 'TIMESTAMPTZ',
 292   );
 293   foreach ($old_column, $new_column) {
 294     $_->type($canonical{uc($_->type)}) if $canonical{uc($_->type)};
 295   }
 296
 297   my $pg_server_version = $dbh->{'pg_server_version'};
 298   my $warning = '';
 299   unless ( $pg_server_version =~ /\d/ ) {
 300     $warning = "WARNING: no pg_server_version!  Assuming >= 7.3\n";
 301     $pg_server_version = 70300;
 302   }
 303
 304   my $hashref = {};
 305
 306   #change type
 307   if ( ( $canonical{uc($old_column->type)} || uc($old_column->type) )
 308          ne ( $canonical{uc($new_column->type)} || uc($new_column->type) )
 309        || $old_column->length ne $new_column->length
 310      )
 311   {
 312
 313     warn $warning if $warning;
 314     if ( $pg_server_version >= 80000 ) {
 315
 316       $hashref->{'sql_alter_type'} =
 317         "ALTER COLUMN ". $new_column->name.
 318         " TYPE ". $new_column->type.
 319         ( ( defined($new_column->length) && $new_column->length )
 320               ? '('.$new_column->length.')'
 321               : ''
 322         )
 323
 324     } else {
 325       warn "WARNING: can't yet change column types for Pg < version 8\n";
 326     }
 327
 328   }
 329
 330   # change nullability from NOT NULL to NULL
 331   if ( ! $old_column->null && $new_column->null ) {
 332
 333     warn $warning if $warning;
 334     if ( $pg_server_version < 70300 ) {
 335       $hashref->{'sql_alter_null'} =
 336         "UPDATE pg_attribute SET attnotnull = FALSE
 337           WHERE attname = '$name'
 338             AND attrelid = ( SELECT oid FROM pg_class
 339                                WHERE relname = '$table'
 340                            )";
 341     }
 342
 343   }
 344
 345   # change nullability from NULL to NOT NULL...
 346   # this one could be more complicated, need to set a DEFAULT value and update
 347   # the table first...
 348   if ( $old_column->null && ! $new_column->null ) {
 349
 350     warn $warning if $warning;
 351     if ( $pg_server_version < 70300 ) {
 352       $hashref->{'sql_alter_null'} =
 353         "UPDATE pg_attribute SET attnotnull = TRUE
 354            WHERE attname = '$name'
 355              AND attrelid = ( SELECT oid FROM pg_class
 356                                 WHERE relname = '$table'
 357                             )";
 358     }
 359
 360   }
 361
 362   $hashref;
 363
 364 }
 365
 366 sub column_value_needs_quoting {
 367   my($proto, $col) = @_;
 368   _type_needs_quoting($col->type);
 369 }
 370
 371 sub _type_needs_quoting {
 372   my $type = shift;
 373   $type !~ m{^(
 374                int(?:2|4|8)?
 375              | smallint
 376              | integer
 377              | bigint
 378              | (?:numeric|decimal)(?:\(\d+(?:\s*\,\s*\d+\))?)?
 379              | real
 380              | double\s+precision
 381              | float(?:\(\d+\))?
 382              | serial(?:4|8)?
 383              | bigserial
 384              )$}ix;
 385 }
 386
 387
 388 =head1 AUTHOR
 389
 390 Ivan Kohler <ivan-dbix-dbschema@420.am>
 391
 392 =head1 COPYRIGHT
 393
 394 Copyright (c) 2000 Ivan Kohler
 395 Copyright (c) 2000 Mail Abuse Prevention System LLC
 396 Copyright (c) 2009-2013 Freeside Internet Services, Inc.
 397 All rights reserved.
 398 This program is free software; you can redistribute it and/or modify it under
 399 the same terms as Perl itself.
 400
 401 =head1 BUGS
 402
 403 columns doesn't return column default information.
 404
 405 =head1 SEE ALSO
 406
 407 L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD>
 408
 409 =cut
 410
 411 1;
 412