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