DBSchema/DBD/Pg.pm

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