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

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