4890b1011b188be59165ec01eda036d02094f41e
[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / DBI.pm
1 package DBIx::Class::Schema::Loader::DBI;
2
3 use strict;
4 use warnings;
5 use base qw/DBIx::Class::Schema::Loader::Base/;
6 use Class::C3;
7 use Carp::Clan qw/^DBIx::Class/;
8
9 our $VERSION = '0.04999_07';
10
11 =head1 NAME
12
13 DBIx::Class::Schema::Loader::DBI - DBIx::Class::Schema::Loader DBI Implementation.
14
15 =head1 SYNOPSIS
16
17 See L<DBIx::Class::Schema::Loader::Base>
18
19 =head1 DESCRIPTION
20
21 This is the base class for L<DBIx::Class::Schema::Loader::Base> classes for
22 DBI-based storage backends, and implements the common functionality between them.
23
24 See L<DBIx::Class::Schema::Loader::Base> for the available options.
25
26 =head1 METHODS
27
28 =head2 new
29
30 Overlays L<DBIx::Class::Schema::Loader::Base/new> to do some DBI-specific
31 things.
32
33 =cut
34
35 sub new {
36     my $self = shift->next::method(@_);
37
38     # rebless to vendor-specific class if it exists and loads
39     my $dbh = $self->schema->storage->dbh;
40     my $driver = $dbh->{Driver}->{Name};
41
42     my $subclass = 'DBIx::Class::Schema::Loader::DBI::' . $driver;
43     if ($self->load_optional_class($subclass)) {
44         bless $self, $subclass unless $self->isa($subclass);
45         $self->_rebless;
46     }
47
48     # Set up the default quoting character and name seperators
49     $self->{_quoter} = $self->_build_quoter;
50     $self->{_namesep} = $self->_build_namesep;
51     # For our usage as regex matches, concatenating multiple quoter
52     # values works fine (e.g. s/\Q<>\E// if quoter was [ '<', '>' ])
53     if( ref $self->{_quoter} eq 'ARRAY') {
54         $self->{_quoter} = join(q{}, @{$self->{_quoter}});
55     }
56
57     $self->_setup;
58
59     $self;
60 }
61
62 sub _build_quoter {
63     my $self = shift;
64     my $dbh = $self->schema->storage->dbh;
65     return $dbh->get_info(29)
66            || $self->schema->storage->sql_maker->quote_char
67            || q{"};
68 }
69
70 sub _build_namesep {
71     my $self = shift;
72     my $dbh = $self->schema->storage->dbh;
73     return $dbh->get_info(41)
74            || $self->schema->storage->sql_maker->name_sep
75            || q{.};
76 }
77
78 # Override this in vendor modules to do things at the end of ->new()
79 sub _setup { }
80
81 # Override this in vendor module to load a subclass if necessary
82 sub _rebless { }
83
84 # Returns an array of table names
85 sub _tables_list { 
86     my $self = shift;
87
88     my ($table, $type) = @_ ? @_ : ('%', '%');
89
90     my $dbh = $self->schema->storage->dbh;
91     my @tables = $dbh->tables(undef, $self->db_schema, $table, $type);
92
93     s/\Q$self->{_quoter}\E//g    for @tables;
94     s/^.*\Q$self->{_namesep}\E// for @tables;
95
96     return @tables;
97 }
98
99 =head2 load
100
101 We override L<DBIx::Class::Schema::Loader::Base/load> here to hook in our localized settings for C<$dbh> error handling.
102
103 =cut
104
105 sub load {
106     my $self = shift;
107
108     local $self->schema->storage->dbh->{RaiseError} = 1;
109     local $self->schema->storage->dbh->{PrintError} = 0;
110     $self->next::method(@_);
111 }
112
113 # Returns an arrayref of column names
114 sub _table_columns {
115     my ($self, $table) = @_;
116
117     my $dbh = $self->schema->storage->dbh;
118
119     if($self->{db_schema}) {
120         $table = $self->{db_schema} . $self->{_namesep} . $table;
121     }
122
123     my $sth = $dbh->prepare($self->schema->storage->sql_maker->select($table, undef, \'1 = 0'));
124     $sth->execute;
125     my $retval = \@{$sth->{NAME_lc}};
126     $sth->finish;
127
128     $retval;
129 }
130
131 # Returns arrayref of pk col names
132 sub _table_pk_info { 
133     my ($self, $table) = @_;
134
135     my $dbh = $self->schema->storage->dbh;
136
137     my @primary = map { lc } $dbh->primary_key('', $self->db_schema, $table);
138     s/\Q$self->{_quoter}\E//g for @primary;
139
140     return \@primary;
141 }
142
143 # Override this for vendor-specific uniq info
144 sub _table_uniq_info {
145     my ($self, $table) = @_;
146
147     my $dbh = $self->schema->storage->dbh;
148     if(!$dbh->can('statistics_info')) {
149         warn "No UNIQUE constraint information can be gathered for this vendor";
150         return [];
151     }
152
153     my %indices;
154     my $sth = $dbh->statistics_info(undef, $self->db_schema, $table, 1, 1);
155     while(my $row = $sth->fetchrow_hashref) {
156         # skip table-level stats, conditional indexes, and any index missing
157         #  critical fields
158         next if $row->{TYPE} eq 'table'
159             || defined $row->{FILTER_CONDITION}
160             || !$row->{INDEX_NAME}
161             || !defined $row->{ORDINAL_POSITION}
162             || !$row->{COLUMN_NAME};
163
164         $indices{$row->{INDEX_NAME}}->{$row->{ORDINAL_POSITION}} = $row->{COLUMN_NAME};
165     }
166     $sth->finish;
167
168     my @retval;
169     foreach my $index_name (keys %indices) {
170         my $index = $indices{$index_name};
171         push(@retval, [ $index_name => [
172             map { $index->{$_} }
173                 sort keys %$index
174         ]]);
175     }
176
177     return \@retval;
178 }
179
180 # Find relationships
181 sub _table_fk_info {
182     my ($self, $table) = @_;
183
184     my $dbh = $self->schema->storage->dbh;
185     my $sth = $dbh->foreign_key_info( '', $self->db_schema, '',
186                                       '', $self->db_schema, $table );
187     return [] if !$sth;
188
189     my %rels;
190
191     my $i = 1; # for unnamed rels, which hopefully have only 1 column ...
192     while(my $raw_rel = $sth->fetchrow_arrayref) {
193         my $uk_tbl  = $raw_rel->[2];
194         my $uk_col  = lc $raw_rel->[3];
195         my $fk_col  = lc $raw_rel->[7];
196         my $relid   = ($raw_rel->[11] || ( "__dcsld__" . $i++ ));
197         $uk_tbl =~ s/\Q$self->{_quoter}\E//g;
198         $uk_col =~ s/\Q$self->{_quoter}\E//g;
199         $fk_col =~ s/\Q$self->{_quoter}\E//g;
200         $relid  =~ s/\Q$self->{_quoter}\E//g;
201         $rels{$relid}->{tbl} = $uk_tbl;
202         $rels{$relid}->{cols}->{$uk_col} = $fk_col;
203     }
204     $sth->finish;
205
206     my @rels;
207     foreach my $relid (keys %rels) {
208         push(@rels, {
209             remote_columns => [ keys   %{$rels{$relid}->{cols}} ],
210             local_columns  => [ values %{$rels{$relid}->{cols}} ],
211             remote_table   => $rels{$relid}->{tbl},
212         });
213     }
214
215     return \@rels;
216 }
217
218 # ported in from DBIx::Class::Storage::DBI:
219 sub _columns_info_for {
220     my ($self, $table) = @_;
221
222     my $dbh = $self->schema->storage->dbh;
223
224     if ($dbh->can('column_info')) {
225         my %result;
226         eval {
227             my $sth = $dbh->column_info( undef, $self->db_schema, $table, '%' );
228             while ( my $info = $sth->fetchrow_hashref() ){
229                 my %column_info;
230                 $column_info{data_type}   = $info->{TYPE_NAME};
231                 $column_info{size}      = $info->{COLUMN_SIZE};
232                 $column_info{is_nullable}   = $info->{NULLABLE} ? 1 : 0;
233                 $column_info{default_value} = $info->{COLUMN_DEF};
234                 my $col_name = $info->{COLUMN_NAME};
235                 $col_name =~ s/^\"(.*)\"$/$1/;
236
237                 my $extra_info = $self->_extra_column_info($info) || {};
238
239                 $result{$col_name} = { %column_info, %$extra_info };
240             }
241             $sth->finish;
242         };
243       return \%result if !$@ && scalar keys %result;
244     }
245
246     if($self->db_schema) {
247         $table = $self->db_schema . $self->{_namesep} . $table;
248     }
249     my %result;
250     my $sth = $dbh->prepare($self->schema->storage->sql_maker->select($table, undef, \'1 = 0'));
251     $sth->execute;
252     my @columns = @{$sth->{NAME_lc}};
253     for my $i ( 0 .. $#columns ){
254         my %column_info;
255         $column_info{data_type} = $sth->{TYPE}->[$i];
256         $column_info{size} = $sth->{PRECISION}->[$i];
257         $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
258
259         if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
260             $column_info{data_type} = $1;
261             $column_info{size}    = $2;
262         }
263
264         my $extra_info = $self->_extra_column_info($table, $columns[$i], $sth, $i) || {};
265
266         $result{$columns[$i]} = { %column_info, %$extra_info };
267     }
268     $sth->finish;
269
270     foreach my $col (keys %result) {
271         my $colinfo = $result{$col};
272         my $type_num = $colinfo->{data_type};
273         my $type_name;
274         if(defined $type_num && $dbh->can('type_info')) {
275             my $type_info = $dbh->type_info($type_num);
276             $type_name = $type_info->{TYPE_NAME} if $type_info;
277             $colinfo->{data_type} = $type_name if $type_name;
278         }
279     }
280
281     return \%result;
282 }
283
284 # Override this in vendor class to return any additional column
285 # attributes
286 sub _extra_column_info {}
287
288 =head1 SEE ALSO
289
290 L<DBIx::Class::Schema::Loader>
291
292 =cut
293
294 1;