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 mro 'c3';
  11
  12 our $VERSION = '0.07006';
  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         # XXX should this be a negative match?
 149         if ($data_type =~
 150 /^(?: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) {
 151             delete $info->{size};
 152         }
 153 # for datetime types, check if it has a precision or not
 154         elsif ($data_type =~ /^(?:interval|time|timestamp)\b/i) {
 155             if (lc($data_type) eq 'timestamp without time zone') {
 156                 $info->{data_type} = 'timestamp';
 157             }
 158             elsif (lc($data_type) eq 'time without time zone') {
 159                 $info->{data_type} = 'time';
 160             }
 161
 162             my ($precision) = $self->schema->storage->dbh
 163                 ->selectrow_array(<<EOF, {}, $table, $col);
 164 SELECT datetime_precision
 165 FROM information_schema.columns
 166 WHERE table_name = ? and column_name = ?
 167 EOF
 168
 169             if ($data_type =~ /^time\b/i) {
 170                 if ((not $precision) || $precision !~ /^\d/) {
 171                     delete $info->{size};
 172                 }
 173                 else {
 174                     my ($integer_datetimes) = $self->schema->storage->dbh
 175                         ->selectrow_array('show integer_datetimes');
 176
 177                     my $max_precision =
 178                         $integer_datetimes =~ /^on\z/i ? 6 : 10;
 179
 180                     if ($precision == $max_precision) {
 181                         delete $info->{size};
 182                     }
 183                     else {
 184                         $info->{size} = $precision;
 185                     }
 186                 }
 187             }
 188             elsif ((not $precision) || $precision !~ /^\d/ || $precision == 6) {
 189                 delete $info->{size};
 190             }
 191             else {
 192                 $info->{size} = $precision;
 193             }
 194         }
 195         elsif ($data_type =~ /^(?:bit(?: varying)?|varbit)\z/i) {
 196             $info->{data_type} = 'varbit' if $data_type =~ /var/i;
 197
 198             my ($precision) = $self->schema->storage->dbh
 199                 ->selectrow_array(<<EOF, {}, $table, $col);
 200 SELECT character_maximum_length
 201 FROM information_schema.columns
 202 WHERE table_name = ? and column_name = ?
 203 EOF
 204
 205             $info->{size} = $precision if $precision;
 206
 207             $info->{size} = 1 if (not $precision) && lc($data_type) eq 'bit';
 208         }
 209         elsif ($data_type =~ /^(?:numeric|decimal)\z/i && (my $size = $info->{size})) {
 210             $size =~ s/\s*//g;
 211
 212             my ($scale, $precision) = split /,/, $size;
 213
 214             $info->{size} = [ $precision, $scale ];
 215         }
 216         elsif (lc($data_type) eq 'character varying') {
 217             $info->{data_type} = 'varchar';
 218
 219             if (not $info->{size}) {
 220                 $info->{data_type}           = 'text';
 221                 $info->{original}{data_type} = 'varchar';
 222             }
 223         }
 224         elsif (lc($data_type) eq 'character') {
 225             $info->{data_type} = 'char';
 226         }
 227         else {
 228             my ($typetype) = $self->schema->storage->dbh
 229                 ->selectrow_array(<<EOF, {}, $data_type);
 230 SELECT typtype
 231 FROM pg_catalog.pg_type
 232 WHERE typname = ?
 233 EOF
 234             if ($typetype eq 'e') {
 235                 # The following will extract a list of allowed values for the
 236                 # enum.
 237                 my $typevalues = $self->schema->storage->dbh
 238                     ->selectall_arrayref(<<EOF, {}, $info->{data_type});
 239 SELECT e.enumlabel
 240 FROM pg_catalog.pg_enum e
 241 JOIN pg_catalog.pg_type t ON t.oid = e.enumtypid
 242 WHERE t.typname = ?
 243 EOF
 244
 245                 $info->{extra}{list} = [ map { $_->[0] } @$typevalues ];
 246
 247                 # Store its original name in extra for SQLT to pick up.
 248                 $info->{extra}{custom_type_name} = $info->{data_type};
 249
 250                 $info->{data_type} = 'enum';
 251
 252                 delete $info->{size};
 253             }
 254         }
 255
 256 # process SERIAL columns
 257         if (ref($info->{default_value}) eq 'SCALAR' && ${ $info->{default_value} } =~ /\bnextval\(['"]([.\w]+)/i) {
 258             $info->{is_auto_increment} = 1;
 259             $info->{sequence}          = $1;
 260             delete $info->{default_value};
 261         }
 262
 263 # alias now() to current_timestamp for deploying to other DBs
 264         if ((eval { lc ${ $info->{default_value} } }||'') eq 'now()') {
 265             # do not use a ref to a constant, that breaks Data::Dump output
 266             ${$info->{default_value}} = 'current_timestamp';
 267
 268             my $now = 'now()';
 269             $info->{original}{default_value} = \$now;
 270         }
 271     }
 272
 273     return $result;
 274 }
 275
 276 =head1 SEE ALSO
 277
 278 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 279 L<DBIx::Class::Schema::Loader::DBI>
 280
 281 =head1 AUTHOR
 282
 283 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 284
 285 =head1 LICENSE
 286
 287 This library is free software; you can redistribute it and/or modify it under
 288 the same terms as Perl itself.
 289
 290 =cut
 291
 292 1;