File Coverage

blib/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm
Criterion Covered Total %
statement 24 108 22.2
branch 0 36 0.0
condition 0 22 0.0
subroutine 8 16 50.0
pod n/a
total 32 182 17.5


line stmt bran cond sub pod time code
1             package DBIx::Class::Schema::Loader::DBI::DB2;
2              
3 1     1   1051 use strict;
  1         2  
  1         31  
4 1     1   6 use warnings;
  1         3  
  1         31  
5 1         132 use base qw/
6             DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault
7             DBIx::Class::Schema::Loader::DBI
8 1     1   5 /;
  1         3  
9 1     1   7 use mro 'c3';
  1         3  
  1         5  
10              
11 1     1   42 use List::Util 'any';
  1         2  
  1         65  
12 1     1   7 use namespace::clean;
  1         40  
  1         9  
13              
14 1     1   207 use DBIx::Class::Schema::Loader::Table ();
  1         4  
  1         1090  
15              
16             our $VERSION = '0.07051';
17              
18             =head1 NAME
19              
20             DBIx::Class::Schema::Loader::DBI::DB2 - DBIx::Class::Schema::Loader::DBI DB2 Implementation.
21              
22             =head1 DESCRIPTION
23              
24             See L and L.
25              
26             =cut
27              
28             sub _system_schemas {
29 0     0     my $self = shift;
30              
31 0           return ($self->next::method(@_), qw/
32             SYSCAT SYSIBM SYSIBMADM SYSPUBLIC SYSSTAT SYSTOOLS
33             /);
34             }
35              
36             sub _setup {
37 0     0     my $self = shift;
38              
39 0           $self->next::method(@_);
40              
41 0           my $ns = $self->name_sep;
42              
43 0 0         $self->db_schema([ $self->dbh->selectrow_array(<<"EOF", {}) ]) unless $self->db_schema;
44             SELECT CURRENT_SCHEMA FROM sysibm${ns}sysdummy1
45             EOF
46              
47 0 0         if (not defined $self->preserve_case) {
    0          
48 0           $self->preserve_case(0);
49             }
50             elsif ($self->preserve_case) {
51 0           $self->schema->storage->sql_maker->quote_char('"');
52 0           $self->schema->storage->sql_maker->name_sep($ns);
53             }
54             }
55              
56             sub _table_uniq_info {
57 0     0     my ($self, $table) = @_;
58              
59 0           my @uniqs;
60              
61 0   0       my $sth = $self->{_cache}->{db2_uniq} ||= $self->dbh->prepare(<<'EOF');
62             SELECT kcu.colname, kcu.constname, kcu.colseq
63             FROM syscat.tabconst as tc
64             JOIN syscat.keycoluse as kcu
65             ON tc.constname = kcu.constname
66             AND tc.tabschema = kcu.tabschema
67             AND tc.tabname = kcu.tabname
68             WHERE tc.tabschema = ? and tc.tabname = ? and tc.type = 'U'
69             EOF
70              
71 0           $sth->execute($table->schema, $table->name);
72              
73 0           my %keydata;
74 0           while(my $row = $sth->fetchrow_arrayref) {
75 0           my ($col, $constname, $seq) = @$row;
76 0           push(@{$keydata{$constname}}, [ $seq, $self->_lc($col) ]);
  0            
77             }
78 0           foreach my $keyname (sort keys %keydata) {
79 0           my @ordered_cols = map { $_->[1] } sort { $a->[0] <=> $b->[0] }
  0            
80 0           @{$keydata{$keyname}};
  0            
81 0           push(@uniqs, [ $keyname => \@ordered_cols ]);
82             }
83              
84 0           $sth->finish;
85              
86 0           return \@uniqs;
87             }
88              
89             sub _table_fk_info {
90 0     0     my ($self, $table) = @_;
91              
92 0   0       my $sth = $self->{_cache}->{db2_fk} ||= $self->dbh->prepare(<<'EOF');
93             SELECT tc.constname, sr.reftabschema, sr.reftabname,
94             kcu.colname, rkcu.colname, kcu.colseq,
95             sr.deleterule, sr.updaterule
96             FROM syscat.tabconst tc
97             JOIN syscat.keycoluse kcu
98             ON tc.constname = kcu.constname
99             AND tc.tabschema = kcu.tabschema
100             AND tc.tabname = kcu.tabname
101             JOIN syscat.references sr
102             ON tc.constname = sr.constname
103             AND tc.tabschema = sr.tabschema
104             AND tc.tabname = sr.tabname
105             JOIN syscat.keycoluse rkcu
106             ON sr.refkeyname = rkcu.constname
107             AND sr.reftabschema = rkcu.tabschema
108             AND sr.reftabname = rkcu.tabname
109             AND kcu.colseq = rkcu.colseq
110             WHERE tc.tabschema = ?
111             AND tc.tabname = ?
112             AND tc.type = 'F';
113             EOF
114 0           $sth->execute($table->schema, $table->name);
115              
116 0           my %rels;
117              
118 0           my %rules = (
119             A => 'NO ACTION',
120             C => 'CASCADE',
121             N => 'SET NULL',
122             R => 'RESTRICT',
123             );
124              
125 0           COLS: while (my @row = $sth->fetchrow_array) {
126 0           my ($fk, $remote_schema, $remote_table, $local_col, $remote_col,
127             $colseq, $delete_rule, $update_rule) = @row;
128              
129 0 0         if (not exists $rels{$fk}) {
130 0 0 0       if ($self->db_schema && $self->db_schema->[0] ne '%'
      0        
131 0     0     && (not any { $_ eq $remote_schema } @{ $self->db_schema })) {
  0            
132              
133 0           next COLS;
134             }
135              
136 0           $rels{$fk}{remote_table} = DBIx::Class::Schema::Loader::Table->new(
137             loader => $self,
138             name => $remote_table,
139             schema => $remote_schema,
140             );
141             }
142              
143 0           $rels{$fk}{local_columns}[$colseq-1] = $self->_lc($local_col);
144 0           $rels{$fk}{remote_columns}[$colseq-1] = $self->_lc($remote_col);
145              
146             $rels{$fk}{attrs} ||= {
147             on_delete => $rules{$delete_rule},
148 0   0       on_update => $rules{$update_rule},
149             is_deferrable => 1, # DB2 has no deferrable constraints
150             };
151             }
152              
153 0           return [ values %rels ];
154             }
155              
156              
157             # DBD::DB2 doesn't follow the DBI API for ->tables (pre 1.85), but since its
158             # backwards compatible we don't change it.
159             # DBD::DB2 1.85 and beyond default TABLE_NAME to '', previously defaulted to
160             # '%'. so we supply it.
161             sub _dbh_tables {
162 0     0     my ($self, $schema) = @_;
163              
164 0 0         return $self->dbh->tables($schema ? { TABLE_SCHEM => $schema, TABLE_NAME => '%' } : undef);
165             }
166              
167             sub _dbh_table_info {
168 0     0     my $self = shift;
169              
170 0           local $^W = 0; # shut up undef warning from DBD::DB2
171              
172 0           $self->next::method(@_);
173             }
174              
175             sub _columns_info_for {
176 0     0     my $self = shift;
177 0           my ($table) = @_;
178              
179 0           my $result = $self->next::method(@_);
180              
181 0           while (my ($col, $info) = each %$result) {
182             # check for identities
183 0           my $sth = $self->dbh->prepare_cached(
184             q{
185             SELECT COUNT(*)
186             FROM syscat.columns
187             WHERE tabschema = ? AND tabname = ? AND colname = ?
188             AND identity = 'Y' AND generated != ''
189             },
190             {}, 1);
191 0           $sth->execute($table->schema, $table->name, $self->_uc($col));
192 0 0         if ($sth->fetchrow_array) {
193 0           $info->{is_auto_increment} = 1;
194             }
195              
196 0           my $data_type = $info->{data_type};
197              
198 0 0         if ($data_type !~ /^(?:(?:var)?(?:char|graphic)|decimal)\z/i) {
199 0           delete $info->{size};
200             }
201              
202 0 0         if ($data_type eq 'double') {
    0          
    0          
203 0           $info->{data_type} = 'double precision';
204             }
205             elsif ($data_type eq 'decimal') {
206 1     1   9 no warnings 'uninitialized';
  1         3  
  1         422  
207              
208 0           $info->{data_type} = 'numeric';
209              
210 0 0         my @size = @{ $info->{size} || [] };
  0            
211              
212 0 0 0       if ($size[0] == 5 && $size[1] == 0) {
213 0           delete $info->{size};
214             }
215             }
216             elsif ($data_type =~ /^(?:((?:var)?char) \(\) for bit data|(long varchar) for bit data)\z/i) {
217 0   0       my $base_type = lc($1 || $2);
218              
219 0           (my $original_type = $data_type) =~ s/[()]+ //;
220              
221 0           $info->{original}{data_type} = $original_type;
222              
223 0 0         if ($base_type eq 'long varchar') {
224 0           $info->{data_type} = 'blob';
225             }
226             else {
227 0 0         if ($base_type eq 'char') {
    0          
228 0           $info->{data_type} = 'binary';
229             }
230             elsif ($base_type eq 'varchar') {
231 0           $info->{data_type} = 'varbinary';
232             }
233              
234 0           my ($size) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name, $self->_uc($col));
235             SELECT length
236             FROM syscat.columns
237             WHERE tabschema = ? AND tabname = ? AND colname = ?
238             EOF
239              
240 0 0         $info->{size} = $size if $size;
241             }
242             }
243              
244 0 0 0       if ((eval { lc ${ $info->{default_value} } }||'') =~ /^current (date|time(?:stamp)?)\z/i) {
245 0           my $type = lc($1);
246              
247 0           ${ $info->{default_value} } = 'current_timestamp';
  0            
248              
249 0           my $orig_deflt = "current $type";
250 0           $info->{original}{default_value} = \$orig_deflt;
251             }
252             }
253              
254 0           return $result;
255             }
256              
257             =head1 SEE ALSO
258              
259             L, L,
260             L
261              
262             =head1 AUTHORS
263              
264             See L.
265              
266             =head1 LICENSE
267              
268             This library is free software; you can redistribute it and/or modify it under
269             the same terms as Perl itself.
270              
271             =cut
272              
273             1;
274             # vim:et sts=4 sw=4 tw=0: