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