lib/SQL/Translator/Parser/DBI/DB2.pm

   1 package SQL::Translator::Parser::DBI::DB2;
   2
   3 =head1 NAME
   4
   5 SQL::Translator::Parser::DBI::DB2 - parser for DBD::DB2
   6
   7 =head1 SYNOPSIS
   8
   9 See SQL::Translator::Parser::DBI.
  10
  11 =head1 DESCRIPTION
  12
  13 Uses DBI methods to determine schema structure.  DBI, of course,
  14 delegates to DBD::DB2.
  15
  16 =cut
  17
  18 use strict;
  19 use DBI;
  20 use Data::Dumper;
  21 use SQL::Translator::Schema::Constants;
  22
  23 use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
  24 $VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/;
  25 $DEBUG   = 0 unless defined $DEBUG;
  26
  27 # -------------------------------------------------------------------
  28 sub parse {
  29     my ( $tr, $dbh ) = @_;
  30
  31     my $schema = $tr->schema;
  32
  33     my ($sth, @tables, $columns);
  34     my $stuff;
  35
  36     if ($dbh->{FetchHashKeyName} ne 'NAME_uc') {
  37         $dbh->{FetchHashKeyName} = 'NAME_uc';
  38     }
  39
  40     if ($dbh->{ChopBlanks} != 1) {
  41         $dbh->{ChopBlanks} = 1;
  42     }
  43
  44     $sth = $dbh->table_info();
  45
  46     @tables   = @{$sth->fetchall_arrayref({})};
  47
  48     my $colsth = $dbh->prepare(<<SQL);
  49 SELECT c.TABSCHEMA,
  50        c.TABNAME,
  51        c.COLNAME,
  52        c.TYPENAME,
  53        c.LENGTH,
  54        c.DEFAULT,
  55        c.NULLS,
  56        c.COLNO
  57 FROM SYSCAT.COLUMNS c
  58 WHERE c.TABSCHEMA NOT LIKE 'SYS%' AND
  59      c.TABNAME = ?
  60 SQL
  61
  62     my $consth = $dbh->prepare(<<SQL);
  63 SELECT tc.TABSCHEMA,
  64        tc.TABNAME,
  65        kc.CONSTNAME,
  66        kc.COLNAME,
  67        tc.TYPE,
  68        tc.CHECKEXISTINGDATA
  69 FROM SYSCAT.TABCONST tc
  70 JOIN SYSCAT.KEYCOLUSE kc ON tc.CONSTNAME = kc.CONSTNAME AND
  71                             tc.TABSCHEMA = kc.TABSCHEMA AND
  72                             tc.TABNAME   = kc.TABNAME
  73 WHERE tc.TABSCHEMA NOT LIKE 'SYS%' AND
  74       tc.TABNAME = ?
  75 SQL
  76
  77     my $indsth = $dbh->prepare(<<SQL);
  78 SELECT i.INDSCHEMA,
  79        i.INDNAME,
  80        i.TABSCHEMA,
  81        i.TABNAME,
  82        i.UNIQUERULE,
  83        i.INDEXTYPE,
  84        ic.COLNAME
  85 FROM SYSCAT.INDEXES i
  86 JOIN SYSCAT.INDEXCOLUSE ic ON i.INDSCHEMA = ic.INDSCHEMA AND
  87                               i.INDNAME = ic.INDNAME
  88 WHERE i.TABSCHEMA NOT LIKE 'SYS%' AND
  89       i.INDEXTYPE <> 'P' AND
  90       i.TABNAME = ?
  91 SQL
  92
  93     foreach my $table_info (@tables) {
  94         next
  95             unless (defined($table_info->{TABLE_TYPE}));
  96
  97 # Why are we not getting system tables, maybe a parameter should decide?
  98
  99         if ($table_info->{TABLE_TYPE} eq 'TABLE'&&
 100             $table_info->{TABLE_SCHEM} !~ /^SYS/) {
 101             print Dumper($table_info) if($DEBUG);
 102             print  $table_info->{TABLE_NAME} if($DEBUG);
 103             my $table = $schema->add_table(
 104                                            name => $table_info->{TABLE_NAME},
 105                                            type => $table_info->{TABLE_TYPE},
 106                                           ) || die $schema->error;
 107
 108             $colsth->execute($table_info->{TABLE_NAME});
 109             my $cols = $colsth->fetchall_hashref("COLNAME");
 110
 111             foreach my $c (values %{$cols}) {
 112                 print Dumper($c) if $DEBUG;
 113                 print $c->{COLNAME} if($DEBUG);
 114                 my $f = $table->add_field(
 115                                         name        => $c->{COLNAME},
 116                                         default_value => $c->{DEFAULT},
 117                                         data_type   => $c->{TYPENAME},
 118                                         order       => $c->{COLNO},
 119                                         size        => $c->{LENGTH},
 120                                          ) || die $table->error;
 121
 122
 123                 $f->is_nullable($c->{NULLS} eq 'Y');
 124             }
 125
 126             $consth->execute($table_info->{TABLE_NAME});
 127             my $cons = $consth->fetchall_hashref("COLNAME");
 128             next if(!%$cons);
 129
 130             my @fields = map { $_->{COLNAME} } (values %{$cons});
 131             my $c = $cons->{$fields[0]};
 132
 133             print  $c->{CONSTNAME} if($DEBUG);
 134             my $con = $table->add_constraint(
 135                                            name   => $c->{CONSTNAME},
 136                                            fields => \@fields,
 137                                            type   => $c->{TYPE} eq 'P' ?
 138                                            PRIMARY_KEY : $c->{TYPE} eq 'F' ?
 139                                            FOREIGN_KEY : UNIQUE
 140                                          ) || die $table->error;
 141
 142
 143             $con->deferrable($c->{CHECKEXISTINGDATA} eq 'D');
 144
 145             $indsth->execute($table_info->{TABLE_NAME});
 146             my $inds = $indsth->fetchall_hashref("INDNAME");
 147             print Dumper($inds) if($DEBUG);
 148             next if(!%$inds);
 149
 150             foreach my $ind (keys %$inds)
 151             {
 152                 print $ind if($DEBUG);
 153                 $indsth->execute($table_info->{TABLE_NAME});
 154                 my $indcols = $indsth->fetchall_hashref("COLNAME");
 155                 next if($inds->{$ind}{UNIQUERULE} eq 'P');
 156
 157                 print Dumper($indcols) if($DEBUG);
 158
 159                 my @fields = map { $_->{INDNAME} eq $ind ? $_->{COLNAME} : () }
 160                    (values %{$indcols});
 161
 162                 my $index = $indcols->{$fields[0]};
 163
 164                 my $inew = $table->add_index(
 165                                              name   => $index->{INDNAME},
 166                                              fields => \@fields,
 167                                              type   => $index->{UNIQUERULE} eq 'U' ?
 168                                              UNIQUE : NORMAL
 169                                              ) || die $table->error;
 170
 171
 172             }
 173         }
 174     }
 175
 176     return 1;
 177 }
 178
 179 1;
 180
 181 # -------------------------------------------------------------------
 182 # Time is a waste of money.
 183 # Oscar Wilde
 184 # -------------------------------------------------------------------
 185
 186 =pod
 187
 188 =head1 AUTHOR
 189
 190 Jess Robinson <lt>castaway@desert-island.m.isar.de<gt>.
 191
 192 =head1 SEE ALSO
 193
 194 SQL::Translator, DBD::DB2.
 195
 196 =cut