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.11';
   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 );
  19
  20 =head1 NAME
  21
  22 DBIx::DBSchema::DBD::Pg - PostgreSQL native driver for DBIx::DBSchema
  23
  24 =head1 SYNOPSIS
  25
  26 use DBI;
  27 use DBIx::DBSchema;
  28
  29 $dbh = DBI->connect('dbi:Pg:dbname=database', 'user', 'pass');
  30 $schema = new_native DBIx::DBSchema $dbh;
  31
  32 =head1 DESCRIPTION
  33
  34 This module implements a PostgreSQL-native driver for DBIx::DBSchema.
  35
  36 =cut
  37
  38 sub default_db_schema  { 'public'; }
  39
  40 sub columns {
  41   my($proto, $dbh, $table) = @_;
  42   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
  43     SELECT a.attname, t.typname, a.attlen, a.atttypmod, a.attnotnull,
  44            a.atthasdef, a.attnum
  45     FROM pg_class c, pg_attribute a, pg_type t
  46     WHERE c.relname = '$table'
  47       AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid
  48     ORDER BY a.attnum
  49 END
  50   $sth->execute or die $sth->errstr;
  51
  52   map {
  53
  54     my $default = '';
  55     if ( $_->{atthasdef} ) {
  56       my $attnum = $_->{attnum};
  57       my $d_sth = $dbh->prepare(<<END) or die $dbh->errstr;
  58         SELECT substring(d.adsrc for 128) FROM pg_attrdef d, pg_class c
  59         WHERE c.relname = '$table' AND c.oid = d.adrelid AND d.adnum = $attnum
  60 END
  61       $d_sth->execute or die $d_sth->errstr;
  62
  63       $default = $d_sth->fetchrow_arrayref->[0];
  64     };
  65
  66     my $len = '';
  67     if ( $_->{attlen} == -1 && $_->{atttypmod} != -1
  68          && $_->{typname} ne 'text'                  ) {
  69       $len = $_->{atttypmod} - 4;
  70       if ( $_->{typname} eq 'numeric' ) {
  71         $len = ($len >> 16). ','. ($len & 0xffff);
  72       }
  73     }
  74
  75     my $type = $_->{'typname'};
  76     $type = 'char' if $type eq 'bpchar';
  77
  78     [
  79       $_->{'attname'},
  80       $type,
  81       ! $_->{'attnotnull'},
  82       $len,
  83       $default,
  84       ''  #local
  85     ];
  86
  87   } @{ $sth->fetchall_arrayref({}) };
  88 }
  89
  90 sub primary_key {
  91   my($proto, $dbh, $table) = @_;
  92   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
  93     SELECT a.attname, a.attnum
  94     FROM pg_class c, pg_attribute a, pg_type t
  95     WHERE c.relname = '${table}_pkey'
  96       AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid
  97 END
  98   $sth->execute or die $sth->errstr;
  99   my $row = $sth->fetchrow_hashref or return '';
 100   $row->{'attname'};
 101 }
 102
 103 sub unique {
 104   my($proto, $dbh, $table) = @_;
 105   my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] }
 106       grep { $proto->_is_unique($dbh, $_ ) }
 107         $proto->_all_indices($dbh, $table)
 108   };
 109 }
 110
 111 sub index {
 112   my($proto, $dbh, $table) = @_;
 113   my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] }
 114       grep { ! $proto->_is_unique($dbh, $_ ) }
 115         $proto->_all_indices($dbh, $table)
 116   };
 117 }
 118
 119 sub _all_indices {
 120   my($proto, $dbh, $table) = @_;
 121   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
 122     SELECT c2.relname
 123     FROM pg_class c, pg_class c2, pg_index i
 124     WHERE c.relname = '$table' AND c.oid = i.indrelid AND i.indexrelid = c2.oid
 125 END
 126   $sth->execute or die $sth->errstr;
 127   map { $_->{'relname'} }
 128     grep { $_->{'relname'} !~ /_pkey$/ }
 129       @{ $sth->fetchall_arrayref({}) };
 130 }
 131
 132 sub _index_fields {
 133   my($proto, $dbh, $index) = @_;
 134   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
 135     SELECT a.attname, a.attnum
 136     FROM pg_class c, pg_attribute a, pg_type t
 137     WHERE c.relname = '$index'
 138       AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid
 139     ORDER BY a.attnum
 140 END
 141   $sth->execute or die $sth->errstr;
 142   map { $_->{'attname'} } @{ $sth->fetchall_arrayref({}) };
 143 }
 144
 145 sub _is_unique {
 146   my($proto, $dbh, $index) = @_;
 147   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
 148     SELECT i.indisunique
 149     FROM pg_index i, pg_class c, pg_am a
 150     WHERE i.indexrelid = c.oid AND c.relname = '$index' AND c.relam = a.oid
 151 END
 152   $sth->execute or die $sth->errstr;
 153   my $row = $sth->fetchrow_hashref or die 'guru meditation #420';
 154   $row->{'indisunique'};
 155 }
 156
 157 =head1 AUTHOR
 158
 159 Ivan Kohler <ivan-dbix-dbschema@420.am>
 160
 161 =head1 COPYRIGHT
 162
 163 Copyright (c) 2000 Ivan Kohler
 164 Copyright (c) 2000 Mail Abuse Prevention System LLC
 165 All rights reserved.
 166 This program is free software; you can redistribute it and/or modify it under
 167 the same terms as Perl itself.
 168
 169 =head1 BUGS
 170
 171 Yes.
 172
 173 columns doesn't return column default information.
 174
 175 =head1 SEE ALSO
 176
 177 L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD>
 178
 179 =cut
 180
 181 1;
 182