Commit | Line | Data |
996be9ee |
1 | package DBIx::Class::Schema::Loader::DBI::DB2; |
2 | |
3 | use strict; |
4 | use warnings; |
41968729 |
5 | use base qw/ |
6 | DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault |
7 | DBIx::Class::Schema::Loader::DBI |
8 | /; |
fa994d3c |
9 | use Carp::Clan qw/^DBIx::Class/; |
942bd5e0 |
10 | use mro 'c3'; |
996be9ee |
11 | |
e94ccbea |
12 | our $VERSION = '0.07006'; |
32f784fc |
13 | |
996be9ee |
14 | =head1 NAME |
15 | |
16 | DBIx::Class::Schema::Loader::DBI::DB2 - DBIx::Class::Schema::Loader::DBI DB2 Implementation. |
17 | |
18 | =head1 SYNOPSIS |
19 | |
20 | package My::Schema; |
21 | use base qw/DBIx::Class::Schema::Loader/; |
22 | |
59cfa251 |
23 | __PACKAGE__->loader_options( db_schema => "MYSCHEMA" ); |
996be9ee |
24 | |
25 | 1; |
26 | |
27 | =head1 DESCRIPTION |
28 | |
29 | See L<DBIx::Class::Schema::Loader::Base>. |
30 | |
31 | =cut |
32 | |
7a930e63 |
33 | sub _setup { |
34 | my $self = shift; |
35 | |
36 | $self->next::method(@_); |
37 | |
38 | my $dbh = $self->schema->storage->dbh; |
39 | $self->{db_schema} ||= $dbh->selectrow_array('VALUES(CURRENT_USER)', {}); |
bc1cb85e |
40 | |
41 | if (not defined $self->preserve_case) { |
42 | $self->preserve_case(0); |
43 | } |
b511f36e |
44 | elsif ($self->preserve_case) { |
45 | $self->schema->storage->sql_maker->quote_char('"'); |
46 | $self->schema->storage->sql_maker->name_sep('.'); |
47 | } |
7a930e63 |
48 | } |
49 | |
996be9ee |
50 | sub _table_uniq_info { |
51 | my ($self, $table) = @_; |
52 | |
53 | my @uniqs; |
54 | |
55 | my $dbh = $self->schema->storage->dbh; |
56 | |
5223f24a |
57 | my $sth = $self->{_cache}->{db2_uniq} ||= $dbh->prepare( |
58 | q{SELECT kcu.COLNAME, kcu.CONSTNAME, kcu.COLSEQ |
59 | FROM SYSCAT.TABCONST as tc |
ae32aaf6 |
60 | JOIN SYSCAT.KEYCOLUSE as kcu |
61 | ON tc.CONSTNAME = kcu.CONSTNAME AND tc.TABSCHEMA = kcu.TABSCHEMA |
5223f24a |
62 | WHERE tc.TABSCHEMA = ? and tc.TABNAME = ? and tc.TYPE = 'U'} |
4421d6a3 |
63 | ) or die $DBI::errstr; |
5223f24a |
64 | |
b511f36e |
65 | $sth->execute($self->db_schema, $self->_uc($table)) or die $DBI::errstr; |
996be9ee |
66 | |
67 | my %keydata; |
68 | while(my $row = $sth->fetchrow_arrayref) { |
69 | my ($col, $constname, $seq) = @$row; |
b511f36e |
70 | push(@{$keydata{$constname}}, [ $seq, $self->_lc($col) ]); |
996be9ee |
71 | } |
72 | foreach my $keyname (keys %keydata) { |
73 | my @ordered_cols = map { $_->[1] } sort { $a->[0] <=> $b->[0] } |
74 | @{$keydata{$keyname}}; |
75 | push(@uniqs, [ $keyname => \@ordered_cols ]); |
76 | } |
4421d6a3 |
77 | |
996be9ee |
78 | $sth->finish; |
79 | |
80 | return \@uniqs; |
81 | } |
82 | |
072d5aae |
83 | # DBD::DB2 doesn't follow the DBI API for ->tables |
84 | sub _tables_list { |
bfb43060 |
85 | my ($self, $opts) = @_; |
072d5aae |
86 | |
87 | my $dbh = $self->schema->storage->dbh; |
b511f36e |
88 | my @tables = map $self->_lc($_), $dbh->tables( |
072d5aae |
89 | $self->db_schema ? { TABLE_SCHEM => $self->db_schema } : undef |
90 | ); |
91 | s/\Q$self->{_quoter}\E//g for @tables; |
92 | s/^.*\Q$self->{_namesep}\E// for @tables; |
93 | |
bfb43060 |
94 | return $self->_filter_tables(\@tables, $opts); |
a168c1c4 |
95 | } |
96 | |
97 | sub _table_pk_info { |
98 | my ($self, $table) = @_; |
b511f36e |
99 | return $self->next::method($self->_uc($table)); |
a168c1c4 |
100 | } |
101 | |
102 | sub _table_fk_info { |
103 | my ($self, $table) = @_; |
104 | |
b511f36e |
105 | my $rels = $self->next::method($self->_uc($table)); |
a168c1c4 |
106 | |
107 | foreach my $rel (@$rels) { |
b511f36e |
108 | $rel->{remote_table} = $self->_lc($rel->{remote_table}); |
a168c1c4 |
109 | } |
110 | |
111 | return $rels; |
112 | } |
113 | |
114 | sub _columns_info_for { |
8a64178e |
115 | my $self = shift; |
116 | my ($table) = @_; |
a168c1c4 |
117 | |
b511f36e |
118 | my $result = $self->next::method($self->_uc($table)); |
772cfe65 |
119 | |
772cfe65 |
120 | my $dbh = $self->schema->storage->dbh; |
8a64178e |
121 | |
122 | while (my ($col, $info) = each %$result) { |
123 | # check for identities |
124 | my $sth = $dbh->prepare_cached( |
125 | q{ |
126 | SELECT COUNT(*) |
127 | FROM syscat.columns |
128 | WHERE tabschema = ? AND tabname = ? AND colname = ? |
129 | AND identity = 'Y' AND generated != '' |
130 | }, |
131 | {}, 1); |
b511f36e |
132 | $sth->execute($self->db_schema, $self->_uc($table), $self->_uc($col)); |
8a64178e |
133 | if ($sth->fetchrow_array) { |
134 | $info->{is_auto_increment} = 1; |
135 | } |
136 | |
7640ef4b |
137 | my $data_type = $info->{data_type}; |
138 | |
139 | if ($data_type !~ /^(?:(?:var)?(?:char|graphic)|decimal)\z/i) { |
8a64178e |
140 | delete $info->{size}; |
7640ef4b |
141 | } |
142 | |
143 | if ($data_type eq 'double') { |
144 | $info->{data_type} = 'double precision'; |
145 | } |
146 | elsif ($data_type eq 'decimal') { |
147 | no warnings 'uninitialized'; |
148 | |
149 | $info->{data_type} = 'numeric'; |
150 | |
151 | my @size = @{ $info->{size} || [] }; |
152 | |
153 | if ($size[0] == 5 && $size[1] == 0) { |
154 | delete $info->{size}; |
155 | } |
156 | } |
157 | elsif ($data_type =~ /^(?:((?:var)?char) \(\) for bit data|(long varchar) for bit data)\z/i) { |
158 | my $base_type = lc($1 || $2); |
159 | |
160 | (my $original_type = $data_type) =~ s/[()]+ //; |
161 | |
162 | $info->{original}{data_type} = $original_type; |
163 | |
164 | if ($base_type eq 'long varchar') { |
165 | $info->{data_type} = 'blob'; |
166 | } |
167 | else { |
168 | if ($base_type eq 'char') { |
169 | $info->{data_type} = 'binary'; |
170 | } |
171 | elsif ($base_type eq 'varchar') { |
172 | $info->{data_type} = 'varbinary'; |
173 | } |
174 | |
175 | my ($size) = $dbh->selectrow_array(<<'EOF', {}, $self->db_schema, $self->_uc($table), $self->_uc($col)); |
176 | SELECT length |
177 | FROM syscat.columns |
178 | WHERE tabschema = ? AND tabname = ? AND colname = ? |
179 | EOF |
180 | |
181 | $info->{size} = $size if $size; |
182 | } |
183 | } |
184 | |
185 | if ((eval { lc ${ $info->{default_value} } }||'') =~ /^current (date|time(?:stamp)?)\z/i) { |
186 | my $type = lc($1); |
187 | |
188 | ${ $info->{default_value} } = 'current_timestamp'; |
701cd3e3 |
189 | |
7640ef4b |
190 | my $orig_deflt = "current $type"; |
701cd3e3 |
191 | $info->{original}{default_value} = \$orig_deflt; |
8a64178e |
192 | } |
772cfe65 |
193 | } |
194 | |
8a64178e |
195 | return $result; |
772cfe65 |
196 | } |
197 | |
996be9ee |
198 | =head1 SEE ALSO |
199 | |
200 | L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, |
201 | L<DBIx::Class::Schema::Loader::DBI> |
202 | |
be80bba7 |
203 | =head1 AUTHOR |
204 | |
9cc8e7e1 |
205 | See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. |
be80bba7 |
206 | |
207 | =head1 LICENSE |
208 | |
209 | This library is free software; you can redistribute it and/or modify it under |
210 | the same terms as Perl itself. |
211 | |
996be9ee |
212 | =cut |
213 | |
214 | 1; |
8a64178e |
215 | # vim:et sts=4 sw=4 tw=0: |