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.18';
   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     'DOUBLE PRECISION' => 'FLOAT8',
 246     'BLOB'             => 'BYTEA',
 247     'TIMESTAMP'        => 'TIMESTAMPTZ',
 248   );
 249   foreach ($old_column, $new_column) {
 250     $_->type($canonical{uc($_->type)}) if $canonical{uc($_->type)};
 251   }
 252
 253   my $pg_server_version = $dbh->{'pg_server_version'};
 254   my $warning = '';
 255   unless ( $pg_server_version =~ /\d/ ) {
 256     $warning = "WARNING: no pg_server_version!  Assuming >= 7.3\n";
 257     $pg_server_version = 70300;
 258   }
 259
 260   my $hashref = {};
 261
 262   #change type
 263   if ( ( $canonical{uc($old_column->type)} || uc($old_column->type) )
 264          ne ( $canonical{uc($new_column->type)} || uc($new_column->type) )
 265        || $old_column->length ne $new_column->length
 266      )
 267   {
 268
 269     warn $warning if $warning;
 270     if ( $pg_server_version >= 80000 ) {
 271
 272       $hashref->{'sql_alter_type'} =
 273         "ALTER COLUMN ". $new_column->name.
 274         " TYPE ". $new_column->type.
 275         ( ( defined($new_column->length) && $new_column->length )
 276               ? '('.$new_column->length.')'
 277               : ''
 278         )
 279
 280     } else {
 281       warn "WARNING: can't yet change column types for Pg < version 8\n";
 282     }
 283
 284   }
 285
 286   # change nullability from NOT NULL to NULL
 287   if ( ! $old_column->null && $new_column->null ) {
 288
 289     warn $warning if $warning;
 290     if ( $pg_server_version < 70300 ) {
 291       $hashref->{'sql_alter_null'} =
 292         "UPDATE pg_attribute SET attnotnull = FALSE
 293           WHERE attname = '$name'
 294             AND attrelid = ( SELECT oid FROM pg_class
 295                                WHERE relname = '$table'
 296                            )";
 297     }
 298
 299   }
 300
 301   # change nullability from NULL to NOT NULL...
 302   # this one could be more complicated, need to set a DEFAULT value and update
 303   # the table first...
 304   if ( $old_column->null && ! $new_column->null ) {
 305
 306     warn $warning if $warning;
 307     if ( $pg_server_version < 70300 ) {
 308       $hashref->{'sql_alter_null'} =
 309         "UPDATE pg_attribute SET attnotnull = TRUE
 310            WHERE attname = '$name'
 311              AND attrelid = ( SELECT oid FROM pg_class
 312                                 WHERE relname = '$table'
 313                             )";
 314     }
 315
 316   }
 317
 318   $hashref;
 319
 320 }
 321
 322 sub column_value_needs_quoting {
 323   my($proto, $col) = @_;
 324   _type_needs_quoting($col->type);
 325 }
 326
 327 sub _type_needs_quoting {
 328   my $type = shift;
 329   $type !~ m{^(
 330                int(?:2|4|8)?
 331              | smallint
 332              | integer
 333              | bigint
 334              | (?:numeric|decimal)(?:\(\d+(?:\s*\,\s*\d+\))?)?
 335              | real
 336              | double\s+precision
 337              | float(?:\(\d+\))?
 338              | serial(?:4|8)?
 339              | bigserial
 340              )$}ix;
 341 }
 342
 343
 344 =head1 AUTHOR
 345
 346 Ivan Kohler <ivan-dbix-dbschema@420.am>
 347
 348 =head1 COPYRIGHT
 349
 350 Copyright (c) 2000 Ivan Kohler
 351 Copyright (c) 2000 Mail Abuse Prevention System LLC
 352 Copyright (c) 2009-2013 Freeside Internet Services, Inc.
 353 All rights reserved.
 354 This program is free software; you can redistribute it and/or modify it under
 355 the same terms as Perl itself.
 356
 357 =head1 BUGS
 358
 359 Yes.
 360
 361 columns doesn't return column default information.
 362
 363 =head1 SEE ALSO
 364
 365 L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD>
 366
 367 =cut
 368
 369 1;
 370