lib/DBIx/Class/Schema/Loader/DB2.pm

   1 package DBIx::Class::Schema::Loader::DB2;
   2
   3 use strict;
   4 use warnings;
   5 use base 'DBIx::Class::Schema::Loader::Generic';
   6 use Class::C3;
   7
   8 =head1 NAME
   9
  10 DBIx::Class::Schema::Loader::DB2 - DBIx::Class::Schema::Loader DB2 Implementation.
  11
  12 =head1 SYNOPSIS
  13
  14   package My::Schema;
  15   use base qw/DBIx::Class::Schema::Loader/;
  16
  17   __PACKAGE__->load_from_connection(
  18     dsn         => "dbi:DB2:dbname",
  19     user        => "myuser",
  20     password    => "",
  21     db_schema   => "MYSCHEMA",
  22     drop_schema => 1,
  23   );
  24
  25   1;
  26
  27 =head1 DESCRIPTION
  28
  29 See L<DBIx::Class::Schema::Loader>.
  30
  31 =cut
  32
  33 sub _db_classes {
  34     return qw/PK::Auto::DB2/;
  35 }
  36
  37 sub _tables {
  38     my $self = shift;
  39     my %args = @_;
  40     my $db_schema = uc $self->db_schema;
  41     my $dbh = $self->schema->storage->dbh;
  42     my $quoter = $dbh->get_info(29) || q{"};
  43
  44     # this is split out to avoid version parsing errors...
  45     my $is_dbd_db2_gte_114 = ( $DBD::DB2::VERSION >= 1.14 );
  46     my @tables = $is_dbd_db2_gte_114 ?
  47     $dbh->tables( { TABLE_SCHEM => '%', TABLE_TYPE => 'TABLE,VIEW' } )
  48         : $dbh->tables;
  49     # People who use table or schema names that aren't identifiers deserve
  50     # what they get.  Still, FIXME?
  51     s/$quoter//g for @tables;
  52     @tables = grep {!/^SYSIBM\./ and !/^SYSCAT\./ and !/^SYSSTAT\./} @tables;
  53     @tables = grep {/^$db_schema\./} @tables if($db_schema);
  54     return @tables;
  55 }
  56
  57 sub _table_info {
  58     my ( $self, $table ) = @_;
  59 #    $|=1;
  60 #    print "_table_info($table)\n";
  61     my ($db_schema, $tabname) = split /\./, $table, 2;
  62     # print "DB_Schema: $db_schema, Table: $tabname\n";
  63
  64     # FIXME: Horribly inefficient and just plain evil. (JMM)
  65     my $dbh = $self->schema->storage->dbh;
  66     $dbh->{RaiseError} = 1;
  67
  68     my $sth = $dbh->prepare(<<'SQL') or die;
  69 SELECT c.COLNAME
  70 FROM SYSCAT.COLUMNS as c
  71 WHERE c.TABSCHEMA = ? and c.TABNAME = ?
  72 SQL
  73
  74     $sth->execute($db_schema, $tabname) or die;
  75     my @cols = map { lc } map { @$_ } @{$sth->fetchall_arrayref};
  76
  77     undef $sth;
  78
  79     $sth = $dbh->prepare(<<'SQL') or die;
  80 SELECT kcu.COLNAME
  81 FROM SYSCAT.TABCONST as tc
  82 JOIN SYSCAT.KEYCOLUSE as kcu ON tc.constname = kcu.constname
  83 WHERE tc.TABSCHEMA = ? and tc.TABNAME = ? and tc.TYPE = 'P'
  84 SQL
  85
  86     $sth->execute($db_schema, $tabname) or die;
  87
  88     my @pri = map { lc } map { @$_ } @{$sth->fetchall_arrayref};
  89
  90     return ( \@cols, \@pri );
  91 }
  92
  93 # Find and setup relationships
  94 sub _load_relationships {
  95     my $self = shift;
  96
  97     my $dbh = $self->schema->storage->dbh;
  98
  99     my $sth = $dbh->prepare(<<'SQL') or die;
 100 SELECT SR.COLCOUNT, SR.REFTBNAME, SR.PKCOLNAMES, SR.FKCOLNAMES
 101 FROM SYSIBM.SYSRELS SR WHERE SR.TBNAME = ?
 102 SQL
 103
 104     foreach my $table ( $self->tables ) {
 105         next if ! $sth->execute(uc $table);
 106         while(my $res = $sth->fetchrow_arrayref()) {
 107             my ($colcount, $other, $other_column, $column) =
 108                 map { lc } @$res;
 109
 110             my @self_cols = split(' ',$column);
 111             my @other_cols = split(' ',$other_column);
 112             if(@self_cols != $colcount || @other_cols != $colcount) {
 113                 die "Column count discrepancy while getting rel info";
 114             }
 115
 116             my %cond;
 117             for(my $i = 0; $i < @self_cols; $i++) {
 118                 $cond{$other_cols[$i]} = $self_cols[$i];
 119             }
 120
 121             eval { $self->_make_cond_rel ($table, $other, \%cond); };
 122             warn qq/\# belongs_to_many failed "$@"\n\n/
 123               if $@ && $self->debug;
 124         }
 125     }
 126
 127     $sth->finish;
 128     $dbh->disconnect;
 129 }
 130
 131 =head1 SEE ALSO
 132
 133 L<DBIx::Class::Schema::Loader>
 134
 135 =cut
 136
 137 1;