DBSchema/DBD/Pg.pm

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