Commit | Line | Data |
18fca96a |
1 | package DBIx::Class::Schema::Loader::Generic; |
a78e3fed |
2 | |
3 | use strict; |
a4a19f3c |
4 | use warnings; |
457eb8a6 |
5 | use base qw/Class::Accessor::Fast/; |
2a4b8262 |
6 | use Class::C3; |
a78e3fed |
7 | use Carp; |
8 | use Lingua::EN::Inflect; |
8563178e |
9 | use UNIVERSAL::require; |
a78e3fed |
10 | require DBIx::Class::Core; |
a4a19f3c |
11 | |
3980d69c |
12 | # The first group are all arguments which are may be defaulted within, |
13 | # The last two (classes, monikers) are generated locally: |
14 | |
15 | __PACKAGE__->mk_ro_accessors(qw/ |
16 | schema |
17 | dsn |
18 | user |
19 | password |
20 | options |
21 | exclude |
22 | constraint |
23 | additional_classes |
24 | additional_base_classes |
25 | left_base_classes |
9fa99683 |
26 | components |
27 | resultset_components |
3980d69c |
28 | relationships |
29 | inflect |
30 | db_schema |
31 | drop_db_schema |
32 | debug |
33 | |
34 | classes |
35 | monikers |
36 | /); |
a4a19f3c |
37 | |
a78e3fed |
38 | =head1 NAME |
39 | |
18fca96a |
40 | DBIx::Class::Schema::Loader::Generic - Generic DBIx::Class::Schema::Loader Implementation. |
a78e3fed |
41 | |
42 | =head1 SYNOPSIS |
43 | |
18fca96a |
44 | See L<DBIx::Class::Schema::Loader> |
a78e3fed |
45 | |
46 | =head1 DESCRIPTION |
47 | |
457eb8a6 |
48 | This is the base class for the vendor-specific C<DBIx::Class::Schema::*> |
49 | classes, and implements the common functionality between them. |
50 | |
51 | =head1 OPTIONS |
a78e3fed |
52 | |
53 | Available constructor options are: |
54 | |
457eb8a6 |
55 | =head2 additional_base_classes |
a78e3fed |
56 | |
57 | List of additional base classes your table classes will use. |
58 | |
457eb8a6 |
59 | =head2 left_base_classes |
a78e3fed |
60 | |
61 | List of additional base classes, that need to be leftmost. |
62 | |
457eb8a6 |
63 | =head2 additional_classes |
a78e3fed |
64 | |
65 | List of additional classes which your table classes will use. |
66 | |
c2849787 |
67 | =head2 components |
68 | |
69 | List of additional components to be loaded into your table classes. |
70 | A good example would be C<ResultSetManager>. |
71 | |
72 | =head2 resultset_components |
73 | |
74 | List of additional resultset components to be loaded into your table |
75 | classes. A good example would be C<AlwaysRS>. Component |
76 | C<ResultSetManager> will be automatically added to the above |
77 | C<components> list if this option is set. |
78 | |
457eb8a6 |
79 | =head2 constraint |
a78e3fed |
80 | |
81 | Only load tables matching regex. |
82 | |
457eb8a6 |
83 | =head2 exclude |
a78e3fed |
84 | |
85 | Exclude tables matching regex. |
86 | |
457eb8a6 |
87 | =head2 debug |
a78e3fed |
88 | |
89 | Enable debug messages. |
90 | |
457eb8a6 |
91 | =head2 dsn |
a78e3fed |
92 | |
93 | DBI Data Source Name. |
94 | |
457eb8a6 |
95 | =head2 password |
a78e3fed |
96 | |
97 | Password. |
98 | |
457eb8a6 |
99 | =head2 relationships |
a78e3fed |
100 | |
101 | Try to automatically detect/setup has_a and has_many relationships. |
102 | |
457eb8a6 |
103 | =head2 inflect |
a78e3fed |
104 | |
105 | An hashref, which contains exceptions to Lingua::EN::Inflect::PL(). |
106 | Useful for foreign language column names. |
107 | |
457eb8a6 |
108 | =head2 user |
a78e3fed |
109 | |
110 | Username. |
111 | |
457eb8a6 |
112 | =head1 METHODS |
2a4b8262 |
113 | |
a78e3fed |
114 | =cut |
115 | |
3980d69c |
116 | # ensure that a peice of object data is a valid arrayref, creating |
117 | # an empty one or encapsulating whatever's there. |
118 | sub _ensure_arrayref { |
119 | my $self = shift; |
e26a4023 |
120 | |
3980d69c |
121 | foreach (@_) { |
122 | $self->{$_} ||= []; |
123 | $self->{$_} = [ $self->{$_} ] |
124 | unless ref $self->{$_} eq 'ARRAY'; |
125 | } |
a78e3fed |
126 | } |
127 | |
457eb8a6 |
128 | =head2 new |
129 | |
130 | Constructor for L<DBIx::Class::Schema::Loader::Generic>, used internally |
131 | by L<DBIx::Class::Schema::Loader>. |
132 | |
133 | =cut |
134 | |
3980d69c |
135 | sub new { |
136 | my ( $class, %args ) = @_; |
a78e3fed |
137 | |
3980d69c |
138 | my $self = { %args }; |
fbd83464 |
139 | |
3980d69c |
140 | bless $self => $class; |
fbd83464 |
141 | |
3980d69c |
142 | $self->{db_schema} ||= ''; |
143 | $self->{constraint} ||= '.*'; |
144 | $self->{inflect} ||= {}; |
145 | $self->_ensure_arrayref(qw/additional_classes |
146 | additional_base_classes |
c2849787 |
147 | left_base_classes |
9fa99683 |
148 | components |
149 | resultset_components/); |
c2849787 |
150 | |
151 | push(@{$self->{components}}, 'ResultSetManager') |
152 | if @{$self->{resultset_components}}; |
fbd83464 |
153 | |
3980d69c |
154 | $self->{monikers} = {}; |
155 | $self->{classes} = {}; |
a78e3fed |
156 | |
2a4b8262 |
157 | $self; |
158 | } |
159 | |
457eb8a6 |
160 | =head2 load |
161 | |
162 | Does the actual schema-construction work, used internally by |
163 | L<DBIx::Class::Schema::Loader> right after object construction. |
164 | |
165 | =cut |
166 | |
2a4b8262 |
167 | sub load { |
168 | my $self = shift; |
169 | |
3980d69c |
170 | $self->schema->connection($self->dsn, $self->user, |
171 | $self->password, $self->options); |
a78e3fed |
172 | |
3980d69c |
173 | warn qq/\### START DBIx::Class::Schema::Loader dump ###\n/ |
174 | if $self->debug; |
a78e3fed |
175 | |
3980d69c |
176 | $self->_load_classes; |
177 | $self->_load_relationships if $self->relationships; |
a78e3fed |
178 | |
3980d69c |
179 | warn qq/\### END DBIx::Class::Schema::Loader dump ###\n/ |
180 | if $self->debug; |
52bf3f26 |
181 | $self->schema->storage->disconnect; |
a78e3fed |
182 | |
3980d69c |
183 | $self; |
a78e3fed |
184 | } |
185 | |
186 | # Overload in your driver class |
3980d69c |
187 | sub _db_classes { croak "ABSTRACT METHOD" } |
66742793 |
188 | |
16f6b6ac |
189 | # Inflect a relationship name |
190 | # XXX (should pluralize, but currently also tends to de-pluralize plurals) |
3980d69c |
191 | sub _inflect_relname { |
192 | my ($self, $relname) = @_; |
708c0939 |
193 | |
3980d69c |
194 | return $self->inflect->{$relname} if exists $self->inflect->{$relname}; |
195 | return Lingua::EN::Inflect::PL($relname); |
16f6b6ac |
196 | } |
a78e3fed |
197 | |
16f6b6ac |
198 | # Set up a simple relation with just a local col and foreign table |
3980d69c |
199 | sub _make_simple_rel { |
200 | my ($self, $table, $other, $col) = @_; |
708c0939 |
201 | |
3980d69c |
202 | my $table_class = $self->classes->{$table}; |
203 | my $other_class = $self->classes->{$other}; |
204 | my $table_relname = $self->_inflect_relname(lc $table); |
66742793 |
205 | |
3980d69c |
206 | warn qq/\# Belongs_to relationship\n/ if $self->debug; |
16f6b6ac |
207 | warn qq/$table_class->belongs_to( '$col' => '$other_class' );\n\n/ |
3980d69c |
208 | if $self->debug; |
16f6b6ac |
209 | $table_class->belongs_to( $col => $other_class ); |
708c0939 |
210 | |
3980d69c |
211 | warn qq/\# Has_many relationship\n/ if $self->debug; |
16f6b6ac |
212 | warn qq/$other_class->has_many( '$table_relname' => '$table_class',/ |
213 | . qq/$col);\n\n/ |
3980d69c |
214 | if $self->debug; |
708c0939 |
215 | |
16f6b6ac |
216 | $other_class->has_many( $table_relname => $table_class, $col); |
217 | } |
a78e3fed |
218 | |
3980d69c |
219 | # not a class method, just a helper for cond_rel XXX |
220 | sub _stringify_hash { |
221 | my $href = shift; |
222 | |
223 | return '{ ' . |
224 | join(q{, }, map("$_ => $href->{$_}", keys %$href)) |
225 | . ' }'; |
226 | } |
227 | |
16f6b6ac |
228 | # Set up a complex relation based on a hashref condition |
3980d69c |
229 | sub _make_cond_rel { |
230 | my ( $self, $table, $other, $cond ) = @_; |
a78e3fed |
231 | |
3980d69c |
232 | my $table_class = $self->classes->{$table}; |
233 | my $other_class = $self->classes->{$other}; |
234 | my $table_relname = $self->_inflect_relname(lc $table); |
16f6b6ac |
235 | my $other_relname = lc $other; |
708c0939 |
236 | |
16f6b6ac |
237 | # for single-column case, set the relname to the column name, |
238 | # to make filter accessors work |
239 | if(scalar keys %$cond == 1) { |
240 | my ($col) = keys %$cond; |
241 | $other_relname = $cond->{$col}; |
4ce22656 |
242 | } |
16f6b6ac |
243 | |
244 | my $rev_cond = { reverse %$cond }; |
245 | |
c5de0b0c |
246 | for (keys %$rev_cond) { |
c2849787 |
247 | $rev_cond->{"foreign.$_"} = "self.".$rev_cond->{$_}; |
248 | delete $rev_cond->{$_}; |
c5de0b0c |
249 | } |
250 | |
3980d69c |
251 | my $cond_printable = _stringify_hash($cond) |
252 | if $self->debug; |
253 | my $rev_cond_printable = _stringify_hash($rev_cond) |
254 | if $self->debug; |
16f6b6ac |
255 | |
3980d69c |
256 | warn qq/\# Belongs_to relationship\n/ if $self->debug; |
16f6b6ac |
257 | |
258 | warn qq/$table_class->belongs_to( '$other_relname' => '$other_class',/ |
259 | . qq/$cond_printable);\n\n/ |
3980d69c |
260 | if $self->debug; |
16f6b6ac |
261 | |
262 | $table_class->belongs_to( $other_relname => $other_class, $cond); |
263 | |
3980d69c |
264 | warn qq/\# Has_many relationship\n/ if $self->debug; |
16f6b6ac |
265 | |
266 | warn qq/$other_class->has_many( '$table_relname' => '$table_class',/ |
267 | . qq/$rev_cond_printable);\n\n/ |
268 | . qq/);\n\n/ |
3980d69c |
269 | if $self->debug; |
16f6b6ac |
270 | |
271 | $other_class->has_many( $table_relname => $table_class, $rev_cond); |
a78e3fed |
272 | } |
273 | |
42c0680e |
274 | sub _use { |
275 | my $self = shift; |
276 | my $target = shift; |
277 | |
278 | foreach (@_) { |
279 | $_->require or croak ($_ . "->require: $@"); |
280 | eval "package $target; use $_;"; |
281 | croak "use $_: $@" if $@; |
282 | } |
283 | } |
284 | |
285 | sub _inject { |
286 | my $self = shift; |
287 | my $target = shift; |
288 | my $schema = $self->schema; |
289 | |
290 | foreach (@_) { |
291 | $_->require or croak ($_ . "->require: $@"); |
292 | $schema->inject_base($target, $_); |
293 | } |
294 | } |
295 | |
a78e3fed |
296 | # Load and setup classes |
3980d69c |
297 | sub _load_classes { |
298 | my $self = shift; |
af6c2665 |
299 | |
3980d69c |
300 | my @tables = $self->_tables(); |
301 | my @db_classes = $self->_db_classes(); |
302 | my $schema = $self->schema; |
a78e3fed |
303 | |
a78e3fed |
304 | foreach my $table (@tables) { |
3980d69c |
305 | my $constraint = $self->constraint; |
306 | my $exclude = $self->exclude; |
307 | |
308 | next unless $table =~ /$constraint/; |
309 | next if defined $exclude && $table =~ /$exclude/; |
af6c2665 |
310 | |
af6c2665 |
311 | my ($db_schema, $tbl) = split /\./, $table; |
af96f52e |
312 | my $tablename = lc $table; |
a78e3fed |
313 | if($tbl) { |
3980d69c |
314 | $tablename = $self->drop_db_schema ? $tbl : lc $table; |
af6c2665 |
315 | } |
3980d69c |
316 | my $lc_tblname = lc $tablename; |
af6c2665 |
317 | |
3980d69c |
318 | my $table_moniker = $self->_table2moniker($db_schema, $tbl); |
319 | my $table_class = $schema . q{::} . $table_moniker; |
af6c2665 |
320 | |
9fa99683 |
321 | { no strict 'refs'; |
322 | @{"${table_class}::ISA"} = ($schema); |
323 | } |
42c0680e |
324 | $self->_use ($table_class, @{$self->additional_classes}); |
9fa99683 |
325 | $self->_inject($table_class, @{$self->additional_base_classes}); |
326 | $table_class->load_components(@{$self->components}, @db_classes, 'Core'); |
327 | $table_class->load_resultset_components(@{$self->resultset_components}) |
328 | if @{$self->resultset_components}; |
42c0680e |
329 | $self->_inject($table_class, @{$self->left_base_classes}); |
3980d69c |
330 | |
331 | warn qq/\# Initializing table "$tablename" as "$table_class"\n/ |
332 | if $self->debug; |
e26a4023 |
333 | $table_class->table($lc_tblname); |
af6c2665 |
334 | |
3980d69c |
335 | my ( $cols, $pks ) = $self->_table_info($table); |
a78e3fed |
336 | carp("$table has no primary key") unless @$pks; |
a4a19f3c |
337 | $table_class->add_columns(@$cols); |
338 | $table_class->set_primary_key(@$pks) if @$pks; |
af6c2665 |
339 | |
3980d69c |
340 | warn qq/$table_class->table('$tablename');\n/ if $self->debug; |
a78e3fed |
341 | my $columns = join "', '", @$cols; |
3980d69c |
342 | warn qq/$table_class->add_columns('$columns')\n/ if $self->debug; |
a78e3fed |
343 | my $primaries = join "', '", @$pks; |
3980d69c |
344 | warn qq/$table_class->set_primary_key('$primaries')\n/ |
345 | if $self->debug && @$pks; |
af6c2665 |
346 | |
c2849787 |
347 | $table_class->require; |
348 | if($@ && $@ !~ /^Can't locate /) { |
349 | croak "Failed to load external class definition" |
350 | . "for '$table_class': $@"; |
351 | } |
352 | |
353 | warn qq/# Loaded external class definition for '$table_class'\n/ |
354 | if $self->debug; |
355 | |
3980d69c |
356 | $schema->register_class($table_moniker, $table_class); |
357 | $self->classes->{$lc_tblname} = $table_class; |
358 | $self->monikers->{$lc_tblname} = $table_moniker; |
a78e3fed |
359 | } |
360 | } |
361 | |
457eb8a6 |
362 | =head2 tables |
3980d69c |
363 | |
8a6b44ef |
364 | Returns a sorted list of loaded tables, using the original database table |
365 | names. Actually generated from the keys of the C<monikers> hash below. |
3980d69c |
366 | |
457eb8a6 |
367 | my @tables = $schema->loader->tables; |
3980d69c |
368 | |
369 | =cut |
370 | |
371 | sub tables { |
372 | my $self = shift; |
373 | |
374 | return sort keys %{ $self->monikers }; |
375 | } |
376 | |
a78e3fed |
377 | # Find and setup relationships |
3980d69c |
378 | sub _load_relationships { |
379 | my $self = shift; |
380 | |
381 | my $dbh = $self->schema->storage->dbh; |
708c0939 |
382 | my $quoter = $dbh->get_info(29) || q{"}; |
3980d69c |
383 | foreach my $table ( $self->tables ) { |
708c0939 |
384 | my $rels = {}; |
385 | my $sth = $dbh->foreign_key_info( '', |
3980d69c |
386 | $self->db_schema, '', '', '', $table ); |
708c0939 |
387 | next if !$sth; |
388 | while(my $raw_rel = $sth->fetchrow_hashref) { |
389 | my $uk_tbl = lc $raw_rel->{UK_TABLE_NAME}; |
390 | my $uk_col = lc $raw_rel->{UK_COLUMN_NAME}; |
391 | my $fk_col = lc $raw_rel->{FK_COLUMN_NAME}; |
4ce22656 |
392 | my $relid = lc $raw_rel->{UK_NAME}; |
708c0939 |
393 | $uk_tbl =~ s/$quoter//g; |
394 | $uk_col =~ s/$quoter//g; |
395 | $fk_col =~ s/$quoter//g; |
4ce22656 |
396 | $relid =~ s/$quoter//g; |
397 | $rels->{$relid}->{tbl} = $uk_tbl; |
398 | $rels->{$relid}->{cols}->{$uk_col} = $fk_col; |
708c0939 |
399 | } |
400 | |
4ce22656 |
401 | foreach my $relid (keys %$rels) { |
402 | my $reltbl = $rels->{$relid}->{tbl}; |
403 | my $cond = $rels->{$relid}->{cols}; |
3980d69c |
404 | eval { $self->_make_cond_rel( $table, $reltbl, $cond ) }; |
708c0939 |
405 | warn qq/\# belongs_to_many failed "$@"\n\n/ |
3980d69c |
406 | if $@ && $self->debug; |
a78e3fed |
407 | } |
408 | } |
409 | } |
410 | |
65644119 |
411 | # Make a moniker from a table |
3980d69c |
412 | sub _table2moniker { |
413 | my ( $self, $db_schema, $table ) = @_; |
af6c2665 |
414 | |
af96f52e |
415 | my $db_schema_ns; |
af6c2665 |
416 | |
af96f52e |
417 | if($table) { |
418 | $db_schema = ucfirst lc $db_schema; |
3980d69c |
419 | $db_schema_ns = $db_schema if(!$self->drop_db_schema); |
af96f52e |
420 | } else { |
421 | $table = $db_schema; |
a78e3fed |
422 | } |
af6c2665 |
423 | |
65644119 |
424 | my $moniker = join '', map ucfirst, split /[\W_]+/, lc $table; |
425 | $moniker = $db_schema_ns ? $db_schema_ns . $moniker : $moniker; |
af96f52e |
426 | |
65644119 |
427 | return $moniker; |
a78e3fed |
428 | } |
429 | |
430 | # Overload in driver class |
3980d69c |
431 | sub _tables { croak "ABSTRACT METHOD" } |
a78e3fed |
432 | |
3980d69c |
433 | sub _table_info { croak "ABSTRACT METHOD" } |
a78e3fed |
434 | |
457eb8a6 |
435 | =head2 monikers |
436 | |
437 | Returns a hashref of loaded table-to-moniker mappings for the original |
438 | database table names. |
439 | |
440 | my $monikers = $schema->loader->monikers; |
441 | my $foo_tbl_moniker = $monikers->{foo_tbl}; |
442 | # -or- |
443 | my $foo_tbl_moniker = $schema->loader->monikers->{foo_tbl}; |
444 | # $foo_tbl_moniker would look like "FooTbl" |
445 | |
446 | =head2 classes |
447 | |
448 | Returns a hashref of table-to-classname mappings for the original database |
449 | table names. You probably shouldn't be using this for any normal or simple |
450 | usage of your Schema. The usual way to run queries on your tables is via |
451 | C<$schema-E<gt>resultset('FooTbl')>, where C<FooTbl> is a moniker as |
452 | returned by C<monikers> above. |
453 | |
454 | my $classes = $schema->loader->classes; |
455 | my $foo_tbl_class = $classes->{foo_tbl}; |
456 | # -or- |
457 | my $foo_tbl_class = $schema->loader->classes->{foo_tbl}; |
458 | # $foo_tbl_class would look like "My::Schema::FooTbl", |
459 | # assuming the schema class is "My::Schema" |
460 | |
a78e3fed |
461 | =head1 SEE ALSO |
462 | |
18fca96a |
463 | L<DBIx::Class::Schema::Loader> |
a78e3fed |
464 | |
465 | =cut |
466 | |
467 | 1; |