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