5d146ec104b5c60a2835fc660d036dcce88f1502
[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->{relbuilder} = DBIx::Class::Schema::Loader::RelBuilder->new(
276         $self->schema, $self->inflect_plural, $self->inflect_singular
277     ) if !$self->{skip_relationships};
278
279     $self;
280 }
281
282 sub _find_file_in_inc {
283     my ($self, $file) = @_;
284
285     foreach my $prefix (@INC) {
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)) || '';
290     }
291
292     return;
293 }
294
295 sub _load_external {
296     my ($self, $class) = @_;
297
298     my $class_path = $class;
299     $class_path =~ s{::}{/}g;
300     $class_path .= '.pm';
301
302     my $real_inc_path = $self->_find_file_in_inc($class_path);
303
304     return if !$real_inc_path;
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
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,
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|
322     );
323     while(<$fh>) {
324         chomp;
325         $self->_ext_stmt($class, $_);
326     }
327     $self->_ext_stmt($class,
328         qq|# End of lines loaded from '$real_inc_path' |
329     );
330     close($fh)
331         or croak "Failed to close $real_inc_path: $!";
332 }
333
334 =head2 load
335
336 Does the actual schema-construction work.
337
338 =cut
339
340 sub load {
341     my $self = shift;
342
343     $self->_load_tables($self->_tables_list);
344 }
345
346 =head2 rescan
347
348 Arguments: schema
349
350 Rescan the database for newly added tables.  Does
351 not process drops or changes.  Returns a list of
352 the newly added table monikers.
353
354 The schema argument should be the schema class
355 or object to be affected.  It should probably
356 be derived from the original schema_class used
357 during L</load>.
358
359 =cut
360
361 sub rescan {
362     my ($self, $schema) = @_;
363
364     $self->{schema} = $schema;
365     $self->{relbuilder}{schema} = $schema;
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
375     my $loaded = $self->_load_tables(@created);
376
377     return map { $self->monikers->{$_} } @$loaded;
378 }
379
380 sub _load_tables {
381     my ($self, @tables) = @_;
382
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;
388
389     @tables = grep { /$constraint/ } @tables if $constraint;
390     @tables = grep { ! /$exclude/ } @tables if $exclude;
391
392     # Save the new tables to the tables list
393     foreach (@tables) {
394         $self->{_tables}->{$_} = 1;
395     }
396
397     $self->_make_src_class($_) for @tables;
398     $self->_setup_src_meta($_) for @tables;
399
400     if(!$self->skip_relationships) {
401         # The relationship loader needs a working schema
402         $self->{quiet} = 1;
403         local $self->{dump_directory} = $self->{temp_directory};
404         $self->_reload_classes(@tables);
405         $self->_load_relationships($_) for @tables;
406         $self->{quiet} = 0;
407
408         # Remove that temp dir from INC so it doesn't get reloaded
409         @INC = grep { $_ ne $self->{dump_directory} } @INC;
410     }
411
412     $self->_load_external($_)
413         for map { $self->classes->{$_} } @tables;
414
415     $self->_reload_classes(@tables);
416
417     # Drop temporary cache
418     delete $self->{_cache};
419
420     return \@tables;
421 }
422
423 sub _reload_classes {
424     my ($self, @tables) = @_;
425
426     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
427
428     unshift @INC, $self->dump_directory;
429     
430     my @to_register;
431     my %have_source = map { $_ => $self->schema->source($_) }
432         $self->schema->sources;
433
434     for my $table (@tables) {
435         my $moniker = $self->monikers->{$table};
436         my $class = $self->classes->{$table};
437         
438         {
439             no warnings 'redefine';
440             local *Class::C3::reinitialize = sub {};
441             use warnings;
442
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);
452                 $self->ensure_class_loaded($resultset_class) if $has_file;
453             }
454             $self->ensure_class_loaded($class);
455         }
456         push @to_register, [$moniker, $class];
457     }
458
459     Class::C3->reinitialize;
460     for (@to_register) {
461         $self->schema->register_class(@$_);
462     }
463 }
464
465 sub _get_dump_filename {
466     my ($self, $class) = (@_);
467
468     $class =~ s{::}{/}g;
469     return $self->dump_directory . q{/} . $class . q{.pm};
470 }
471
472 sub _ensure_dump_subdirs {
473     my ($self, $class) = (@_);
474
475     my @name_parts = split(/::/, $class);
476     pop @name_parts; # we don't care about the very last element,
477                      # which is a filename
478
479     my $dir = $self->dump_directory;
480     while (1) {
481         if(!-d $dir) {
482             mkdir($dir) or croak "mkdir('$dir') failed: $!";
483         }
484         last if !@name_parts;
485         $dir = File::Spec->catdir($dir, shift @name_parts);
486     }
487 }
488
489 sub _dump_to_dir {
490     my ($self, @classes) = @_;
491
492     my $schema_class = $self->schema_class;
493     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
494
495     my $target_dir = $self->dump_directory;
496     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
497         unless $self->{dynamic} or $self->{quiet};
498
499     my $schema_text =
500           qq|package $schema_class;\n\n|
501         . qq|# Created by DBIx::Class::Schema::Loader\n|
502         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
503         . qq|use strict;\nuse warnings;\n\n|
504         . qq|use base '$schema_base_class';\n\n|;
505
506     if ($self->use_namespaces) {
507         $schema_text .= qq|__PACKAGE__->load_namespaces|;
508         my $namespace_options;
509         for my $attr (qw(result_namespace
510                          resultset_namespace
511                          default_resultset_class)) {
512             if ($self->$attr) {
513                 $namespace_options .= qq|    $attr => '| . $self->$attr . qq|',\n|
514             }
515         }
516         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
517         $schema_text .= qq|;\n|;
518     }
519     else {
520         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
521     }
522
523     $self->_write_classfile($schema_class, $schema_text);
524
525     my $result_base_class = $self->result_base_class || 'DBIx::Class';
526
527     foreach my $src_class (@classes) {
528         my $src_text = 
529               qq|package $src_class;\n\n|
530             . qq|# Created by DBIx::Class::Schema::Loader\n|
531             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
532             . qq|use strict;\nuse warnings;\n\n|
533             . qq|use base '$result_base_class';\n\n|;
534
535         $self->_write_classfile($src_class, $src_text);
536     }
537
538     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
539
540 }
541
542 sub _sig_comment {
543     my ($self, $version, $ts) = @_;
544     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
545          . qq| v| . $version
546          . q| @ | . $ts 
547          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
548 }
549
550 sub _write_classfile {
551     my ($self, $class, $text) = @_;
552
553     my $filename = $self->_get_dump_filename($class);
554     $self->_ensure_dump_subdirs($class);
555
556     if (-f $filename && $self->really_erase_my_files) {
557         warn "Deleting existing file '$filename' due to "
558             . "'really_erase_my_files' setting\n" unless $self->{quiet};
559         unlink($filename);
560     }    
561
562     my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
563
564     $text .= qq|$_\n|
565         for @{$self->{_dump_storage}->{$class} || []};
566
567     # Check and see if the dump is infact differnt
568
569     my $compare_to;
570     if ($old_md5) {
571       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
572       
573
574       if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
575         return;
576       }
577     }
578
579     $text .= $self->_sig_comment(
580       $DBIx::Class::Schema::Loader::VERSION, 
581       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
582     );
583
584     open(my $fh, '>', $filename)
585         or croak "Cannot open '$filename' for writing: $!";
586
587     # Write the top half and its MD5 sum
588     print $fh $text . Digest::MD5::md5_base64($text) . "\n";
589
590     # Write out anything loaded via external partial class file in @INC
591     print $fh qq|$_\n|
592         for @{$self->{_ext_storage}->{$class} || []};
593
594     # Write out any custom content the user has added
595     print $fh $custom_content;
596
597     close($fh)
598         or croak "Error closing '$filename': $!";
599 }
600
601 sub _default_custom_content {
602     return qq|\n\n# You can replace this text with custom|
603          . qq| content, and it will be preserved on regeneration|
604          . qq|\n1;\n|;
605 }
606
607 sub _get_custom_content {
608     my ($self, $class, $filename) = @_;
609
610     return ($self->_default_custom_content) if ! -f $filename;
611
612     open(my $fh, '<', $filename)
613         or croak "Cannot open '$filename' for reading: $!";
614
615     my $mark_re = 
616         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
617
618     my $buffer = '';
619     my ($md5, $ts, $ver);
620     while(<$fh>) {
621         if(!$md5 && /$mark_re/) {
622             $md5 = $2;
623             my $line = $1;
624
625             # Pull out the previous version and timestamp
626             ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
627
628             $buffer .= $line;
629             croak "Checksum mismatch in '$filename'"
630                 if Digest::MD5::md5_base64($buffer) ne $md5;
631
632             $buffer = '';
633         }
634         else {
635             $buffer .= $_;
636         }
637     }
638
639     croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
640         . " it does not appear to have been generated by Loader"
641             if !$md5;
642
643     # Default custom content:
644     $buffer ||= $self->_default_custom_content;
645
646     return ($buffer, $md5, $ver, $ts);
647 }
648
649 sub _use {
650     my $self = shift;
651     my $target = shift;
652
653     foreach (@_) {
654         warn "$target: use $_;" if $self->debug;
655         $self->_raw_stmt($target, "use $_;");
656     }
657 }
658
659 sub _inject {
660     my $self = shift;
661     my $target = shift;
662     my $schema_class = $self->schema_class;
663
664     my $blist = join(q{ }, @_);
665     warn "$target: use base qw/ $blist /;" if $self->debug && @_;
666     $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
667 }
668
669 # Create class with applicable bases, setup monikers, etc
670 sub _make_src_class {
671     my ($self, $table) = @_;
672
673     my $schema       = $self->schema;
674     my $schema_class = $self->schema_class;
675
676     my $table_moniker = $self->_table2moniker($table);
677     my @result_namespace = ($schema_class);
678     if ($self->use_namespaces) {
679         my $result_namespace = $self->result_namespace || 'Result';
680         if ($result_namespace =~ /^\+(.*)/) {
681             # Fully qualified namespace
682             @result_namespace =  ($1)
683         }
684         else {
685             # Relative namespace
686             push @result_namespace, $result_namespace;
687         }
688     }
689     my $table_class = join(q{::}, @result_namespace, $table_moniker);
690
691     my $table_normalized = lc $table;
692     $self->classes->{$table} = $table_class;
693     $self->classes->{$table_normalized} = $table_class;
694     $self->monikers->{$table} = $table_moniker;
695     $self->monikers->{$table_normalized} = $table_moniker;
696
697     $self->_use   ($table_class, @{$self->additional_classes});
698     $self->_inject($table_class, @{$self->left_base_classes});
699
700     $self->_dbic_stmt($table_class, 'load_components', @{$self->components}, 'Core');
701
702     $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
703         if @{$self->resultset_components};
704     $self->_inject($table_class, @{$self->additional_base_classes});
705 }
706
707 # Set up metadata (cols, pks, etc)
708 sub _setup_src_meta {
709     my ($self, $table) = @_;
710
711     my $schema       = $self->schema;
712     my $schema_class = $self->schema_class;
713
714     my $table_class = $self->classes->{$table};
715     my $table_moniker = $self->monikers->{$table};
716
717     my $table_name = $table;
718     my $name_sep   = $self->schema->storage->sql_maker->name_sep;
719
720     if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
721         $table_name = \ $self->_quote_table_name($table_name);
722     }
723
724     $self->_dbic_stmt($table_class,'table',$table_name);
725
726     my $cols = $self->_table_columns($table);
727     my $col_info;
728     eval { $col_info = $self->_columns_info_for($table) };
729     if($@) {
730         $self->_dbic_stmt($table_class,'add_columns',@$cols);
731     }
732     else {
733         if ($self->_is_case_sensitive) {
734             for my $col (keys %$col_info) {
735                 $col_info->{$col}{accessor} = lc $col
736                     if $col ne lc($col);
737             }
738         } else {
739             $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
740         }
741
742         my $fks = $self->_table_fk_info($table);
743
744         for my $fkdef (@$fks) {
745             for my $col (@{ $fkdef->{local_columns} }) {
746                 $col_info->{$col}{is_foreign_key} = 1;
747             }
748         }
749         $self->_dbic_stmt(
750             $table_class,
751             'add_columns',
752             map { $_, ($col_info->{$_}||{}) } @$cols
753         );
754     }
755
756     my %uniq_tag; # used to eliminate duplicate uniqs
757
758     my $pks = $self->_table_pk_info($table) || [];
759     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
760           : carp("$table has no primary key");
761     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
762
763     my $uniqs = $self->_table_uniq_info($table) || [];
764     for (@$uniqs) {
765         my ($name, $cols) = @$_;
766         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
767         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
768     }
769
770 }
771
772 =head2 tables
773
774 Returns a sorted list of loaded tables, using the original database table
775 names.
776
777 =cut
778
779 sub tables {
780     my $self = shift;
781
782     return keys %{$self->_tables};
783 }
784
785 # Make a moniker from a table
786 sub _default_table2moniker {
787     my ($self, $table) = @_;
788
789     return join '', map ucfirst, split /[\W_]+/,
790         Lingua::EN::Inflect::Number::to_S(lc $table);
791 }
792
793 sub _table2moniker {
794     my ( $self, $table ) = @_;
795
796     my $moniker;
797
798     if( ref $self->moniker_map eq 'HASH' ) {
799         $moniker = $self->moniker_map->{$table};
800     }
801     elsif( ref $self->moniker_map eq 'CODE' ) {
802         $moniker = $self->moniker_map->($table);
803     }
804
805     $moniker ||= $self->_default_table2moniker($table);
806
807     return $moniker;
808 }
809
810 sub _load_relationships {
811     my ($self, $table) = @_;
812
813     my $tbl_fk_info = $self->_table_fk_info($table);
814     foreach my $fkdef (@$tbl_fk_info) {
815         $fkdef->{remote_source} =
816             $self->monikers->{delete $fkdef->{remote_table}};
817     }
818     my $tbl_uniq_info = $self->_table_uniq_info($table);
819
820     my $local_moniker = $self->monikers->{$table};
821     my $rel_stmts = $self->{relbuilder}->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
822
823     foreach my $src_class (sort keys %$rel_stmts) {
824         my $src_stmts = $rel_stmts->{$src_class};
825         foreach my $stmt (@$src_stmts) {
826             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
827         }
828     }
829 }
830
831 # Overload these in driver class:
832
833 # Returns an arrayref of column names
834 sub _table_columns { croak "ABSTRACT METHOD" }
835
836 # Returns arrayref of pk col names
837 sub _table_pk_info { croak "ABSTRACT METHOD" }
838
839 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
840 sub _table_uniq_info { croak "ABSTRACT METHOD" }
841
842 # Returns an arrayref of foreign key constraints, each
843 #   being a hashref with 3 keys:
844 #   local_columns (arrayref), remote_columns (arrayref), remote_table
845 sub _table_fk_info { croak "ABSTRACT METHOD" }
846
847 # Returns an array of lower case table names
848 sub _tables_list { croak "ABSTRACT METHOD" }
849
850 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
851 sub _dbic_stmt {
852     my $self = shift;
853     my $class = shift;
854     my $method = shift;
855
856     my $args = dump(@_);
857     $args = '(' . $args . ')' if @_ < 2;
858     my $stmt = $method . $args . q{;};
859
860     warn qq|$class\->$stmt\n| if $self->debug;
861     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
862 }
863
864 # Store a raw source line for a class (for dumping purposes)
865 sub _raw_stmt {
866     my ($self, $class, $stmt) = @_;
867     push(@{$self->{_dump_storage}->{$class}}, $stmt);
868 }
869
870 # Like above, but separately for the externally loaded stuff
871 sub _ext_stmt {
872     my ($self, $class, $stmt) = @_;
873     push(@{$self->{_ext_storage}->{$class}}, $stmt);
874 }
875
876 sub _quote_table_name {
877     my ($self, $table) = @_;
878
879     my $qt = $self->schema->storage->sql_maker->quote_char;
880
881     return $table unless $qt;
882
883     if (ref $qt) {
884         return $qt->[0] . $table . $qt->[1];
885     }
886
887     return $qt . $table . $qt;
888 }
889
890 sub _is_case_sensitive { 0 }
891
892 =head2 monikers
893
894 Returns a hashref of loaded table to moniker mappings.  There will
895 be two entries for each table, the original name and the "normalized"
896 name, in the case that the two are different (such as databases
897 that like uppercase table names, or preserve your original mixed-case
898 definitions, or what-have-you).
899
900 =head2 classes
901
902 Returns a hashref of table to class mappings.  In some cases it will
903 contain multiple entries per table for the original and normalized table
904 names, as above in L</monikers>.
905
906 =head1 SEE ALSO
907
908 L<DBIx::Class::Schema::Loader>
909
910 =head1 AUTHOR
911
912 See L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
913
914 =head1 LICENSE
915
916 This library is free software; you can redistribute it and/or modify it under
917 the same terms as Perl itself.
918
919 =cut
920
921 1;