lib/DBIx/Class/Schema/Loader/DBI/Pg.pm

   1 package DBIx::Class::Schema::Loader::DBI::Pg;
   2
   3 use strict;
   4 use warnings;
   5 use base qw/
   6     DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault
   7     DBIx::Class::Schema::Loader::DBI
   8 /;
   9 use Carp::Clan qw/^DBIx::Class/;
  10 use Class::C3;
  11
  12 our $VERSION = '0.07000';
  13
  14 =head1 NAME
  15
  16 DBIx::Class::Schema::Loader::DBI::Pg - DBIx::Class::Schema::Loader::DBI
  17 PostgreSQL Implementation.
  18
  19 =head1 SYNOPSIS
  20
  21   package My::Schema;
  22   use base qw/DBIx::Class::Schema::Loader/;
  23
  24   __PACKAGE__->loader_options( debug => 1 );
  25
  26   1;
  27
  28 =head1 DESCRIPTION
  29
  30 See L<DBIx::Class::Schema::Loader::Base>.
  31
  32 =cut
  33
  34 sub _setup {
  35     my $self = shift;
  36
  37     $self->next::method(@_);
  38
  39     $self->{db_schema} ||= 'public';
  40
  41     if (not defined $self->preserve_case) {
  42         $self->preserve_case(0);
  43     }
  44     elsif ($self->preserve_case) {
  45         $self->schema->storage->sql_maker->quote_char('"');
  46         $self->schema->storage->sql_maker->name_sep('.');
  47     }
  48 }
  49
  50 sub _table_uniq_info {
  51     my ($self, $table) = @_;
  52
  53     # Use the default support if available
  54     return $self->next::method($table)
  55         if $DBD::Pg::VERSION >= 1.50;
  56
  57     my @uniqs;
  58     my $dbh = $self->schema->storage->dbh;
  59
  60     # Most of the SQL here is mostly based on
  61     #   Rose::DB::Object::Metadata::Auto::Pg, after some prodding from
  62     #   John Siracusa to use his superior SQL code :)
  63
  64     my $attr_sth = $self->{_cache}->{pg_attr_sth} ||= $dbh->prepare(
  65         q{SELECT attname FROM pg_catalog.pg_attribute
  66         WHERE attrelid = ? AND attnum = ?}
  67     );
  68
  69     my $uniq_sth = $self->{_cache}->{pg_uniq_sth} ||= $dbh->prepare(
  70         q{SELECT x.indrelid, i.relname, x.indkey
  71         FROM
  72           pg_catalog.pg_index x
  73           JOIN pg_catalog.pg_class c ON c.oid = x.indrelid
  74           JOIN pg_catalog.pg_class i ON i.oid = x.indexrelid
  75           JOIN pg_catalog.pg_constraint con ON con.conname = i.relname
  76           LEFT JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace
  77         WHERE
  78           x.indisunique = 't' AND
  79           c.relkind     = 'r' AND
  80           i.relkind     = 'i' AND
  81           con.contype   = 'u' AND
  82           n.nspname     = ? AND
  83           c.relname     = ?}
  84     );
  85
  86     $uniq_sth->execute($self->db_schema, $table);
  87     while(my $row = $uniq_sth->fetchrow_arrayref) {
  88         my ($tableid, $indexname, $col_nums) = @$row;
  89         $col_nums =~ s/^\s+//;
  90         my @col_nums = split(/\s+/, $col_nums);
  91         my @col_names;
  92
  93         foreach (@col_nums) {
  94             $attr_sth->execute($tableid, $_);
  95             my $name_aref = $attr_sth->fetchrow_arrayref;
  96             push(@col_names, $name_aref->[0]) if $name_aref;
  97         }
  98
  99         if(!@col_names) {
 100             warn "Failed to parse UNIQUE constraint $indexname on $table";
 101         }
 102         else {
 103             push(@uniqs, [ $indexname => \@col_names ]);
 104         }
 105     }
 106
 107     return \@uniqs;
 108 }
 109
 110 sub _table_comment {
 111     my ( $self, $table ) = @_;
 112      my ($table_comment) = $self->schema->storage->dbh->selectrow_array(
 113         q{SELECT obj_description(oid)
 114             FROM pg_class
 115             WHERE relname=? AND relnamespace=(
 116                 SELECT oid FROM pg_namespace WHERE nspname=?)
 117         }, undef, $table, $self->db_schema
 118         );
 119     return $table_comment
 120 }
 121
 122
 123 sub _column_comment {
 124     my ( $self, $table, $column_number ) = @_;
 125      my ($table_oid) = $self->schema->storage->dbh->selectrow_array(
 126         q{SELECT oid
 127             FROM pg_class
 128             WHERE relname=? AND relnamespace=(
 129                 SELECT oid FROM pg_namespace WHERE nspname=?)
 130         }, undef, $table, $self->db_schema
 131         );
 132     return $self->schema->storage->dbh->selectrow_array('SELECT col_description(?,?)', undef, $table_oid,
 133     $column_number );
 134 }
 135
 136 # Make sure data_type's that don't need it don't have a 'size' column_info, and
 137 # set the correct precision for datetime and varbit types.
 138 sub _columns_info_for {
 139     my $self = shift;
 140     my ($table) = @_;
 141
 142     my $result = $self->next::method(@_);
 143
 144     while (my ($col, $info) = each %$result) {
 145         my $data_type = $info->{data_type};
 146
 147         # these types are fixed size
 148         if ($data_type =~
 149 /^(?:bigint|int8|bigserial|serial8|boolean|bool|box|bytea|cidr|circle|date|double precision|float8|inet|integer|int|int4|line|lseg|macaddr|money|path|point|polygon|real|float4|smallint|int2|serial|serial4|text)\z/i) {
 150             delete $info->{size};
 151         }
 152 # for datetime types, check if it has a precision or not
 153         elsif ($data_type =~ /^(?:interval|time|timestamp)\b/i) {
 154             if (lc($data_type) eq 'timestamp without time zone') {
 155                 $info->{data_type} = 'timestamp';
 156             }
 157             elsif (lc($data_type) eq 'time without time zone') {
 158                 $info->{data_type} = 'time';
 159             }
 160
 161             my ($precision) = $self->schema->storage->dbh
 162                 ->selectrow_array(<<EOF, {}, $table, $col);
 163 SELECT datetime_precision
 164 FROM information_schema.columns
 165 WHERE table_name = ? and column_name = ?
 166 EOF
 167
 168             if ($data_type =~ /^time\b/i) {
 169                 if ((not $precision) || $precision !~ /^\d/) {
 170                     delete $info->{size};
 171                 }
 172                 else {
 173                     my ($integer_datetimes) = $self->schema->storage->dbh
 174                         ->selectrow_array('show integer_datetimes');
 175
 176                     my $max_precision =
 177                         $integer_datetimes =~ /^on\z/i ? 6 : 10;
 178
 179                     if ($precision == $max_precision) {
 180                         delete $info->{size};
 181                     }
 182                     else {
 183                         $info->{size} = $precision;
 184                     }
 185                 }
 186             }
 187             elsif ((not $precision) || $precision !~ /^\d/ || $precision == 6) {
 188                 delete $info->{size};
 189             }
 190             else {
 191                 $info->{size} = $precision;
 192             }
 193         }
 194         elsif ($data_type =~ /^(?:bit(?: varying)?|varbit)\z/i) {
 195             $info->{data_type} = 'varbit' if $data_type =~ /var/i;
 196
 197             my ($precision) = $self->schema->storage->dbh
 198                 ->selectrow_array(<<EOF, {}, $table, $col);
 199 SELECT character_maximum_length
 200 FROM information_schema.columns
 201 WHERE table_name = ? and column_name = ?
 202 EOF
 203
 204             $info->{size} = $precision if $precision;
 205
 206             $info->{size} = 1 if (not $precision) && lc($data_type) eq 'bit';
 207         }
 208         elsif ($data_type =~ /^(?:numeric|decimal)\z/i && (my $size = $info->{size})) {
 209             $size =~ s/\s*//g;
 210
 211             my ($scale, $precision) = split /,/, $size;
 212
 213             $info->{size} = [ $precision, $scale ];
 214         }
 215         elsif (lc($data_type) eq 'character varying') {
 216             $info->{data_type} = 'varchar';
 217
 218             if (not $info->{size}) {
 219                 $info->{data_type}           = 'text';
 220                 $info->{original}{data_type} = 'varchar';
 221             }
 222         }
 223         elsif (lc($data_type) eq 'character') {
 224             $info->{data_type} = 'char';
 225         }
 226
 227 # process SERIAL columns
 228         if (ref($info->{default_value}) eq 'SCALAR' && ${ $info->{default_value} } =~ /\bnextval\(['"](\w+)/i) {
 229             $info->{is_auto_increment} = 1;
 230             $info->{sequence}          = $1;
 231             delete $info->{default_value};
 232         }
 233
 234 # alias now() to current_timestamp for deploying to other DBs
 235         if ((eval { lc ${ $info->{default_value} } }||'') eq 'now()') {
 236             # do not use a ref to a constant, that breaks Data::Dump output
 237             ${$info->{default_value}} = 'current_timestamp';
 238
 239             my $now = 'now()';
 240             $info->{original}{default_value} = \$now;
 241         }
 242     }
 243
 244     return $result;
 245 }
 246
 247 =head1 SEE ALSO
 248
 249 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 250 L<DBIx::Class::Schema::Loader::DBI>
 251
 252 =head1 AUTHOR
 253
 254 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 255
 256 =head1 LICENSE
 257
 258 This library is free software; you can redistribute it and/or modify it under
 259 the same terms as Perl itself.
 260
 261 =cut
 262
 263 1;