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     namespace => "Data",
  21     schema    => "MYSCHEMA",
  22     dropschema  => 0,
  23   );
  24
  25 =head1 DESCRIPTION
  26
  27 See L<DBIx::Class::Schema::Loader>.
  28
  29 =cut
  30
  31 sub _db_classes {
  32     return qw/DBIx::Class::PK::Auto::DB2/;
  33 }
  34
  35 sub _tables {
  36     my $class = shift;
  37     my %args = @_;
  38     my $db_schema = uc $class->loader_data->{_db_schema};
  39     my $dbh = $class->storage->dbh;
  40
  41     # this is split out to avoid version parsing errors...
  42     my $is_dbd_db2_gte_114 = ( $DBD::DB2::VERSION >= 1.14 );
  43     my @tables = $is_dbd_db2_gte_114 ?
  44     $dbh->tables( { TABLE_SCHEM => '%', TABLE_TYPE => 'TABLE,VIEW' } )
  45         : $dbh->tables;
  46     # People who use table or schema names that aren't identifiers deserve
  47     # what they get.  Still, FIXME?
  48     s/\"//g for @tables;
  49     @tables = grep {!/^SYSIBM\./ and !/^SYSCAT\./ and !/^SYSSTAT\./} @tables;
  50     @tables = grep {/^$db_schema\./} @tables if($db_schema);
  51     return @tables;
  52 }
  53
  54 sub _table_info {
  55     my ( $class, $table ) = @_;
  56 #    $|=1;
  57 #    print "_table_info($table)\n";
  58     my ($db_schema, $tabname) = split /\./, $table, 2;
  59     # print "DB_Schema: $db_schema, Table: $tabname\n";
  60
  61     # FIXME: Horribly inefficient and just plain evil. (JMM)
  62     my $dbh = $class->storage->dbh;
  63     $dbh->{RaiseError} = 1;
  64
  65     my $sth = $dbh->prepare(<<'SQL') or die;
  66 SELECT c.COLNAME
  67 FROM SYSCAT.COLUMNS as c
  68 WHERE c.TABSCHEMA = ? and c.TABNAME = ?
  69 SQL
  70
  71     $sth->execute($db_schema, $tabname) or die;
  72     my @cols = map { lc } map { @$_ } @{$sth->fetchall_arrayref};
  73
  74     $sth->finish;
  75
  76     $sth = $dbh->prepare(<<'SQL') or die;
  77 SELECT kcu.COLNAME
  78 FROM SYSCAT.TABCONST as tc
  79 JOIN SYSCAT.KEYCOLUSE as kcu ON tc.constname = kcu.constname
  80 WHERE tc.TABSCHEMA = ? and tc.TABNAME = ? and tc.TYPE = 'P'
  81 SQL
  82
  83     $sth->execute($db_schema, $tabname) or die;
  84
  85     my @pri = map { lc } map { @$_ } @{$sth->fetchall_arrayref};
  86
  87     $sth->finish;
  88
  89     return ( \@cols, \@pri );
  90 }
  91
  92 # Find and setup relationships
  93 sub _relationships {
  94     my $class = shift;
  95
  96     my $dbh = $class->storage->dbh;
  97
  98     my $sth = $dbh->prepare(<<'SQL') or die;
  99 SELECT SR.COLCOUNT, SR.REFTBNAME, SR.PKCOLNAMES, SR.FKCOLNAMES
 100 FROM SYSIBM.SYSRELS SR WHERE SR.TBNAME = ?
 101 SQL
 102
 103     foreach my $table ( $class->tables ) {
 104         if ($sth->execute(uc $table)) {
 105             while(my $res = $sth->fetchrow_arrayref()) {
 106                 my ($colcount, $other, $other_column, $column) =
 107                     map { $_=lc; s/^\s+//; s/\s+$//; $_; } @$res;
 108                 next if $colcount != 1; # XXX no multi-col FK support yet
 109                 eval { $class->_belongs_to_many( $table, $column, $other,
 110                   $other_column ) };
 111                 warn qq/\# belongs_to_many failed "$@"\n\n/
 112                   if $@ && $class->debug_loader;
 113             }
 114         }
 115     }
 116
 117     $sth->finish;
 118     $dbh->disconnect;
 119 }
 120
 121 =head1 SEE ALSO
 122
 123 L<DBIx::Class::Schema::Loader>
 124
 125 =cut
 126
 127 1;