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.03';
   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       $_->{'attname'},
  46       $_->{'typname'},
  47       ! $_->{'attnotnull'},
  48       ( $_->{'attlen'} == -1
  49         ? $_->{'atttypmod'} - 4
  50         : ''
  51       ),
  52       '', #default
  53       ''  #local
  54     ]
  55   } @{ $sth->fetchall_arrayref({}) };
  56 }
  57
  58 sub primary_key {
  59   my($proto, $dbh, $table) = @_;
  60   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
  61     SELECT a.attname, a.attnum
  62     FROM pg_class c, pg_attribute a, pg_type t
  63     WHERE c.relname = '${table}_pkey'
  64       AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid
  65 END
  66   $sth->execute or die $sth->errstr;
  67   my $row = $sth->fetchrow_hashref or return '';
  68   $row->{'attname'};
  69 }
  70
  71 sub unique {
  72   my($proto, $dbh, $table) = @_;
  73   my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] }
  74       grep { $proto->_is_unique($dbh, $_ ) }
  75         $proto->_all_indices($dbh, $table)
  76   };
  77 }
  78
  79 sub index {
  80   my($proto, $dbh, $table) = @_;
  81   my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] }
  82       grep { ! $proto->_is_unique($dbh, $_ ) }
  83         $proto->_all_indices($dbh, $table)
  84   };
  85 }
  86
  87 sub _all_indices {
  88   my($proto, $dbh, $table) = @_;
  89   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
  90     SELECT c2.relname
  91     FROM pg_class c, pg_class c2, pg_index i
  92     WHERE c.relname = '$table' AND c.oid = i.indrelid AND i.indexrelid = c2.oid
  93 END
  94   $sth->execute or die $sth->errstr;
  95   map { $_->{'relname'} }
  96     grep { $_->{'relname'} !~ /_pkey$/ }
  97       @{ $sth->fetchall_arrayref({}) };
  98 }
  99
 100 sub _index_fields {
 101   my($proto, $dbh, $index) = @_;
 102   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
 103     SELECT a.attname, a.attnum
 104     FROM pg_class c, pg_attribute a, pg_type t
 105     WHERE c.relname = '$index'
 106       AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid
 107 END
 108   $sth->execute or die $sth->errstr;
 109   map { $_->{'attname'} } @{ $sth->fetchall_arrayref({}) };
 110 }
 111
 112 sub _is_unique {
 113   my($proto, $dbh, $index) = @_;
 114   my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
 115     SELECT i.indisunique
 116     FROM pg_index i, pg_class c, pg_am a
 117     WHERE i.indexrelid = c.oid AND c.relname = '$index' AND c.relam = a.oid
 118 END
 119   $sth->execute or die $sth->errstr;
 120   my $row = $sth->fetchrow_hashref or die 'guru meditation #420';
 121   $row->{'indisunique'};
 122 }
 123
 124 =head1 AUTHOR
 125
 126 Ivan Kohler <ivan-dbix-dbschema@420.am>
 127
 128 =head1 COPYRIGHT
 129
 130 Copyright (c) 2000 Ivan Kohler
 131 Copyright (c) 2000 Mail Abuse Prevention System LLC
 132 All rights reserved.
 133 This program is free software; you can redistribute it and/or modify it under
 134 the same terms as Perl itself.
 135
 136 =head1 BUGS
 137
 138 Yes.
 139
 140 columns doesn't return column default information.
 141
 142 =head1 SEE ALSO
 143
 144 L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD>
 145
 146 =cut
 147
 148 1;
 149