Commit | Line | Data |
4c41d371 |
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; |
173392cd |
21 | use SQL::Translator::Parser::DB2; |
4c41d371 |
22 | use SQL::Translator::Schema::Constants; |
23 | |
478f608d |
24 | use vars qw[ $DEBUG @EXPORT_OK ]; |
4c41d371 |
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 | |
173392cd |
44 | my $tabsth = $dbh->prepare(<<SQL); |
45 | SELECT t.TABSCHEMA, |
46 | t.TABNAME, |
47 | t.TYPE, |
48 | ts.TBSPACE |
49 | FROM SYSCAT.TABLES t |
50 | JOIN SYSCAT.TABLESPACES ts ON t.TBSPACEID = ts.TBSPACEID |
51 | WHERE t.TABSCHEMA NOT LIKE 'SYS%' |
52 | ORDER BY t.TABNAME ASC |
53 | SQL |
54 | # $sth = $dbh->table_info(); |
55 | # @tables = @{$sth->fetchall_arrayref({})}; |
4c41d371 |
56 | |
57 | my $colsth = $dbh->prepare(<<SQL); |
58 | SELECT c.TABSCHEMA, |
59 | c.TABNAME, |
60 | c.COLNAME, |
61 | c.TYPENAME, |
62 | c.LENGTH, |
63 | c.DEFAULT, |
64 | c.NULLS, |
65 | c.COLNO |
66 | FROM SYSCAT.COLUMNS c |
67 | WHERE c.TABSCHEMA NOT LIKE 'SYS%' AND |
68 | c.TABNAME = ? |
173392cd |
69 | ORDER BY COLNO |
4c41d371 |
70 | SQL |
71 | |
72 | my $consth = $dbh->prepare(<<SQL); |
73 | SELECT tc.TABSCHEMA, |
74 | tc.TABNAME, |
75 | kc.CONSTNAME, |
76 | kc.COLNAME, |
77 | tc.TYPE, |
78 | tc.CHECKEXISTINGDATA |
79 | FROM SYSCAT.TABCONST tc |
80 | JOIN SYSCAT.KEYCOLUSE kc ON tc.CONSTNAME = kc.CONSTNAME AND |
81 | tc.TABSCHEMA = kc.TABSCHEMA AND |
82 | tc.TABNAME = kc.TABNAME |
83 | WHERE tc.TABSCHEMA NOT LIKE 'SYS%' AND |
84 | tc.TABNAME = ? |
85 | SQL |
86 | |
87 | my $indsth = $dbh->prepare(<<SQL); |
88 | SELECT i.INDSCHEMA, |
89 | i.INDNAME, |
90 | i.TABSCHEMA, |
91 | i.TABNAME, |
92 | i.UNIQUERULE, |
93 | i.INDEXTYPE, |
94 | ic.COLNAME |
95 | FROM SYSCAT.INDEXES i |
96 | JOIN SYSCAT.INDEXCOLUSE ic ON i.INDSCHEMA = ic.INDSCHEMA AND |
97 | i.INDNAME = ic.INDNAME |
98 | WHERE i.TABSCHEMA NOT LIKE 'SYS%' AND |
99 | i.INDEXTYPE <> 'P' AND |
100 | i.TABNAME = ? |
101 | SQL |
102 | |
173392cd |
103 | my $trigsth = $dbh->prepare(<<SQL); |
104 | SELECT t.TRIGSCHEMA, |
105 | t.TRIGNAME, |
106 | t.TABSCHEMA, |
107 | t.TRIGTIME, |
108 | t.TRIGEVENT, |
109 | t.GRANULARITY, |
110 | t.TEXT |
111 | FROM SYSCAT.TRIGGERS t |
112 | WHERE t.TABSCHEMA NOT LIKE 'SYS%' AND |
113 | t.TABNAME = ? |
114 | SQL |
115 | |
116 | $tabsth->execute(); |
117 | @tables = @{$tabsth->fetchall_arrayref({})}; |
118 | |
4c41d371 |
119 | foreach my $table_info (@tables) { |
120 | next |
173392cd |
121 | unless (defined($table_info->{TYPE})); |
4c41d371 |
122 | |
123 | # Why are we not getting system tables, maybe a parameter should decide? |
124 | |
173392cd |
125 | if ($table_info->{TYPE} eq 'T'&& |
126 | $table_info->{TABSCHEMA} !~ /^SYS/) { |
4c41d371 |
127 | print Dumper($table_info) if($DEBUG); |
173392cd |
128 | print $table_info->{TABNAME} if($DEBUG); |
4c41d371 |
129 | my $table = $schema->add_table( |
173392cd |
130 | name => $table_info->{TABNAME}, |
131 | type => 'TABLE', |
4c41d371 |
132 | ) || die $schema->error; |
173392cd |
133 | $table->options("TABLESPACE", $table_info->{TBSPACE}); |
4c41d371 |
134 | |
173392cd |
135 | $colsth->execute($table_info->{TABNAME}); |
4c41d371 |
136 | my $cols = $colsth->fetchall_hashref("COLNAME"); |
137 | |
138 | foreach my $c (values %{$cols}) { |
139 | print Dumper($c) if $DEBUG; |
140 | print $c->{COLNAME} if($DEBUG); |
141 | my $f = $table->add_field( |
142 | name => $c->{COLNAME}, |
143 | default_value => $c->{DEFAULT}, |
144 | data_type => $c->{TYPENAME}, |
145 | order => $c->{COLNO}, |
146 | size => $c->{LENGTH}, |
147 | ) || die $table->error; |
148 | |
149 | |
150 | $f->is_nullable($c->{NULLS} eq 'Y'); |
151 | } |
152 | |
173392cd |
153 | $consth->execute($table_info->{TABNAME}); |
4c41d371 |
154 | my $cons = $consth->fetchall_hashref("COLNAME"); |
155 | next if(!%$cons); |
156 | |
157 | my @fields = map { $_->{COLNAME} } (values %{$cons}); |
158 | my $c = $cons->{$fields[0]}; |
159 | |
160 | print $c->{CONSTNAME} if($DEBUG); |
161 | my $con = $table->add_constraint( |
162 | name => $c->{CONSTNAME}, |
163 | fields => \@fields, |
164 | type => $c->{TYPE} eq 'P' ? |
165 | PRIMARY_KEY : $c->{TYPE} eq 'F' ? |
166 | FOREIGN_KEY : UNIQUE |
167 | ) || die $table->error; |
168 | |
169 | |
170 | $con->deferrable($c->{CHECKEXISTINGDATA} eq 'D'); |
171 | |
173392cd |
172 | $indsth->execute($table_info->{TABNAME}); |
4c41d371 |
173 | my $inds = $indsth->fetchall_hashref("INDNAME"); |
174 | print Dumper($inds) if($DEBUG); |
175 | next if(!%$inds); |
176 | |
177 | foreach my $ind (keys %$inds) |
178 | { |
179 | print $ind if($DEBUG); |
173392cd |
180 | $indsth->execute($table_info->{TABNAME}); |
4c41d371 |
181 | my $indcols = $indsth->fetchall_hashref("COLNAME"); |
182 | next if($inds->{$ind}{UNIQUERULE} eq 'P'); |
183 | |
184 | print Dumper($indcols) if($DEBUG); |
185 | |
186 | my @fields = map { $_->{INDNAME} eq $ind ? $_->{COLNAME} : () } |
187 | (values %{$indcols}); |
188 | |
189 | my $index = $indcols->{$fields[0]}; |
190 | |
191 | my $inew = $table->add_index( |
192 | name => $index->{INDNAME}, |
193 | fields => \@fields, |
194 | type => $index->{UNIQUERULE} eq 'U' ? |
195 | UNIQUE : NORMAL |
196 | ) || die $table->error; |
197 | |
198 | |
199 | } |
173392cd |
200 | |
201 | $trigsth->execute($table_info->{TABNAME}); |
202 | my $trigs = $trigsth->fetchall_hashref("TRIGNAME"); |
203 | print Dumper($trigs); |
204 | next if(!%$trigs); |
205 | |
206 | foreach my $t (values %$trigs) |
207 | { |
208 | print $t->{TRIGNAME} if($DEBUG); |
209 | my $trig = $schema->add_trigger( |
210 | name => $t->{TRIGNAME}, |
211 | # fields => \@fields, |
212 | perform_action_when => $t->{TRIGTIME} eq 'A' ? 'after' : |
213 | $t->{TRIGTIME} eq 'B' ? 'before': |
214 | 'instead', |
215 | database_event => $t->{TRIGEVENT} eq 'I' ? 'insert' |
216 | : $t->{TRIGEVENT} eq 'D' ? 'delete' |
217 | : 'update', |
218 | action => $t->{TEXT}, |
219 | on_table => $t->{TABNAME} |
220 | ) || die $schema->error; |
221 | |
222 | # $trig->extra( reference => $def->{'reference'}, |
223 | # condition => $def->{'condition'}, |
224 | # granularity => $def->{'granularity'} ); |
225 | } |
226 | |
4c41d371 |
227 | } |
228 | } |
229 | |
230 | return 1; |
231 | } |
232 | |
233 | 1; |
234 | |
235 | # ------------------------------------------------------------------- |
236 | # Time is a waste of money. |
237 | # Oscar Wilde |
238 | # ------------------------------------------------------------------- |
239 | |
240 | =pod |
241 | |
242 | =head1 AUTHOR |
243 | |
244 | Jess Robinson <lt>castaway@desert-island.m.isar.de<gt>. |
245 | |
246 | =head1 SEE ALSO |
247 | |
248 | SQL::Translator, DBD::DB2. |
249 | |
250 | =cut |