Only redump the files when something has actually changed
[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / Base.pm
CommitLineData
996be9ee 1package DBIx::Class::Schema::Loader::Base;
2
3use strict;
4use warnings;
6ae3f335 5use base qw/Class::Accessor::Fast Class::C3::Componentised/;
996be9ee 6use Class::C3;
fa994d3c 7use Carp::Clan qw/^DBIx::Class/;
996be9ee 8use DBIx::Class::Schema::Loader::RelBuilder;
9use Data::Dump qw/ dump /;
10use POSIX qw//;
dd03ee1a 11use File::Spec qw//;
419a2eeb 12use Cwd qw//;
7cab3ab7 13use Digest::MD5 qw//;
22270947 14use Lingua::EN::Inflect::Number qw//;
af31090c 15use File::Temp qw//;
16use Class::Unload;
996be9ee 17require DBIx::Class;
18
1bcb47d3 19our $VERSION = '0.04999_08';
32f784fc 20
996be9ee 21__PACKAGE__->mk_ro_accessors(qw/
22 schema
23 schema_class
24
25 exclude
26 constraint
27 additional_classes
28 additional_base_classes
29 left_base_classes
30 components
31 resultset_components
59cfa251 32 skip_relationships
996be9ee 33 moniker_map
34 inflect_singular
35 inflect_plural
36 debug
37 dump_directory
d65cda9e 38 dump_overwrite
28b4691d 39 really_erase_my_files
f44ecc2f 40 use_namespaces
41 result_namespace
42 resultset_namespace
43 default_resultset_class
9c9c2f2b 44 schema_base_class
45 result_base_class
996be9ee 46
996be9ee 47 db_schema
48 _tables
49 classes
50 monikers
51 /);
52
53=head1 NAME
54
55DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
56
57=head1 SYNOPSIS
58
59See L<DBIx::Class::Schema::Loader>
60
61=head1 DESCRIPTION
62
63This is the base class for the storage-specific C<DBIx::Class::Schema::*>
64classes, and implements the common functionality between them.
65
66=head1 CONSTRUCTOR OPTIONS
67
68These constructor options are the base options for
29ddb54c 69L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
3953cbee 70
59cfa251 71=head2 skip_relationships
996be9ee 72
59cfa251 73Skip setting up relationships. The default is to attempt the loading
74of relationships.
996be9ee 75
76=head2 debug
77
78If set to true, each constructive L<DBIx::Class> statement the loader
79decides to execute will be C<warn>-ed before execution.
80
d65cda9e 81=head2 db_schema
82
83Set the name of the schema to load (schema in the sense that your database
84vendor means it). Does not currently support loading more than one schema
85name.
86
996be9ee 87=head2 constraint
88
89Only load tables matching regex. Best specified as a qr// regex.
90
91=head2 exclude
92
93Exclude tables matching regex. Best specified as a qr// regex.
94
95=head2 moniker_map
96
8f9d7ce5 97Overrides the default table name to moniker translation. Can be either
98a hashref of table keys and moniker values, or a coderef for a translator
996be9ee 99function taking a single scalar table name argument and returning
100a scalar moniker. If the hash entry does not exist, or the function
101returns a false value, the code falls back to default behavior
102for that table name.
103
104The default behavior is: C<join '', map ucfirst, split /[\W_]+/, lc $table>,
105which is to say: lowercase everything, split up the table name into chunks
106anywhere a non-alpha-numeric character occurs, change the case of first letter
107of each chunk to upper case, and put the chunks back together. Examples:
108
109 Table Name | Moniker Name
110 ---------------------------
111 luser | Luser
112 luser_group | LuserGroup
113 luser-opts | LuserOpts
114
115=head2 inflect_plural
116
117Just like L</moniker_map> above (can be hash/code-ref, falls back to default
118if hash key does not exist or coderef returns false), but acts as a map
119for pluralizing relationship names. The default behavior is to utilize
120L<Lingua::EN::Inflect::Number/to_PL>.
121
122=head2 inflect_singular
123
124As L</inflect_plural> above, but for singularizing relationship names.
125Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
126
9c9c2f2b 127=head2 schema_base_class
128
129Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
130
131=head2 result_base_class
132
133Base class for your table classes (aka result classes). Defaults to 'DBIx::Class'.
134
996be9ee 135=head2 additional_base_classes
136
137List of additional base classes all of your table classes will use.
138
139=head2 left_base_classes
140
141List of additional base classes all of your table classes will use
142that need to be leftmost.
143
144=head2 additional_classes
145
146List of additional classes which all of your table classes will use.
147
148=head2 components
149
150List of additional components to be loaded into all of your table
151classes. A good example would be C<ResultSetManager>.
152
153=head2 resultset_components
154
8f9d7ce5 155List of additional ResultSet components to be loaded into your table
996be9ee 156classes. A good example would be C<AlwaysRS>. Component
157C<ResultSetManager> will be automatically added to the above
158C<components> list if this option is set.
159
f44ecc2f 160=head2 use_namespaces
161
162Generate result class names suitable for
163L<DBIx::Class::Schema/load_namespaces> and call that instead of
164L<DBIx::Class::Schema/load_classes>. When using this option you can also
165specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
166C<resultset_namespace>, C<default_resultset_class>), and they will be added
167to the call (and the generated result class names adjusted appropriately).
168
996be9ee 169=head2 dump_directory
170
171This option is designed to be a tool to help you transition from this
172loader to a manually-defined schema when you decide it's time to do so.
173
174The value of this option is a perl libdir pathname. Within
175that directory this module will create a baseline manual
176L<DBIx::Class::Schema> module set, based on what it creates at runtime
177in memory.
178
179The created schema class will have the same classname as the one on
180which you are setting this option (and the ResultSource classes will be
7cab3ab7 181based on this name as well).
996be9ee 182
8f9d7ce5 183Normally you wouldn't hard-code this setting in your schema class, as it
996be9ee 184is meant for one-time manual usage.
185
186See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
187recommended way to access this functionality.
188
d65cda9e 189=head2 dump_overwrite
190
28b4691d 191Deprecated. See L</really_erase_my_files> below, which does *not* mean
192the same thing as the old C<dump_overwrite> setting from previous releases.
193
194=head2 really_erase_my_files
195
7cab3ab7 196Default false. If true, Loader will unconditionally delete any existing
197files before creating the new ones from scratch when dumping a schema to disk.
198
199The default behavior is instead to only replace the top portion of the
200file, up to and including the final stanza which contains
201C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
202leaving any customizations you placed after that as they were.
203
28b4691d 204When C<really_erase_my_files> is not set, if the output file already exists,
7cab3ab7 205but the aforementioned final stanza is not found, or the checksum
206contained there does not match the generated contents, Loader will
207croak and not touch the file.
d65cda9e 208
28b4691d 209You should really be using version control on your schema classes (and all
210of the rest of your code for that matter). Don't blame me if a bug in this
211code wipes something out when it shouldn't have, you've been warned.
212
996be9ee 213=head1 METHODS
214
215None of these methods are intended for direct invocation by regular
216users of L<DBIx::Class::Schema::Loader>. Anything you can find here
217can also be found via standard L<DBIx::Class::Schema> methods somehow.
218
219=cut
220
221# ensure that a peice of object data is a valid arrayref, creating
222# an empty one or encapsulating whatever's there.
223sub _ensure_arrayref {
224 my $self = shift;
225
226 foreach (@_) {
227 $self->{$_} ||= [];
228 $self->{$_} = [ $self->{$_} ]
229 unless ref $self->{$_} eq 'ARRAY';
230 }
231}
232
233=head2 new
234
235Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
236by L<DBIx::Class::Schema::Loader>.
237
238=cut
239
240sub new {
241 my ( $class, %args ) = @_;
242
243 my $self = { %args };
244
245 bless $self => $class;
246
996be9ee 247 $self->_ensure_arrayref(qw/additional_classes
248 additional_base_classes
249 left_base_classes
250 components
251 resultset_components
252 /);
253
254 push(@{$self->{components}}, 'ResultSetManager')
255 if @{$self->{resultset_components}};
256
257 $self->{monikers} = {};
258 $self->{classes} = {};
259
996be9ee 260 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
261 $self->{schema} ||= $self->{schema_class};
262
28b4691d 263 croak "dump_overwrite is deprecated. Please read the"
264 . " DBIx::Class::Schema::Loader::Base documentation"
265 if $self->{dump_overwrite};
266
af31090c 267 $self->{dynamic} = ! $self->{dump_directory};
79193756 268 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
af31090c 269 TMPDIR => 1,
270 CLEANUP => 1,
271 );
272
79193756 273 $self->{dump_directory} ||= $self->{temp_directory};
274
e8ad6491 275 $self->{relbuilder} = DBIx::Class::Schema::Loader::RelBuilder->new(
706ef173 276 $self->schema, $self->inflect_plural, $self->inflect_singular
e8ad6491 277 ) if !$self->{skip_relationships};
278
996be9ee 279 $self;
280}
281
419a2eeb 282sub _find_file_in_inc {
283 my ($self, $file) = @_;
284
285 foreach my $prefix (@INC) {
af31090c 286 my $fullpath = File::Spec->catfile($prefix, $file);
287 return $fullpath if -f $fullpath
288 and Cwd::abs_path($fullpath) ne
289 Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || '';
419a2eeb 290 }
291
292 return;
293}
294
996be9ee 295sub _load_external {
f96ef30f 296 my ($self, $class) = @_;
297
298 my $class_path = $class;
299 $class_path =~ s{::}{/}g;
300 $class_path .= '.pm';
301
af31090c 302 my $real_inc_path = $self->_find_file_in_inc($class_path);
f96ef30f 303
af31090c 304 return if !$real_inc_path;
f96ef30f 305
306 # If we make it to here, we loaded an external definition
307 warn qq/# Loaded external class definition for '$class'\n/
308 if $self->debug;
309
f96ef30f 310 croak 'Failed to locate actual external module file for '
311 . "'$class'"
312 if !$real_inc_path;
313 open(my $fh, '<', $real_inc_path)
314 or croak "Failed to open '$real_inc_path' for reading: $!";
315 $self->_ext_stmt($class,
565ca24d 316 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
317 .qq|# They are now part of the custom portion of this file\n|
318 .qq|# for you to hand-edit. If you do not either delete\n|
319 .qq|# this section or remove that file from \@INC, this section\n|
320 .qq|# will be repeated redundantly when you re-create this\n|
321 .qq|# file again via Loader!\n|
f96ef30f 322 );
323 while(<$fh>) {
324 chomp;
325 $self->_ext_stmt($class, $_);
996be9ee 326 }
f96ef30f 327 $self->_ext_stmt($class,
70b72fab 328 qq|# End of lines loaded from '$real_inc_path' |
f96ef30f 329 );
330 close($fh)
331 or croak "Failed to close $real_inc_path: $!";
996be9ee 332}
333
334=head2 load
335
336Does the actual schema-construction work.
337
338=cut
339
340sub load {
341 my $self = shift;
342
b97c2c1e 343 $self->_load_tables($self->_tables_list);
344}
345
346=head2 rescan
347
a60b5b8d 348Arguments: schema
349
b97c2c1e 350Rescan the database for newly added tables. Does
a60b5b8d 351not process drops or changes. Returns a list of
352the newly added table monikers.
353
354The schema argument should be the schema class
355or object to be affected. It should probably
356be derived from the original schema_class used
357during L</load>.
b97c2c1e 358
359=cut
360
361sub rescan {
a60b5b8d 362 my ($self, $schema) = @_;
363
364 $self->{schema} = $schema;
706ef173 365 $self->{relbuilder}{schema} = $schema;
b97c2c1e 366
367 my @created;
368 my @current = $self->_tables_list;
369 foreach my $table ($self->_tables_list) {
370 if(!exists $self->{_tables}->{$table}) {
371 push(@created, $table);
372 }
373 }
374
c39e3507 375 my $loaded = $self->_load_tables(@created);
a60b5b8d 376
c39e3507 377 return map { $self->monikers->{$_} } @$loaded;
b97c2c1e 378}
379
380sub _load_tables {
381 my ($self, @tables) = @_;
382
f96ef30f 383 # First, use _tables_list with constraint and exclude
384 # to get a list of tables to operate on
385
386 my $constraint = $self->constraint;
387 my $exclude = $self->exclude;
f96ef30f 388
b97c2c1e 389 @tables = grep { /$constraint/ } @tables if $constraint;
390 @tables = grep { ! /$exclude/ } @tables if $exclude;
f96ef30f 391
b97c2c1e 392 # Save the new tables to the tables list
a60b5b8d 393 foreach (@tables) {
394 $self->{_tables}->{$_} = 1;
395 }
f96ef30f 396
af31090c 397 $self->_make_src_class($_) for @tables;
f96ef30f 398 $self->_setup_src_meta($_) for @tables;
399
e8ad6491 400 if(!$self->skip_relationships) {
181cc907 401 # The relationship loader needs a working schema
af31090c 402 $self->{quiet} = 1;
79193756 403 local $self->{dump_directory} = $self->{temp_directory};
181cc907 404 $self->_reload_classes(@tables);
e8ad6491 405 $self->_load_relationships($_) for @tables;
af31090c 406 $self->{quiet} = 0;
79193756 407
408 # Remove that temp dir from INC so it doesn't get reloaded
409 @INC = grep { $_ ne $self->{dump_directory} } @INC;
e8ad6491 410 }
411
f96ef30f 412 $self->_load_external($_)
75451704 413 for map { $self->classes->{$_} } @tables;
f96ef30f 414
181cc907 415 $self->_reload_classes(@tables);
996be9ee 416
5223f24a 417 # Drop temporary cache
418 delete $self->{_cache};
419
c39e3507 420 return \@tables;
996be9ee 421}
422
af31090c 423sub _reload_classes {
181cc907 424 my ($self, @tables) = @_;
425
426 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
e9b8719e 427
428 unshift @INC, $self->dump_directory;
af31090c 429
706ef173 430 my @to_register;
431 my %have_source = map { $_ => $self->schema->source($_) }
432 $self->schema->sources;
433
181cc907 434 for my $table (@tables) {
435 my $moniker = $self->monikers->{$table};
436 my $class = $self->classes->{$table};
0ae6b65d 437
438 {
439 no warnings 'redefine';
440 local *Class::C3::reinitialize = sub {};
441 use warnings;
442
706ef173 443 Class::Unload->unload($class);
444 my ($source, $resultset_class);
445 if (
446 ($source = $have_source{$moniker})
447 && ($resultset_class = $source->resultset_class)
448 && ($resultset_class ne 'DBIx::Class::ResultSet')
449 ) {
450 my $has_file = Class::Inspector->loaded_filename($resultset_class);
451 Class::Unload->unload($resultset_class);
6ae3f335 452 $self->ensure_class_loaded($resultset_class) if $has_file;
0ae6b65d 453 }
6ae3f335 454 $self->ensure_class_loaded($class);
af31090c 455 }
706ef173 456 push @to_register, [$moniker, $class];
457 }
af31090c 458
706ef173 459 Class::C3->reinitialize;
460 for (@to_register) {
461 $self->schema->register_class(@$_);
af31090c 462 }
463}
464
996be9ee 465sub _get_dump_filename {
466 my ($self, $class) = (@_);
467
468 $class =~ s{::}{/}g;
469 return $self->dump_directory . q{/} . $class . q{.pm};
470}
471
472sub _ensure_dump_subdirs {
473 my ($self, $class) = (@_);
474
475 my @name_parts = split(/::/, $class);
dd03ee1a 476 pop @name_parts; # we don't care about the very last element,
477 # which is a filename
478
996be9ee 479 my $dir = $self->dump_directory;
7cab3ab7 480 while (1) {
481 if(!-d $dir) {
25328cc4 482 mkdir($dir) or croak "mkdir('$dir') failed: $!";
996be9ee 483 }
7cab3ab7 484 last if !@name_parts;
485 $dir = File::Spec->catdir($dir, shift @name_parts);
996be9ee 486 }
487}
488
489sub _dump_to_dir {
af31090c 490 my ($self, @classes) = @_;
996be9ee 491
fc2b71fd 492 my $schema_class = $self->schema_class;
9c9c2f2b 493 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
996be9ee 494
e9b8719e 495 my $target_dir = $self->dump_directory;
af31090c 496 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
497 unless $self->{dynamic} or $self->{quiet};
996be9ee 498
7cab3ab7 499 my $schema_text =
500 qq|package $schema_class;\n\n|
501 . qq|use strict;\nuse warnings;\n\n|
9c9c2f2b 502 . qq|use base '$schema_base_class';\n\n|;
f44ecc2f 503
f44ecc2f 504 if ($self->use_namespaces) {
505 $schema_text .= qq|__PACKAGE__->load_namespaces|;
506 my $namespace_options;
507 for my $attr (qw(result_namespace
508 resultset_namespace
509 default_resultset_class)) {
510 if ($self->$attr) {
511 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
512 }
513 }
514 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
515 $schema_text .= qq|;\n|;
516 }
517 else {
518 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
f44ecc2f 519 }
996be9ee 520
7cab3ab7 521 $self->_write_classfile($schema_class, $schema_text);
996be9ee 522
9c9c2f2b 523 my $result_base_class = $self->result_base_class || 'DBIx::Class';
524
af31090c 525 foreach my $src_class (@classes) {
7cab3ab7 526 my $src_text =
527 qq|package $src_class;\n\n|
528 . qq|use strict;\nuse warnings;\n\n|
9c9c2f2b 529 . qq|use base '$result_base_class';\n\n|;
996be9ee 530
7cab3ab7 531 $self->_write_classfile($src_class, $src_text);
02356864 532 }
996be9ee 533
af31090c 534 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
535
7cab3ab7 536}
537
79193756 538sub _sig_comment {
539 my ($self, $version, $ts) = @_;
540 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
541 . qq| v| . $version
542 . q| @ | . $ts
543 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
544}
545
7cab3ab7 546sub _write_classfile {
547 my ($self, $class, $text) = @_;
548
549 my $filename = $self->_get_dump_filename($class);
550 $self->_ensure_dump_subdirs($class);
551
28b4691d 552 if (-f $filename && $self->really_erase_my_files) {
7cab3ab7 553 warn "Deleting existing file '$filename' due to "
af31090c 554 . "'really_erase_my_files' setting\n" unless $self->{quiet};
7cab3ab7 555 unlink($filename);
556 }
557
79193756 558 my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
17ca645f 559
7cab3ab7 560 $text .= qq|$_\n|
561 for @{$self->{_dump_storage}->{$class} || []};
562
79193756 563 # Check and see if the dump is infact differnt
564
565 my $compare_to;
566 if ($old_md5) {
567 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
568
569
570 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
571 return;
572 }
573 }
574
575 $text .= $self->_sig_comment(
576 $DBIx::Class::Schema::Loader::VERSION,
577 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
578 );
7cab3ab7 579
580 open(my $fh, '>', $filename)
581 or croak "Cannot open '$filename' for writing: $!";
582
583 # Write the top half and its MD5 sum
a4476f41 584 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
7cab3ab7 585
586 # Write out anything loaded via external partial class file in @INC
587 print $fh qq|$_\n|
588 for @{$self->{_ext_storage}->{$class} || []};
589
1eea4fb1 590 # Write out any custom content the user has added
7cab3ab7 591 print $fh $custom_content;
592
593 close($fh)
e9b8719e 594 or croak "Error closing '$filename': $!";
7cab3ab7 595}
596
79193756 597sub _default_custom_content {
598 return qq|\n\n# You can replace this text with custom|
599 . qq| content, and it will be preserved on regeneration|
600 . qq|\n1;\n|;
601}
602
7cab3ab7 603sub _get_custom_content {
604 my ($self, $class, $filename) = @_;
605
79193756 606 return ($self->_default_custom_content) if ! -f $filename;
607
7cab3ab7 608 open(my $fh, '<', $filename)
609 or croak "Cannot open '$filename' for reading: $!";
610
611 my $mark_re =
419a2eeb 612 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
7cab3ab7 613
7cab3ab7 614 my $buffer = '';
79193756 615 my ($md5, $ts, $ver);
7cab3ab7 616 while(<$fh>) {
79193756 617 if(!$md5 && /$mark_re/) {
618 $md5 = $2;
619 my $line = $1;
620
621 # Pull out the previous version and timestamp
622 ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
623
624 $buffer .= $line;
7cab3ab7 625 croak "Checksum mismatch in '$filename'"
79193756 626 if Digest::MD5::md5_base64($buffer) ne $md5;
7cab3ab7 627
628 $buffer = '';
629 }
630 else {
631 $buffer .= $_;
632 }
996be9ee 633 }
634
28b4691d 635 croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
419a2eeb 636 . " it does not appear to have been generated by Loader"
79193756 637 if !$md5;
638
639 # Default custom content:
640 $buffer ||= $self->_default_custom_content;
5ef3c771 641
79193756 642 return ($buffer, $md5, $ver, $ts);
996be9ee 643}
644
645sub _use {
646 my $self = shift;
647 my $target = shift;
648
649 foreach (@_) {
cb54990b 650 warn "$target: use $_;" if $self->debug;
996be9ee 651 $self->_raw_stmt($target, "use $_;");
996be9ee 652 }
653}
654
655sub _inject {
656 my $self = shift;
657 my $target = shift;
658 my $schema_class = $self->schema_class;
659
af31090c 660 my $blist = join(q{ }, @_);
661 warn "$target: use base qw/ $blist /;" if $self->debug && @_;
662 $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
996be9ee 663}
664
f96ef30f 665# Create class with applicable bases, setup monikers, etc
666sub _make_src_class {
667 my ($self, $table) = @_;
996be9ee 668
a13b2803 669 my $schema = $self->schema;
670 my $schema_class = $self->schema_class;
996be9ee 671
f96ef30f 672 my $table_moniker = $self->_table2moniker($table);
f44ecc2f 673 my @result_namespace = ($schema_class);
674 if ($self->use_namespaces) {
675 my $result_namespace = $self->result_namespace || 'Result';
676 if ($result_namespace =~ /^\+(.*)/) {
677 # Fully qualified namespace
678 @result_namespace = ($1)
679 }
680 else {
681 # Relative namespace
682 push @result_namespace, $result_namespace;
683 }
684 }
685 my $table_class = join(q{::}, @result_namespace, $table_moniker);
996be9ee 686
f96ef30f 687 my $table_normalized = lc $table;
688 $self->classes->{$table} = $table_class;
689 $self->classes->{$table_normalized} = $table_class;
690 $self->monikers->{$table} = $table_moniker;
691 $self->monikers->{$table_normalized} = $table_moniker;
996be9ee 692
f96ef30f 693 $self->_use ($table_class, @{$self->additional_classes});
af31090c 694 $self->_inject($table_class, @{$self->left_base_classes});
996be9ee 695
605fcea8 696 $self->_dbic_stmt($table_class, 'load_components', @{$self->components}, 'Core');
996be9ee 697
f96ef30f 698 $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
699 if @{$self->resultset_components};
af31090c 700 $self->_inject($table_class, @{$self->additional_base_classes});
f96ef30f 701}
996be9ee 702
af31090c 703# Set up metadata (cols, pks, etc)
f96ef30f 704sub _setup_src_meta {
705 my ($self, $table) = @_;
996be9ee 706
f96ef30f 707 my $schema = $self->schema;
708 my $schema_class = $self->schema_class;
a13b2803 709
f96ef30f 710 my $table_class = $self->classes->{$table};
711 my $table_moniker = $self->monikers->{$table};
996be9ee 712
ff30991a 713 my $table_name = $table;
714 my $name_sep = $self->schema->storage->sql_maker->name_sep;
715
c177d483 716 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
ff30991a 717 $table_name = \ $self->_quote_table_name($table_name);
718 }
719
720 $self->_dbic_stmt($table_class,'table',$table_name);
996be9ee 721
f96ef30f 722 my $cols = $self->_table_columns($table);
723 my $col_info;
724 eval { $col_info = $self->_columns_info_for($table) };
725 if($@) {
726 $self->_dbic_stmt($table_class,'add_columns',@$cols);
727 }
728 else {
0906d55b 729 if ($self->_is_case_sensitive) {
730 for my $col (keys %$col_info) {
731 $col_info->{$col}{accessor} = lc $col
732 if $col ne lc($col);
733 }
734 } else {
735 $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
c9373b79 736 }
737
e7213f4f 738 my $fks = $self->_table_fk_info($table);
565335e6 739
e7213f4f 740 for my $fkdef (@$fks) {
741 for my $col (@{ $fkdef->{local_columns} }) {
565335e6 742 $col_info->{$col}{is_foreign_key} = 1;
e7213f4f 743 }
744 }
f96ef30f 745 $self->_dbic_stmt(
746 $table_class,
747 'add_columns',
565335e6 748 map { $_, ($col_info->{$_}||{}) } @$cols
f96ef30f 749 );
996be9ee 750 }
751
d70c335f 752 my %uniq_tag; # used to eliminate duplicate uniqs
753
f96ef30f 754 my $pks = $self->_table_pk_info($table) || [];
755 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
756 : carp("$table has no primary key");
d70c335f 757 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
996be9ee 758
f96ef30f 759 my $uniqs = $self->_table_uniq_info($table) || [];
d70c335f 760 for (@$uniqs) {
761 my ($name, $cols) = @$_;
762 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
763 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
764 }
765
996be9ee 766}
767
768=head2 tables
769
770Returns a sorted list of loaded tables, using the original database table
771names.
772
773=cut
774
775sub tables {
776 my $self = shift;
777
b97c2c1e 778 return keys %{$self->_tables};
996be9ee 779}
780
781# Make a moniker from a table
c39e403e 782sub _default_table2moniker {
783 my ($self, $table) = @_;
784
785 return join '', map ucfirst, split /[\W_]+/,
786 Lingua::EN::Inflect::Number::to_S(lc $table);
787}
788
996be9ee 789sub _table2moniker {
790 my ( $self, $table ) = @_;
791
792 my $moniker;
793
794 if( ref $self->moniker_map eq 'HASH' ) {
795 $moniker = $self->moniker_map->{$table};
796 }
797 elsif( ref $self->moniker_map eq 'CODE' ) {
798 $moniker = $self->moniker_map->($table);
799 }
800
c39e403e 801 $moniker ||= $self->_default_table2moniker($table);
996be9ee 802
803 return $moniker;
804}
805
806sub _load_relationships {
e8ad6491 807 my ($self, $table) = @_;
996be9ee 808
e8ad6491 809 my $tbl_fk_info = $self->_table_fk_info($table);
810 foreach my $fkdef (@$tbl_fk_info) {
811 $fkdef->{remote_source} =
812 $self->monikers->{delete $fkdef->{remote_table}};
996be9ee 813 }
26f1c8c9 814 my $tbl_uniq_info = $self->_table_uniq_info($table);
996be9ee 815
e8ad6491 816 my $local_moniker = $self->monikers->{$table};
26f1c8c9 817 my $rel_stmts = $self->{relbuilder}->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
996be9ee 818
996be9ee 819 foreach my $src_class (sort keys %$rel_stmts) {
820 my $src_stmts = $rel_stmts->{$src_class};
821 foreach my $stmt (@$src_stmts) {
822 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
823 }
824 }
825}
826
827# Overload these in driver class:
828
829# Returns an arrayref of column names
830sub _table_columns { croak "ABSTRACT METHOD" }
831
832# Returns arrayref of pk col names
833sub _table_pk_info { croak "ABSTRACT METHOD" }
834
835# Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
836sub _table_uniq_info { croak "ABSTRACT METHOD" }
837
838# Returns an arrayref of foreign key constraints, each
839# being a hashref with 3 keys:
840# local_columns (arrayref), remote_columns (arrayref), remote_table
841sub _table_fk_info { croak "ABSTRACT METHOD" }
842
843# Returns an array of lower case table names
844sub _tables_list { croak "ABSTRACT METHOD" }
845
846# Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
847sub _dbic_stmt {
848 my $self = shift;
849 my $class = shift;
850 my $method = shift;
851
996be9ee 852 my $args = dump(@_);
853 $args = '(' . $args . ')' if @_ < 2;
854 my $stmt = $method . $args . q{;};
855
856 warn qq|$class\->$stmt\n| if $self->debug;
996be9ee 857 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
858}
859
860# Store a raw source line for a class (for dumping purposes)
861sub _raw_stmt {
862 my ($self, $class, $stmt) = @_;
af31090c 863 push(@{$self->{_dump_storage}->{$class}}, $stmt);
996be9ee 864}
865
7cab3ab7 866# Like above, but separately for the externally loaded stuff
867sub _ext_stmt {
868 my ($self, $class, $stmt) = @_;
af31090c 869 push(@{$self->{_ext_storage}->{$class}}, $stmt);
7cab3ab7 870}
871
565335e6 872sub _quote_table_name {
873 my ($self, $table) = @_;
874
875 my $qt = $self->schema->storage->sql_maker->quote_char;
876
c177d483 877 return $table unless $qt;
878
565335e6 879 if (ref $qt) {
880 return $qt->[0] . $table . $qt->[1];
881 }
882
883 return $qt . $table . $qt;
884}
885
886sub _is_case_sensitive { 0 }
887
996be9ee 888=head2 monikers
889
8f9d7ce5 890Returns a hashref of loaded table to moniker mappings. There will
996be9ee 891be two entries for each table, the original name and the "normalized"
892name, in the case that the two are different (such as databases
893that like uppercase table names, or preserve your original mixed-case
894definitions, or what-have-you).
895
896=head2 classes
897
8f9d7ce5 898Returns a hashref of table to class mappings. In some cases it will
996be9ee 899contain multiple entries per table for the original and normalized table
900names, as above in L</monikers>.
901
902=head1 SEE ALSO
903
904L<DBIx::Class::Schema::Loader>
905
906=cut
907
9081;