5403cc241bf2abefbef4597efaef05c5edfc3d26
[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_12';
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                                 dynamic
52                                 naming
53                                 _upgrading_from
54                              /);
55
56 __PACKAGE__->mk_accessors(qw/
57                                 version_to_dump
58                                 schema_version_to_dump
59 /);
60
61 =head1 NAME
62
63 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
64
65 =head1 SYNOPSIS
66
67 See L<DBIx::Class::Schema::Loader>
68
69 =head1 DESCRIPTION
70
71 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
72 classes, and implements the common functionality between them.
73
74 =head1 CONSTRUCTOR OPTIONS
75
76 These constructor options are the base options for
77 L<DBIx::Class::Schema::Loader/loader_options>.  Available constructor options are:
78
79 =head2 skip_relationships
80
81 Skip setting up relationships.  The default is to attempt the loading
82 of relationships.
83
84 =head2 naming
85
86 Static schemas (ones dumped to disk) will, by default, use the new-style 0.05XXX
87 relationship names and singularized Results, unless you're overwriting an
88 existing dump made by a 0.04XXX version of L<DBIx::Class::Schema::Loader>, in
89 which case the backward compatible RelBuilder will be activated, and
90 singularization will be turned off.
91
92 Specifying
93
94     naming => 'v5'
95
96 will disable the backward-compatible RelBuilder and use
97 the new-style relationship names along with singularized Results, even when
98 overwriting a dump made with an earlier version.
99
100 The option also takes a hashref:
101
102     naming => { relationships => 'v5', monikers => 'v4' }
103
104 The keys are:
105
106 =over 4
107
108 =item relationships
109
110 How to name relationship accessors.
111
112 =item monikers
113
114 How to name Result classes.
115
116 =back
117
118 The values can be:
119
120 =over 4
121
122 =item current
123
124 Latest default style, whatever that happens to be.
125
126 =item v5
127
128 Version 0.05XXX style.
129
130 =item v4
131
132 Version 0.04XXX style.
133
134 =back
135
136 Dynamic schemas will always default to the 0.04XXX relationship names and won't
137 singularize Results for backward compatibility, to activate the new RelBuilder
138 and singularization put this in your C<Schema.pm> file:
139
140     __PACKAGE__->naming('current');
141
142 Or if you prefer to use 0.05XXX features but insure that nothing breaks in the
143 next major version upgrade:
144
145     __PACKAGE__->naming('v5');
146
147 =head2 debug
148
149 If set to true, each constructive L<DBIx::Class> statement the loader
150 decides to execute will be C<warn>-ed before execution.
151
152 =head2 db_schema
153
154 Set the name of the schema to load (schema in the sense that your database
155 vendor means it).  Does not currently support loading more than one schema
156 name.
157
158 =head2 constraint
159
160 Only load tables matching regex.  Best specified as a qr// regex.
161
162 =head2 exclude
163
164 Exclude tables matching regex.  Best specified as a qr// regex.
165
166 =head2 moniker_map
167
168 Overrides the default table name to moniker translation.  Can be either
169 a hashref of table keys and moniker values, or a coderef for a translator
170 function taking a single scalar table name argument and returning
171 a scalar moniker.  If the hash entry does not exist, or the function
172 returns a false value, the code falls back to default behavior
173 for that table name.
174
175 The default behavior is to singularize the table name, and: C<join '', map
176 ucfirst, split /[\W_]+/, lc $table>, which is to say: lowercase everything,
177 split up the table name into chunks anywhere a non-alpha-numeric character
178 occurs, change the case of first letter of each chunk to upper case, and put
179 the chunks back together.  Examples:
180
181     Table Name  | Moniker Name
182     ---------------------------
183     luser       | Luser
184     luser_group | LuserGroup
185     luser-opts  | LuserOpts
186
187 =head2 inflect_plural
188
189 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
190 if hash key does not exist or coderef returns false), but acts as a map
191 for pluralizing relationship names.  The default behavior is to utilize
192 L<Lingua::EN::Inflect::Number/to_PL>.
193
194 =head2 inflect_singular
195
196 As L</inflect_plural> above, but for singularizing relationship names.
197 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
198
199 =head2 schema_base_class
200
201 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
202
203 =head2 result_base_class
204
205 Base class for your table classes (aka result classes). Defaults to
206 'DBIx::Class::Core'.
207
208 =head2 additional_base_classes
209
210 List of additional base classes all of your table classes will use.
211
212 =head2 left_base_classes
213
214 List of additional base classes all of your table classes will use
215 that need to be leftmost.
216
217 =head2 additional_classes
218
219 List of additional classes which all of your table classes will use.
220
221 =head2 components
222
223 List of additional components to be loaded into all of your table
224 classes.  A good example would be C<ResultSetManager>.
225
226 =head2 resultset_components
227
228 List of additional ResultSet components to be loaded into your table
229 classes.  A good example would be C<AlwaysRS>.  Component
230 C<ResultSetManager> will be automatically added to the above
231 C<components> list if this option is set.
232
233 =head2 use_namespaces
234
235 Generate result class names suitable for
236 L<DBIx::Class::Schema/load_namespaces> and call that instead of
237 L<DBIx::Class::Schema/load_classes>. When using this option you can also
238 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
239 C<resultset_namespace>, C<default_resultset_class>), and they will be added
240 to the call (and the generated result class names adjusted appropriately).
241
242 =head2 dump_directory
243
244 This option is designed to be a tool to help you transition from this
245 loader to a manually-defined schema when you decide it's time to do so.
246
247 The value of this option is a perl libdir pathname.  Within
248 that directory this module will create a baseline manual
249 L<DBIx::Class::Schema> module set, based on what it creates at runtime
250 in memory.
251
252 The created schema class will have the same classname as the one on
253 which you are setting this option (and the ResultSource classes will be
254 based on this name as well).
255
256 Normally you wouldn't hard-code this setting in your schema class, as it
257 is meant for one-time manual usage.
258
259 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
260 recommended way to access this functionality.
261
262 =head2 dump_overwrite
263
264 Deprecated.  See L</really_erase_my_files> below, which does *not* mean
265 the same thing as the old C<dump_overwrite> setting from previous releases.
266
267 =head2 really_erase_my_files
268
269 Default false.  If true, Loader will unconditionally delete any existing
270 files before creating the new ones from scratch when dumping a schema to disk.
271
272 The default behavior is instead to only replace the top portion of the
273 file, up to and including the final stanza which contains
274 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
275 leaving any customizations you placed after that as they were.
276
277 When C<really_erase_my_files> is not set, if the output file already exists,
278 but the aforementioned final stanza is not found, or the checksum
279 contained there does not match the generated contents, Loader will
280 croak and not touch the file.
281
282 You should really be using version control on your schema classes (and all
283 of the rest of your code for that matter).  Don't blame me if a bug in this
284 code wipes something out when it shouldn't have, you've been warned.
285
286 =head1 METHODS
287
288 None of these methods are intended for direct invocation by regular
289 users of L<DBIx::Class::Schema::Loader>.  Anything you can find here
290 can also be found via standard L<DBIx::Class::Schema> methods somehow.
291
292 =cut
293
294 use constant CURRENT_V => 'v5';
295
296 # ensure that a peice of object data is a valid arrayref, creating
297 # an empty one or encapsulating whatever's there.
298 sub _ensure_arrayref {
299     my $self = shift;
300
301     foreach (@_) {
302         $self->{$_} ||= [];
303         $self->{$_} = [ $self->{$_} ]
304             unless ref $self->{$_} eq 'ARRAY';
305     }
306 }
307
308 =head2 new
309
310 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
311 by L<DBIx::Class::Schema::Loader>.
312
313 =cut
314
315 sub new {
316     my ( $class, %args ) = @_;
317
318     my $self = { %args };
319
320     bless $self => $class;
321
322     $self->_ensure_arrayref(qw/additional_classes
323                                additional_base_classes
324                                left_base_classes
325                                components
326                                resultset_components
327                               /);
328
329     push(@{$self->{components}}, 'ResultSetManager')
330         if @{$self->{resultset_components}};
331
332     $self->{monikers} = {};
333     $self->{classes} = {};
334
335     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
336     $self->{schema} ||= $self->{schema_class};
337
338     croak "dump_overwrite is deprecated.  Please read the"
339         . " DBIx::Class::Schema::Loader::Base documentation"
340             if $self->{dump_overwrite};
341
342     $self->{dynamic} = ! $self->{dump_directory};
343     $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
344                                                      TMPDIR  => 1,
345                                                      CLEANUP => 1,
346                                                    );
347
348     $self->{dump_directory} ||= $self->{temp_directory};
349
350     $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
351     $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
352
353     if ((not ref $self->naming) && defined $self->naming) {
354         my $naming_ver = $self->naming;
355         $self->{naming} = {
356             relationships => $naming_ver,
357             monikers => $naming_ver,
358         };
359     }
360
361     if ($self->naming) {
362         for (values %{ $self->naming }) {
363             $_ = CURRENT_V if $_ eq 'current';
364         }
365     }
366     $self->{naming} ||= {};
367
368     $self->_check_back_compat;
369
370     $self;
371 }
372
373 sub _check_back_compat {
374     my ($self) = @_;
375
376 # dynamic schemas will always be in 0.04006 mode, unless overridden
377     if ($self->dynamic) {
378 # just in case, though no one is likely to dump a dynamic schema
379         $self->schema_version_to_dump('0.04006');
380
381         if (not %{ $self->naming }) {
382             warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
383
384 Dynamic schema detected, will run in 0.04006 mode.
385
386 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
387 to disable this warning.
388 EOF
389         }
390
391         $self->naming->{relationships} ||= 'v4';
392         $self->naming->{monikers}      ||= 'v4';
393
394         return;
395     }
396
397 # otherwise check if we need backcompat mode for a static schema
398     my $filename = $self->_get_dump_filename($self->schema_class);
399     return unless -e $filename;
400
401     open(my $fh, '<', $filename)
402         or croak "Cannot open '$filename' for reading: $!";
403
404     while (<$fh>) {
405         if (/^# Created by DBIx::Class::Schema::Loader v((\d+)\.(\d+))/) {
406             my $real_ver = $1;
407
408             $self->schema_version_to_dump($real_ver);
409
410             # XXX when we go past .0 this will need fixing
411             my ($v) = $real_ver =~ /([1-9])/;
412             $v = "v$v";
413
414             $self->naming->{relationships} ||= $v;
415             $self->naming->{monikers}      ||= $v;
416
417             last;
418         }
419     }
420     close $fh;
421 }
422
423 sub _find_file_in_inc {
424     my ($self, $file) = @_;
425
426     foreach my $prefix (@INC) {
427         my $fullpath = File::Spec->catfile($prefix, $file);
428         return $fullpath if -f $fullpath
429             and Cwd::abs_path($fullpath) ne
430                 Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || '';
431     }
432
433     return;
434 }
435
436 sub _class_path {
437     my ($self, $class) = @_;
438
439     my $class_path = $class;
440     $class_path =~ s{::}{/}g;
441     $class_path .= '.pm';
442
443     return $class_path;
444 }
445
446 sub _find_class_in_inc {
447     my ($self, $class) = @_;
448
449     return $self->_find_file_in_inc($self->_class_path($class));
450 }
451
452 sub _load_external {
453     my ($self, $class) = @_;
454
455     my $real_inc_path = $self->_find_class_in_inc($class);
456
457     return if !$real_inc_path;
458
459     # If we make it to here, we loaded an external definition
460     warn qq/# Loaded external class definition for '$class'\n/
461         if $self->debug;
462
463     open(my $fh, '<', $real_inc_path)
464         or croak "Failed to open '$real_inc_path' for reading: $!";
465     $self->_ext_stmt($class,
466          qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
467         .qq|# They are now part of the custom portion of this file\n|
468         .qq|# for you to hand-edit.  If you do not either delete\n|
469         .qq|# this section or remove that file from \@INC, this section\n|
470         .qq|# will be repeated redundantly when you re-create this\n|
471         .qq|# file again via Loader!\n|
472     );
473     while(<$fh>) {
474         chomp;
475         $self->_ext_stmt($class, $_);
476     }
477     $self->_ext_stmt($class,
478         qq|# End of lines loaded from '$real_inc_path' |
479     );
480     close($fh)
481         or croak "Failed to close $real_inc_path: $!";
482
483     if ($self->dynamic) { # load the class too
484         # turn off redefined warnings
485         local $SIG{__WARN__} = sub {};
486         do $real_inc_path;
487         die $@ if $@;
488     }
489 }
490
491 =head2 load
492
493 Does the actual schema-construction work.
494
495 =cut
496
497 sub load {
498     my $self = shift;
499
500     $self->_load_tables($self->_tables_list);
501 }
502
503 =head2 rescan
504
505 Arguments: schema
506
507 Rescan the database for newly added tables.  Does
508 not process drops or changes.  Returns a list of
509 the newly added table monikers.
510
511 The schema argument should be the schema class
512 or object to be affected.  It should probably
513 be derived from the original schema_class used
514 during L</load>.
515
516 =cut
517
518 sub rescan {
519     my ($self, $schema) = @_;
520
521     $self->{schema} = $schema;
522     $self->_relbuilder->{schema} = $schema;
523
524     my @created;
525     my @current = $self->_tables_list;
526     foreach my $table ($self->_tables_list) {
527         if(!exists $self->{_tables}->{$table}) {
528             push(@created, $table);
529         }
530     }
531
532     my $loaded = $self->_load_tables(@created);
533
534     return map { $self->monikers->{$_} } @$loaded;
535 }
536
537 sub _relbuilder {
538     no warnings 'uninitialized';
539     my ($self) = @_;
540
541     return if $self->{skip_relationships};
542
543     if ($self->naming->{relationships} eq 'v4') {
544         require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
545         return $self->{relbuilder} ||=
546             DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
547                 $self->schema, $self->inflect_plural, $self->inflect_singular
548             );
549     }
550
551     $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new(
552         $self->schema, $self->inflect_plural, $self->inflect_singular
553     );
554 }
555
556 sub _load_tables {
557     my ($self, @tables) = @_;
558
559     # First, use _tables_list with constraint and exclude
560     #  to get a list of tables to operate on
561
562     my $constraint   = $self->constraint;
563     my $exclude      = $self->exclude;
564
565     @tables = grep { /$constraint/ } @tables if $constraint;
566     @tables = grep { ! /$exclude/ } @tables if $exclude;
567
568     # Save the new tables to the tables list
569     foreach (@tables) {
570         $self->{_tables}->{$_} = 1;
571     }
572
573     $self->_make_src_class($_) for @tables;
574     $self->_setup_src_meta($_) for @tables;
575
576     if(!$self->skip_relationships) {
577         # The relationship loader needs a working schema
578         $self->{quiet} = 1;
579         local $self->{dump_directory} = $self->{temp_directory};
580         $self->_reload_classes(\@tables);
581         $self->_load_relationships($_) for @tables;
582         $self->{quiet} = 0;
583
584         # Remove that temp dir from INC so it doesn't get reloaded
585         @INC = grep { $_ ne $self->{dump_directory} } @INC;
586     }
587
588     $self->_load_external($_)
589         for map { $self->classes->{$_} } @tables;
590
591     # Reload without unloading first to preserve any symbols from external
592     # packages.
593     $self->_reload_classes(\@tables, 0);
594
595     # Drop temporary cache
596     delete $self->{_cache};
597
598     return \@tables;
599 }
600
601 sub _reload_classes {
602     my ($self, $tables, $unload) = @_;
603
604     my @tables = @$tables;
605     $unload = 1 unless defined $unload;
606
607     # so that we don't repeat custom sections
608     @INC = grep $_ ne $self->dump_directory, @INC;
609
610     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
611
612     unshift @INC, $self->dump_directory;
613     
614     my @to_register;
615     my %have_source = map { $_ => $self->schema->source($_) }
616         $self->schema->sources;
617
618     for my $table (@tables) {
619         my $moniker = $self->monikers->{$table};
620         my $class = $self->classes->{$table};
621         
622         {
623             no warnings 'redefine';
624             local *Class::C3::reinitialize = sub {};
625             use warnings;
626
627             Class::Unload->unload($class) if $unload;
628             my ($source, $resultset_class);
629             if (
630                 ($source = $have_source{$moniker})
631                 && ($resultset_class = $source->resultset_class)
632                 && ($resultset_class ne 'DBIx::Class::ResultSet')
633             ) {
634                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
635                 Class::Unload->unload($resultset_class) if $unload;
636                 $self->_reload_class($resultset_class) if $has_file;
637             }
638             $self->_reload_class($class);
639         }
640         push @to_register, [$moniker, $class];
641     }
642
643     Class::C3->reinitialize;
644     for (@to_register) {
645         $self->schema->register_class(@$_);
646     }
647 }
648
649 # We use this instead of ensure_class_loaded when there are package symbols we
650 # want to preserve.
651 sub _reload_class {
652     my ($self, $class) = @_;
653
654     my $class_path = $self->_class_path($class);
655     delete $INC{ $class_path };
656     eval "require $class;";
657 }
658
659 sub _get_dump_filename {
660     my ($self, $class) = (@_);
661
662     $class =~ s{::}{/}g;
663     return $self->dump_directory . q{/} . $class . q{.pm};
664 }
665
666 sub _ensure_dump_subdirs {
667     my ($self, $class) = (@_);
668
669     my @name_parts = split(/::/, $class);
670     pop @name_parts; # we don't care about the very last element,
671                      # which is a filename
672
673     my $dir = $self->dump_directory;
674     while (1) {
675         if(!-d $dir) {
676             mkdir($dir) or croak "mkdir('$dir') failed: $!";
677         }
678         last if !@name_parts;
679         $dir = File::Spec->catdir($dir, shift @name_parts);
680     }
681 }
682
683 sub _dump_to_dir {
684     my ($self, @classes) = @_;
685
686     my $schema_class = $self->schema_class;
687     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
688
689     my $target_dir = $self->dump_directory;
690     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
691         unless $self->{dynamic} or $self->{quiet};
692
693     my $schema_text =
694           qq|package $schema_class;\n\n|
695         . qq|# Created by DBIx::Class::Schema::Loader\n|
696         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
697         . qq|use strict;\nuse warnings;\n\n|
698         . qq|use base '$schema_base_class';\n\n|;
699
700     if ($self->use_namespaces) {
701         $schema_text .= qq|__PACKAGE__->load_namespaces|;
702         my $namespace_options;
703         for my $attr (qw(result_namespace
704                          resultset_namespace
705                          default_resultset_class)) {
706             if ($self->$attr) {
707                 $namespace_options .= qq|    $attr => '| . $self->$attr . qq|',\n|
708             }
709         }
710         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
711         $schema_text .= qq|;\n|;
712     }
713     else {
714         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
715     }
716
717     {
718         local $self->{version_to_dump} = $self->schema_version_to_dump;
719         $self->_write_classfile($schema_class, $schema_text);
720     }
721
722     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
723
724     foreach my $src_class (@classes) {
725         my $src_text = 
726               qq|package $src_class;\n\n|
727             . qq|# Created by DBIx::Class::Schema::Loader\n|
728             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
729             . qq|use strict;\nuse warnings;\n\n|
730             . qq|use base '$result_base_class';\n\n|;
731
732         $self->_write_classfile($src_class, $src_text);
733     }
734
735     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
736
737 }
738
739 sub _sig_comment {
740     my ($self, $version, $ts) = @_;
741     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
742          . qq| v| . $version
743          . q| @ | . $ts 
744          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
745 }
746
747 sub _write_classfile {
748     my ($self, $class, $text) = @_;
749
750     my $filename = $self->_get_dump_filename($class);
751     $self->_ensure_dump_subdirs($class);
752
753     if (-f $filename && $self->really_erase_my_files) {
754         warn "Deleting existing file '$filename' due to "
755             . "'really_erase_my_files' setting\n" unless $self->{quiet};
756         unlink($filename);
757     }    
758
759     my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
760
761     $text .= qq|$_\n|
762         for @{$self->{_dump_storage}->{$class} || []};
763
764     # Check and see if the dump is infact differnt
765
766     my $compare_to;
767     if ($old_md5) {
768       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
769       
770
771       if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
772         return;
773       }
774     }
775
776     $text .= $self->_sig_comment(
777       $self->version_to_dump,
778       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
779     );
780
781     open(my $fh, '>', $filename)
782         or croak "Cannot open '$filename' for writing: $!";
783
784     # Write the top half and its MD5 sum
785     print $fh $text . Digest::MD5::md5_base64($text) . "\n";
786
787     # Write out anything loaded via external partial class file in @INC
788     print $fh qq|$_\n|
789         for @{$self->{_ext_storage}->{$class} || []};
790
791     # Write out any custom content the user has added
792     print $fh $custom_content;
793
794     close($fh)
795         or croak "Error closing '$filename': $!";
796 }
797
798 sub _default_custom_content {
799     return qq|\n\n# You can replace this text with custom|
800          . qq| content, and it will be preserved on regeneration|
801          . qq|\n1;\n|;
802 }
803
804 sub _get_custom_content {
805     my ($self, $class, $filename) = @_;
806
807     return ($self->_default_custom_content) if ! -f $filename;
808
809     open(my $fh, '<', $filename)
810         or croak "Cannot open '$filename' for reading: $!";
811
812     my $mark_re = 
813         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
814
815     my $buffer = '';
816     my ($md5, $ts, $ver);
817     while(<$fh>) {
818         if(!$md5 && /$mark_re/) {
819             $md5 = $2;
820             my $line = $1;
821
822             # Pull out the previous version and timestamp
823             ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
824
825             $buffer .= $line;
826             croak "Checksum mismatch in '$filename'"
827                 if Digest::MD5::md5_base64($buffer) ne $md5;
828
829             $buffer = '';
830         }
831         else {
832             $buffer .= $_;
833         }
834     }
835
836     croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
837         . " it does not appear to have been generated by Loader"
838             if !$md5;
839
840     # Default custom content:
841     $buffer ||= $self->_default_custom_content;
842
843     return ($buffer, $md5, $ver, $ts);
844 }
845
846 sub _use {
847     my $self = shift;
848     my $target = shift;
849
850     foreach (@_) {
851         warn "$target: use $_;" if $self->debug;
852         $self->_raw_stmt($target, "use $_;");
853     }
854 }
855
856 sub _inject {
857     my $self = shift;
858     my $target = shift;
859     my $schema_class = $self->schema_class;
860
861     my $blist = join(q{ }, @_);
862     warn "$target: use base qw/ $blist /;" if $self->debug && @_;
863     $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
864 }
865
866 # Create class with applicable bases, setup monikers, etc
867 sub _make_src_class {
868     my ($self, $table) = @_;
869
870     my $schema       = $self->schema;
871     my $schema_class = $self->schema_class;
872
873     my $table_moniker = $self->_table2moniker($table);
874     my @result_namespace = ($schema_class);
875     if ($self->use_namespaces) {
876         my $result_namespace = $self->result_namespace || 'Result';
877         if ($result_namespace =~ /^\+(.*)/) {
878             # Fully qualified namespace
879             @result_namespace =  ($1)
880         }
881         else {
882             # Relative namespace
883             push @result_namespace, $result_namespace;
884         }
885     }
886     my $table_class = join(q{::}, @result_namespace, $table_moniker);
887
888     my $table_normalized = lc $table;
889     $self->classes->{$table} = $table_class;
890     $self->classes->{$table_normalized} = $table_class;
891     $self->monikers->{$table} = $table_moniker;
892     $self->monikers->{$table_normalized} = $table_moniker;
893
894     $self->_use   ($table_class, @{$self->additional_classes});
895     $self->_inject($table_class, @{$self->left_base_classes});
896
897     if (my @components = @{ $self->components }) {
898         $self->_dbic_stmt($table_class, 'load_components', @components);
899     }
900
901     $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
902         if @{$self->resultset_components};
903     $self->_inject($table_class, @{$self->additional_base_classes});
904 }
905
906 # Set up metadata (cols, pks, etc)
907 sub _setup_src_meta {
908     my ($self, $table) = @_;
909
910     my $schema       = $self->schema;
911     my $schema_class = $self->schema_class;
912
913     my $table_class = $self->classes->{$table};
914     my $table_moniker = $self->monikers->{$table};
915
916     my $table_name = $table;
917     my $name_sep   = $self->schema->storage->sql_maker->name_sep;
918
919     if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
920         $table_name = \ $self->_quote_table_name($table_name);
921     }
922
923     $self->_dbic_stmt($table_class,'table',$table_name);
924
925     my $cols = $self->_table_columns($table);
926     my $col_info;
927     eval { $col_info = $self->_columns_info_for($table) };
928     if($@) {
929         $self->_dbic_stmt($table_class,'add_columns',@$cols);
930     }
931     else {
932         if ($self->_is_case_sensitive) {
933             for my $col (keys %$col_info) {
934                 $col_info->{$col}{accessor} = lc $col
935                     if $col ne lc($col);
936             }
937         } else {
938             $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
939         }
940
941         my $fks = $self->_table_fk_info($table);
942
943         for my $fkdef (@$fks) {
944             for my $col (@{ $fkdef->{local_columns} }) {
945                 $col_info->{$col}{is_foreign_key} = 1;
946             }
947         }
948         $self->_dbic_stmt(
949             $table_class,
950             'add_columns',
951             map { $_, ($col_info->{$_}||{}) } @$cols
952         );
953     }
954
955     my %uniq_tag; # used to eliminate duplicate uniqs
956
957     my $pks = $self->_table_pk_info($table) || [];
958     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
959           : carp("$table has no primary key");
960     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
961
962     my $uniqs = $self->_table_uniq_info($table) || [];
963     for (@$uniqs) {
964         my ($name, $cols) = @$_;
965         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
966         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
967     }
968
969 }
970
971 =head2 tables
972
973 Returns a sorted list of loaded tables, using the original database table
974 names.
975
976 =cut
977
978 sub tables {
979     my $self = shift;
980
981     return keys %{$self->_tables};
982 }
983
984 # Make a moniker from a table
985 sub _default_table2moniker {
986     no warnings 'uninitialized';
987     my ($self, $table) = @_;
988
989     if ($self->naming->{monikers} eq 'v4') {
990         return join '', map ucfirst, split /[\W_]+/, lc $table;
991     }
992
993     return join '', map ucfirst, split /[\W_]+/,
994         Lingua::EN::Inflect::Number::to_S(lc $table);
995 }
996
997 sub _table2moniker {
998     my ( $self, $table ) = @_;
999
1000     my $moniker;
1001
1002     if( ref $self->moniker_map eq 'HASH' ) {
1003         $moniker = $self->moniker_map->{$table};
1004     }
1005     elsif( ref $self->moniker_map eq 'CODE' ) {
1006         $moniker = $self->moniker_map->($table);
1007     }
1008
1009     $moniker ||= $self->_default_table2moniker($table);
1010
1011     return $moniker;
1012 }
1013
1014 sub _load_relationships {
1015     my ($self, $table) = @_;
1016
1017     my $tbl_fk_info = $self->_table_fk_info($table);
1018     foreach my $fkdef (@$tbl_fk_info) {
1019         $fkdef->{remote_source} =
1020             $self->monikers->{delete $fkdef->{remote_table}};
1021     }
1022     my $tbl_uniq_info = $self->_table_uniq_info($table);
1023
1024     my $local_moniker = $self->monikers->{$table};
1025     my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1026
1027     foreach my $src_class (sort keys %$rel_stmts) {
1028         my $src_stmts = $rel_stmts->{$src_class};
1029         foreach my $stmt (@$src_stmts) {
1030             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1031         }
1032     }
1033 }
1034
1035 # Overload these in driver class:
1036
1037 # Returns an arrayref of column names
1038 sub _table_columns { croak "ABSTRACT METHOD" }
1039
1040 # Returns arrayref of pk col names
1041 sub _table_pk_info { croak "ABSTRACT METHOD" }
1042
1043 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1044 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1045
1046 # Returns an arrayref of foreign key constraints, each
1047 #   being a hashref with 3 keys:
1048 #   local_columns (arrayref), remote_columns (arrayref), remote_table
1049 sub _table_fk_info { croak "ABSTRACT METHOD" }
1050
1051 # Returns an array of lower case table names
1052 sub _tables_list { croak "ABSTRACT METHOD" }
1053
1054 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1055 sub _dbic_stmt {
1056     my $self = shift;
1057     my $class = shift;
1058     my $method = shift;
1059     if ( $method eq 'table' ) {
1060         my ($table) = @_;
1061         $self->_pod( $class, "=head1 NAME" );
1062         my $table_descr = $class;
1063         if ( $self->can('_table_comment') ) {
1064             my $comment = $self->_table_comment($table);
1065             $table_descr .= " - " . $comment if $comment;
1066         }
1067         $self->{_class2table}{ $class } = $table;
1068         $self->_pod( $class, $table_descr );
1069         $self->_pod_cut( $class );
1070     } elsif ( $method eq 'add_columns' ) {
1071         $self->_pod( $class, "=head1 ACCESSORS" );
1072         my $i = 0;
1073         foreach ( @_ ) {
1074             $i++;
1075             next unless $i % 2;
1076             $self->_pod( $class, '=head2 ' . $_  );
1077             my $comment;
1078             $comment = $self->_column_comment( $self->{_class2table}{$class}, ($i - 1) / 2 + 1  ) if $self->can('_column_comment');
1079             $self->_pod( $class, $comment ) if $comment;
1080         }
1081         $self->_pod_cut( $class );
1082     } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1083         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1084         my ( $accessor, $rel_class ) = @_;
1085         $self->_pod( $class, "=head2 $accessor" );
1086         $self->_pod( $class, 'Type: ' . $method );
1087         $self->_pod( $class, "Related object: L<$rel_class>" );
1088         $self->_pod_cut( $class );
1089         $self->{_relations_started} { $class } = 1;
1090     }
1091     my $args = dump(@_);
1092     $args = '(' . $args . ')' if @_ < 2;
1093     my $stmt = $method . $args . q{;};
1094
1095     warn qq|$class\->$stmt\n| if $self->debug;
1096     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1097     return;
1098 }
1099
1100 # Stores a POD documentation
1101 sub _pod {
1102     my ($self, $class, $stmt) = @_;
1103     $self->_raw_stmt( $class, "\n" . $stmt  );
1104 }
1105
1106 sub _pod_cut {
1107     my ($self, $class ) = @_;
1108     $self->_raw_stmt( $class, "\n=cut\n" );
1109 }
1110
1111
1112 # Store a raw source line for a class (for dumping purposes)
1113 sub _raw_stmt {
1114     my ($self, $class, $stmt) = @_;
1115     push(@{$self->{_dump_storage}->{$class}}, $stmt);
1116 }
1117
1118 # Like above, but separately for the externally loaded stuff
1119 sub _ext_stmt {
1120     my ($self, $class, $stmt) = @_;
1121     push(@{$self->{_ext_storage}->{$class}}, $stmt);
1122 }
1123
1124 sub _quote_table_name {
1125     my ($self, $table) = @_;
1126
1127     my $qt = $self->schema->storage->sql_maker->quote_char;
1128
1129     return $table unless $qt;
1130
1131     if (ref $qt) {
1132         return $qt->[0] . $table . $qt->[1];
1133     }
1134
1135     return $qt . $table . $qt;
1136 }
1137
1138 sub _is_case_sensitive { 0 }
1139
1140 =head2 monikers
1141
1142 Returns a hashref of loaded table to moniker mappings.  There will
1143 be two entries for each table, the original name and the "normalized"
1144 name, in the case that the two are different (such as databases
1145 that like uppercase table names, or preserve your original mixed-case
1146 definitions, or what-have-you).
1147
1148 =head2 classes
1149
1150 Returns a hashref of table to class mappings.  In some cases it will
1151 contain multiple entries per table for the original and normalized table
1152 names, as above in L</monikers>.
1153
1154 =head1 SEE ALSO
1155
1156 L<DBIx::Class::Schema::Loader>
1157
1158 =head1 AUTHOR
1159
1160 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1161
1162 =head1 LICENSE
1163
1164 This library is free software; you can redistribute it and/or modify it under
1165 the same terms as Perl itself.
1166
1167 =cut
1168
1169 1;