release
[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::Grouped Class::C3::Componentised/;
6 use namespace::autoclean;
7 use Class::C3;
8 use Carp::Clan qw/^DBIx::Class/;
9 use DBIx::Class::Schema::Loader::RelBuilder;
10 use Data::Dump qw/ dump /;
11 use POSIX qw//;
12 use File::Spec qw//;
13 use Cwd qw//;
14 use Digest::MD5 qw//;
15 use Lingua::EN::Inflect::Number qw//;
16 use Lingua::EN::Inflect::Phrase qw//;
17 use File::Temp qw//;
18 use Class::Unload;
19 use Class::Inspector ();
20 use Data::Dumper::Concise;
21 use Scalar::Util 'looks_like_number';
22 use File::Slurp 'slurp';
23 require DBIx::Class;
24
25 our $VERSION = '0.06001';
26
27 __PACKAGE__->mk_group_ro_accessors('simple', qw/
28                                 schema
29                                 schema_class
30
31                                 exclude
32                                 constraint
33                                 additional_classes
34                                 additional_base_classes
35                                 left_base_classes
36                                 components
37                                 resultset_components
38                                 skip_relationships
39                                 skip_load_external
40                                 moniker_map
41                                 custom_column_info
42                                 inflect_singular
43                                 inflect_plural
44                                 debug
45                                 dump_directory
46                                 dump_overwrite
47                                 really_erase_my_files
48                                 resultset_namespace
49                                 default_resultset_class
50                                 schema_base_class
51                                 result_base_class
52                                 overwrite_modifications
53
54                                 relationship_attrs
55
56                                 db_schema
57                                 _tables
58                                 classes
59                                 _upgrading_classes
60                                 monikers
61                                 dynamic
62                                 naming
63                                 datetime_timezone
64                                 datetime_locale
65                                 config_file
66                                 loader_class
67 /);
68
69
70 __PACKAGE__->mk_group_accessors('simple', qw/
71                                 version_to_dump
72                                 schema_version_to_dump
73                                 _upgrading_from
74                                 _upgrading_from_load_classes
75                                 _downgrading_to_load_classes
76                                 _rewriting_result_namespace
77                                 use_namespaces
78                                 result_namespace
79                                 generate_pod
80                                 pod_comment_mode
81                                 pod_comment_spillover_length
82 /);
83
84 =head1 NAME
85
86 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
87
88 =head1 SYNOPSIS
89
90 See L<DBIx::Class::Schema::Loader>
91
92 =head1 DESCRIPTION
93
94 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
95 classes, and implements the common functionality between them.
96
97 =head1 CONSTRUCTOR OPTIONS
98
99 These constructor options are the base options for
100 L<DBIx::Class::Schema::Loader/loader_options>.  Available constructor options are:
101
102 =head2 skip_relationships
103
104 Skip setting up relationships.  The default is to attempt the loading
105 of relationships.
106
107 =head2 skip_load_external
108
109 Skip loading of other classes in @INC. The default is to merge all other classes
110 with the same name found in @INC into the schema file we are creating.
111
112 =head2 naming
113
114 Static schemas (ones dumped to disk) will, by default, use the new-style
115 relationship names and singularized Results, unless you're overwriting an
116 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
117 which case the backward compatible RelBuilder will be activated, and the
118 appropriate monikerization used.
119
120 Specifying
121
122     naming => 'current'
123
124 will disable the backward-compatible RelBuilder and use
125 the new-style relationship names along with singularized Results, even when
126 overwriting a dump made with an earlier version.
127
128 The option also takes a hashref:
129
130     naming => { relationships => 'v6', monikers => 'v6' }
131
132 The keys are:
133
134 =over 4
135
136 =item relationships
137
138 How to name relationship accessors.
139
140 =item monikers
141
142 How to name Result classes.
143
144 =back
145
146 The values can be:
147
148 =over 4
149
150 =item current
151
152 Latest style, whatever that happens to be.
153
154 =item v4
155
156 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
157
158 =item v5
159
160 Monikers singularized as whole words, C<might_have> relationships for FKs on
161 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
162
163 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
164 the v5 RelBuilder.
165
166 =item v6
167
168 All monikers and relationships inflected using L<Lingua::EN::Inflect::Phrase>,
169 more aggressive C<_id> stripping from relationships.
170
171 In general, there is very little difference between v5 and v6 schemas.
172
173 =back
174
175 Dynamic schemas will always default to the 0.04XXX relationship names and won't
176 singularize Results for backward compatibility, to activate the new RelBuilder
177 and singularization put this in your C<Schema.pm> file:
178
179     __PACKAGE__->naming('current');
180
181 Or if you prefer to use 0.05XXX features but insure that nothing breaks in the
182 next major version upgrade:
183
184     __PACKAGE__->naming('v5');
185
186 =head2 generate_pod
187
188 By default POD will be generated for columns and relationships, using database
189 metadata for the text if available and supported.
190
191 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
192 supported for Postgres right now.
193
194 Set this to C<0> to turn off all POD generation.
195
196 =head2 pod_comment_mode
197
198 Controls where table comments appear in the generated POD. Smaller table
199 comments are appended to the C<NAME> section of the documentation, and larger
200 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
201 section to be generated with the comment always, only use C<NAME>, or choose
202 the length threshold at which the comment is forced into the description.
203
204 =over 4
205
206 =item name
207
208 Use C<NAME> section only.
209
210 =item description
211
212 Force C<DESCRIPTION> always.
213
214 =item auto
215
216 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
217 default.
218
219 =back
220
221 =head2 pod_comment_spillover_length
222
223 When pod_comment_mode is set to C<auto>, this is the length of the comment at
224 which it will be forced into a separate description section.
225
226 The default is C<60>
227
228 =head2 relationship_attrs
229
230 Hashref of attributes to pass to each generated relationship, listed
231 by type.  Also supports relationship type 'all', containing options to
232 pass to all generated relationships.  Attributes set for more specific
233 relationship types override those set in 'all'.
234
235 For example:
236
237   relationship_attrs => {
238     all      => { cascade_delete => 0 },
239     has_many => { cascade_delete => 1 },
240   },
241
242 will set the C<cascade_delete> option to 0 for all generated relationships,
243 except for C<has_many>, which will have cascade_delete as 1.
244
245 NOTE: this option is not supported if v4 backward-compatible naming is
246 set either globally (naming => 'v4') or just for relationships.
247
248 =head2 debug
249
250 If set to true, each constructive L<DBIx::Class> statement the loader
251 decides to execute will be C<warn>-ed before execution.
252
253 =head2 db_schema
254
255 Set the name of the schema to load (schema in the sense that your database
256 vendor means it).  Does not currently support loading more than one schema
257 name.
258
259 =head2 constraint
260
261 Only load tables matching regex.  Best specified as a qr// regex.
262
263 =head2 exclude
264
265 Exclude tables matching regex.  Best specified as a qr// regex.
266
267 =head2 moniker_map
268
269 Overrides the default table name to moniker translation.  Can be either
270 a hashref of table keys and moniker values, or a coderef for a translator
271 function taking a single scalar table name argument and returning
272 a scalar moniker.  If the hash entry does not exist, or the function
273 returns a false value, the code falls back to default behavior
274 for that table name.
275
276 The default behavior is to singularize the table name, and: C<join '', map
277 ucfirst, split /[\W_]+/, lc $table>, which is to say: lowercase everything,
278 split up the table name into chunks anywhere a non-alpha-numeric character
279 occurs, change the case of first letter of each chunk to upper case, and put
280 the chunks back together.  Examples:
281
282     Table Name  | Moniker Name
283     ---------------------------
284     luser       | Luser
285     luser_group | LuserGroup
286     luser-opts  | LuserOpt
287
288 =head2 inflect_plural
289
290 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
291 if hash key does not exist or coderef returns false), but acts as a map
292 for pluralizing relationship names.  The default behavior is to utilize
293 L<Lingua::EN::Inflect::Number/to_PL>.
294
295 =head2 inflect_singular
296
297 As L</inflect_plural> above, but for singularizing relationship names.
298 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
299
300 =head2 schema_base_class
301
302 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
303
304 =head2 result_base_class
305
306 Base class for your table classes (aka result classes). Defaults to
307 'DBIx::Class::Core'.
308
309 =head2 additional_base_classes
310
311 List of additional base classes all of your table classes will use.
312
313 =head2 left_base_classes
314
315 List of additional base classes all of your table classes will use
316 that need to be leftmost.
317
318 =head2 additional_classes
319
320 List of additional classes which all of your table classes will use.
321
322 =head2 components
323
324 List of additional components to be loaded into all of your table
325 classes.  A good example would be C<ResultSetManager>.
326
327 =head2 resultset_components
328
329 List of additional ResultSet components to be loaded into your table
330 classes.  A good example would be C<AlwaysRS>.  Component
331 C<ResultSetManager> will be automatically added to the above
332 C<components> list if this option is set.
333
334 =head2 use_namespaces
335
336 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
337 a C<0>.
338
339 Generate result class names suitable for
340 L<DBIx::Class::Schema/load_namespaces> and call that instead of
341 L<DBIx::Class::Schema/load_classes>. When using this option you can also
342 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
343 C<resultset_namespace>, C<default_resultset_class>), and they will be added
344 to the call (and the generated result class names adjusted appropriately).
345
346 =head2 dump_directory
347
348 This option is designed to be a tool to help you transition from this
349 loader to a manually-defined schema when you decide it's time to do so.
350
351 The value of this option is a perl libdir pathname.  Within
352 that directory this module will create a baseline manual
353 L<DBIx::Class::Schema> module set, based on what it creates at runtime
354 in memory.
355
356 The created schema class will have the same classname as the one on
357 which you are setting this option (and the ResultSource classes will be
358 based on this name as well).
359
360 Normally you wouldn't hard-code this setting in your schema class, as it
361 is meant for one-time manual usage.
362
363 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
364 recommended way to access this functionality.
365
366 =head2 dump_overwrite
367
368 Deprecated.  See L</really_erase_my_files> below, which does *not* mean
369 the same thing as the old C<dump_overwrite> setting from previous releases.
370
371 =head2 really_erase_my_files
372
373 Default false.  If true, Loader will unconditionally delete any existing
374 files before creating the new ones from scratch when dumping a schema to disk.
375
376 The default behavior is instead to only replace the top portion of the
377 file, up to and including the final stanza which contains
378 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
379 leaving any customizations you placed after that as they were.
380
381 When C<really_erase_my_files> is not set, if the output file already exists,
382 but the aforementioned final stanza is not found, or the checksum
383 contained there does not match the generated contents, Loader will
384 croak and not touch the file.
385
386 You should really be using version control on your schema classes (and all
387 of the rest of your code for that matter).  Don't blame me if a bug in this
388 code wipes something out when it shouldn't have, you've been warned.
389
390 =head2 overwrite_modifications
391
392 Default false.  If false, when updating existing files, Loader will
393 refuse to modify any Loader-generated code that has been modified
394 since its last run (as determined by the checksum Loader put in its
395 comment lines).
396
397 If true, Loader will discard any manual modifications that have been
398 made to Loader-generated code.
399
400 Again, you should be using version control on your schema classes.  Be
401 careful with this option.
402
403 =head2 custom_column_info
404
405 Hook for adding extra attributes to the
406 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
407
408 Must be a coderef that returns a hashref with the extra attributes.
409
410 Receives the table name, column name and column_info.
411
412 For example:
413
414   custom_column_info => sub {
415       my ($table_name, $column_name, $column_info) = @_;
416
417       if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
418           return { is_snoopy => 1 };
419       }
420   },
421
422 This attribute can also be used to set C<inflate_datetime> on a non-datetime
423 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
424
425 =head2 datetime_timezone
426
427 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
428 columns with the DATE/DATETIME/TIMESTAMP data_types.
429
430 =head2 datetime_locale
431
432 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
433 columns with the DATE/DATETIME/TIMESTAMP data_types.
434
435 =head1 config_file
436
437 File in Perl format, which should return a HASH reference, from which to read
438 loader options.
439
440 =head1 METHODS
441
442 None of these methods are intended for direct invocation by regular
443 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
444 L<DBIx::Class::Schema::Loader>.
445
446 =cut
447
448 my $CURRENT_V = 'v6';
449
450 my @CLASS_ARGS = qw(
451     schema_base_class result_base_class additional_base_classes
452     left_base_classes additional_classes components resultset_components
453 );
454
455 # ensure that a peice of object data is a valid arrayref, creating
456 # an empty one or encapsulating whatever's there.
457 sub _ensure_arrayref {
458     my $self = shift;
459
460     foreach (@_) {
461         $self->{$_} ||= [];
462         $self->{$_} = [ $self->{$_} ]
463             unless ref $self->{$_} eq 'ARRAY';
464     }
465 }
466
467 =head2 new
468
469 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
470 by L<DBIx::Class::Schema::Loader>.
471
472 =cut
473
474 sub new {
475     my ( $class, %args ) = @_;
476
477     my $self = { %args };
478
479     bless $self => $class;
480
481     if (my $config_file = $self->config_file) {
482         my $config_opts = do $config_file;
483
484         croak "Error reading config from $config_file: $@" if $@;
485
486         croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
487
488         while (my ($k, $v) = each %$config_opts) {
489             $self->{$k} = $v unless exists $self->{$k};
490         }
491     }
492
493     $self->_ensure_arrayref(qw/additional_classes
494                                additional_base_classes
495                                left_base_classes
496                                components
497                                resultset_components
498                               /);
499
500     $self->_validate_class_args;
501
502     push(@{$self->{components}}, 'ResultSetManager')
503         if @{$self->{resultset_components}};
504
505     $self->{monikers} = {};
506     $self->{classes} = {};
507     $self->{_upgrading_classes} = {};
508
509     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
510     $self->{schema} ||= $self->{schema_class};
511
512     croak "dump_overwrite is deprecated.  Please read the"
513         . " DBIx::Class::Schema::Loader::Base documentation"
514             if $self->{dump_overwrite};
515
516     $self->{dynamic} = ! $self->{dump_directory};
517     $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
518                                                      TMPDIR  => 1,
519                                                      CLEANUP => 1,
520                                                    );
521
522     $self->{dump_directory} ||= $self->{temp_directory};
523
524     $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
525     $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
526
527     if ((not ref $self->naming) && defined $self->naming) {
528         my $naming_ver = $self->naming;
529         $self->{naming} = {
530             relationships => $naming_ver,
531             monikers => $naming_ver,
532         };
533     }
534
535     if ($self->naming) {
536         for (values %{ $self->naming }) {
537             $_ = $CURRENT_V if $_ eq 'current';
538         }
539     }
540     $self->{naming} ||= {};
541
542     if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
543         croak 'custom_column_info must be a CODE ref';
544     }
545
546     $self->_check_back_compat;
547
548     $self->use_namespaces(1) unless defined $self->use_namespaces;
549     $self->generate_pod(1)   unless defined $self->generate_pod;
550     $self->pod_comment_mode('auto')         unless defined $self->pod_comment_mode;
551     $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
552
553     $self;
554 }
555
556 sub _check_back_compat {
557     my ($self) = @_;
558
559 # dynamic schemas will always be in 0.04006 mode, unless overridden
560     if ($self->dynamic) {
561 # just in case, though no one is likely to dump a dynamic schema
562         $self->schema_version_to_dump('0.04006');
563
564         if (not %{ $self->naming }) {
565             warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
566
567 Dynamic schema detected, will run in 0.04006 mode.
568
569 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
570 to disable this warning.
571
572 Also consider setting 'use_namespaces => 1' if/when upgrading.
573
574 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
575 details.
576 EOF
577         }
578         else {
579             $self->_upgrading_from('v4');
580         }
581
582         $self->naming->{relationships} ||= 'v4';
583         $self->naming->{monikers}      ||= 'v4';
584
585         if ($self->use_namespaces) {
586             $self->_upgrading_from_load_classes(1);
587         }
588         else {
589             $self->use_namespaces(0);
590         }
591
592         return;
593     }
594
595 # otherwise check if we need backcompat mode for a static schema
596     my $filename = $self->_get_dump_filename($self->schema_class);
597     return unless -e $filename;
598
599     open(my $fh, '<', $filename)
600         or croak "Cannot open '$filename' for reading: $!";
601
602     my $load_classes     = 0;
603     my $result_namespace = '';
604
605     while (<$fh>) {
606         if (/^__PACKAGE__->load_classes;/) {
607             $load_classes = 1;
608         } elsif (/result_namespace => '([^']+)'/) {
609             $result_namespace = $1;
610         } elsif (my ($real_ver) =
611                 /^# Created by DBIx::Class::Schema::Loader v(\d+\.\d+)/) {
612
613             if ($load_classes && (not defined $self->use_namespaces)) {
614                 warn <<"EOF"  unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
615
616 'load_classes;' static schema detected, turning off 'use_namespaces'.
617
618 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
619 variable to disable this warning.
620
621 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
622 details.
623 EOF
624                 $self->use_namespaces(0);
625             }
626             elsif ($load_classes && $self->use_namespaces) {
627                 $self->_upgrading_from_load_classes(1);
628             }
629             elsif ((not $load_classes) && defined $self->use_namespaces
630                                        && (not $self->use_namespaces)) {
631                 $self->_downgrading_to_load_classes(
632                     $result_namespace || 'Result'
633                 );
634             }
635             elsif ((not defined $self->use_namespaces)
636                    || $self->use_namespaces) {
637                 if (not $self->result_namespace) {
638                     $self->result_namespace($result_namespace || 'Result');
639                 }
640                 elsif ($result_namespace ne $self->result_namespace) {
641                     $self->_rewriting_result_namespace(
642                         $result_namespace || 'Result'
643                     );
644                 }
645             }
646
647             # XXX when we go past .0 this will need fixing
648             my ($v) = $real_ver =~ /([1-9])/;
649             $v = "v$v";
650
651             last if $v eq $CURRENT_V || $real_ver =~ /^0\.\d\d999/;
652
653             if (not %{ $self->naming }) {
654                 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
655
656 Version $real_ver static schema detected, turning on backcompat mode.
657
658 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
659 to disable this warning.
660
661 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
662 from version 0.04006.
663 EOF
664             }
665             else {
666                 $self->_upgrading_from($v);
667                 last;
668             }
669
670             $self->naming->{relationships} ||= $v;
671             $self->naming->{monikers}      ||= $v;
672
673             $self->schema_version_to_dump($real_ver);
674
675             last;
676         }
677     }
678     close $fh;
679 }
680
681 sub _validate_class_args {
682     my $self = shift;
683     my $args = shift;
684     
685     foreach my $k (@CLASS_ARGS) {
686         next unless $self->$k;
687
688         my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
689         foreach my $c (@classes) {
690             # components default to being under the DBIx::Class namespace unless they
691             # are preceeded with a '+'
692             if ( $k =~ m/components$/ && $c !~ s/^\+// ) {
693                 $c = 'DBIx::Class::' . $c;
694             }
695
696             # 1 == installed, 0 == not installed, undef == invalid classname
697             my $installed = Class::Inspector->installed($c);
698             if ( defined($installed) ) {
699                 if ( $installed == 0 ) {
700                     croak qq/$c, as specified in the loader option "$k", is not installed/;
701                 }
702             } else {
703                 croak qq/$c, as specified in the loader option "$k", is an invalid class name/;
704             }
705         }
706     }
707 }
708
709 sub _find_file_in_inc {
710     my ($self, $file) = @_;
711
712     foreach my $prefix (@INC) {
713         my $fullpath = File::Spec->catfile($prefix, $file);
714         return $fullpath if -f $fullpath
715             # abs_path throws on Windows for nonexistant files
716             and eval { Cwd::abs_path($fullpath) } ne
717                (eval { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) } || '');
718     }
719
720     return;
721 }
722
723 sub _class_path {
724     my ($self, $class) = @_;
725
726     my $class_path = $class;
727     $class_path =~ s{::}{/}g;
728     $class_path .= '.pm';
729
730     return $class_path;
731 }
732
733 sub _find_class_in_inc {
734     my ($self, $class) = @_;
735
736     return $self->_find_file_in_inc($self->_class_path($class));
737 }
738
739 sub _rewriting {
740     my $self = shift;
741
742     return $self->_upgrading_from
743         || $self->_upgrading_from_load_classes
744         || $self->_downgrading_to_load_classes
745         || $self->_rewriting_result_namespace
746     ;
747 }
748
749 sub _rewrite_old_classnames {
750     my ($self, $code) = @_;
751
752     return $code unless $self->_rewriting;
753
754     my %old_classes = reverse %{ $self->_upgrading_classes };
755
756     my $re = join '|', keys %old_classes;
757     $re = qr/\b($re)\b/;
758
759     $code =~ s/$re/$old_classes{$1} || $1/eg;
760
761     return $code;
762 }
763
764 sub _load_external {
765     my ($self, $class) = @_;
766
767     return if $self->{skip_load_external};
768
769     # so that we don't load our own classes, under any circumstances
770     local *INC = [ grep $_ ne $self->dump_directory, @INC ];
771
772     my $real_inc_path = $self->_find_class_in_inc($class);
773
774     my $old_class = $self->_upgrading_classes->{$class}
775         if $self->_rewriting;
776
777     my $old_real_inc_path = $self->_find_class_in_inc($old_class)
778         if $old_class && $old_class ne $class;
779
780     return unless $real_inc_path || $old_real_inc_path;
781
782     if ($real_inc_path) {
783         # If we make it to here, we loaded an external definition
784         warn qq/# Loaded external class definition for '$class'\n/
785             if $self->debug;
786
787         open(my $fh, '<', $real_inc_path)
788             or croak "Failed to open '$real_inc_path' for reading: $!";
789         my $code = do { local $/; <$fh> };
790         close($fh)
791             or croak "Failed to close $real_inc_path: $!";
792         $code = $self->_rewrite_old_classnames($code);
793
794         if ($self->dynamic) { # load the class too
795             # kill redefined warnings
796             my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
797             local $SIG{__WARN__} = sub {
798                 $warn_handler->(@_)
799                     unless $_[0] =~ /^Subroutine \S+ redefined/;
800             };
801             eval $code;
802             die $@ if $@;
803         }
804
805         $self->_ext_stmt($class,
806           qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
807          .qq|# They are now part of the custom portion of this file\n|
808          .qq|# for you to hand-edit.  If you do not either delete\n|
809          .qq|# this section or remove that file from \@INC, this section\n|
810          .qq|# will be repeated redundantly when you re-create this\n|
811          .qq|# file again via Loader!  See skip_load_external to disable\n|
812          .qq|# this feature.\n|
813         );
814         chomp $code;
815         $self->_ext_stmt($class, $code);
816         $self->_ext_stmt($class,
817             qq|# End of lines loaded from '$real_inc_path' |
818         );
819     }
820
821     if ($old_real_inc_path) {
822         open(my $fh, '<', $old_real_inc_path)
823             or croak "Failed to open '$old_real_inc_path' for reading: $!";
824         $self->_ext_stmt($class, <<"EOF");
825
826 # These lines were loaded from '$old_real_inc_path',
827 # based on the Result class name that would have been created by an 0.04006
828 # version of the Loader. For a static schema, this happens only once during
829 # upgrade. See skip_load_external to disable this feature.
830 EOF
831
832         my $code = slurp $old_real_inc_path;
833         $code = $self->_rewrite_old_classnames($code);
834
835         if ($self->dynamic) {
836             warn <<"EOF";
837
838 Detected external content in '$old_real_inc_path', a class name that would have
839 been used by an 0.04006 version of the Loader.
840
841 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
842 new name of the Result.
843 EOF
844             # kill redefined warnings
845             my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
846             local $SIG{__WARN__} = sub {
847                 $warn_handler->(@_)
848                     unless $_[0] =~ /^Subroutine \S+ redefined/;
849             };
850             eval $code;
851             die $@ if $@;
852         }
853
854         chomp $code;
855         $self->_ext_stmt($class, $code);
856         $self->_ext_stmt($class,
857             qq|# End of lines loaded from '$old_real_inc_path' |
858         );
859     }
860 }
861
862 =head2 load
863
864 Does the actual schema-construction work.
865
866 =cut
867
868 sub load {
869     my $self = shift;
870
871     $self->_load_tables(
872         $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
873     );
874 }
875
876 =head2 rescan
877
878 Arguments: schema
879
880 Rescan the database for newly added tables.  Does
881 not process drops or changes.  Returns a list of
882 the newly added table monikers.
883
884 The schema argument should be the schema class
885 or object to be affected.  It should probably
886 be derived from the original schema_class used
887 during L</load>.
888
889 =cut
890
891 sub rescan {
892     my ($self, $schema) = @_;
893
894     $self->{schema} = $schema;
895     $self->_relbuilder->{schema} = $schema;
896
897     my @created;
898     my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
899     foreach my $table (@current) {
900         if(!exists $self->{_tables}->{$table}) {
901             push(@created, $table);
902         }
903     }
904
905     my $loaded = $self->_load_tables(@created);
906
907     return map { $self->monikers->{$_} } @$loaded;
908 }
909
910 sub _relbuilder {
911     no warnings 'uninitialized';
912     my ($self) = @_;
913
914     return if $self->{skip_relationships};
915
916     if ($self->naming->{relationships} eq 'v4') {
917         require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
918         return $self->{relbuilder} ||=
919             DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
920                 $self->schema, $self->inflect_plural, $self->inflect_singular
921             );
922     }
923     elsif ($self->naming->{relationships} eq 'v5') {
924         require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_05;
925         return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_05->new (
926              $self->schema,
927              $self->inflect_plural,
928              $self->inflect_singular,
929              $self->relationship_attrs,
930         );
931     }
932
933     return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new (
934              $self->schema,
935              $self->inflect_plural,
936              $self->inflect_singular,
937              $self->relationship_attrs,
938     );
939 }
940
941 sub _load_tables {
942     my ($self, @tables) = @_;
943
944     # Save the new tables to the tables list
945     foreach (@tables) {
946         $self->{_tables}->{$_} = 1;
947     }
948
949     $self->_make_src_class($_) for @tables;
950
951     # sanity-check for moniker clashes
952     my $inverse_moniker_idx;
953     for (keys %{$self->monikers}) {
954       push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
955     }
956
957     my @clashes;
958     for (keys %$inverse_moniker_idx) {
959       my $tables = $inverse_moniker_idx->{$_};
960       if (@$tables > 1) {
961         push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
962           join (', ', map { "'$_'" } @$tables),
963           $_,
964         );
965       }
966     }
967
968     if (@clashes) {
969       die   'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
970           . 'Either change the naming style, or supply an explicit moniker_map: '
971           . join ('; ', @clashes)
972           . "\n"
973       ;
974     }
975
976
977     $self->_setup_src_meta($_) for @tables;
978
979     if(!$self->skip_relationships) {
980         # The relationship loader needs a working schema
981         $self->{quiet} = 1;
982         local $self->{dump_directory} = $self->{temp_directory};
983         $self->_reload_classes(\@tables);
984         $self->_load_relationships($_) for @tables;
985         $self->{quiet} = 0;
986
987         # Remove that temp dir from INC so it doesn't get reloaded
988         @INC = grep $_ ne $self->dump_directory, @INC;
989     }
990
991     $self->_load_external($_)
992         for map { $self->classes->{$_} } @tables;
993
994     # Reload without unloading first to preserve any symbols from external
995     # packages.
996     $self->_reload_classes(\@tables, 0);
997
998     # Drop temporary cache
999     delete $self->{_cache};
1000
1001     return \@tables;
1002 }
1003
1004 sub _reload_classes {
1005     my ($self, $tables, $unload) = @_;
1006
1007     my @tables = @$tables;
1008     $unload = 1 unless defined $unload;
1009
1010     # so that we don't repeat custom sections
1011     @INC = grep $_ ne $self->dump_directory, @INC;
1012
1013     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1014
1015     unshift @INC, $self->dump_directory;
1016     
1017     my @to_register;
1018     my %have_source = map { $_ => $self->schema->source($_) }
1019         $self->schema->sources;
1020
1021     for my $table (@tables) {
1022         my $moniker = $self->monikers->{$table};
1023         my $class = $self->classes->{$table};
1024         
1025         {
1026             no warnings 'redefine';
1027             local *Class::C3::reinitialize = sub {};
1028             use warnings;
1029
1030             Class::Unload->unload($class) if $unload;
1031             my ($source, $resultset_class);
1032             if (
1033                 ($source = $have_source{$moniker})
1034                 && ($resultset_class = $source->resultset_class)
1035                 && ($resultset_class ne 'DBIx::Class::ResultSet')
1036             ) {
1037                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1038                 Class::Unload->unload($resultset_class) if $unload;
1039                 $self->_reload_class($resultset_class) if $has_file;
1040             }
1041             $self->_reload_class($class);
1042         }
1043         push @to_register, [$moniker, $class];
1044     }
1045
1046     Class::C3->reinitialize;
1047     for (@to_register) {
1048         $self->schema->register_class(@$_);
1049     }
1050 }
1051
1052 # We use this instead of ensure_class_loaded when there are package symbols we
1053 # want to preserve.
1054 sub _reload_class {
1055     my ($self, $class) = @_;
1056
1057     my $class_path = $self->_class_path($class);
1058     delete $INC{ $class_path };
1059
1060 # kill redefined warnings
1061     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
1062     local $SIG{__WARN__} = sub {
1063         $warn_handler->(@_)
1064             unless $_[0] =~ /^Subroutine \S+ redefined/;
1065     };
1066     eval "require $class;";
1067 }
1068
1069 sub _get_dump_filename {
1070     my ($self, $class) = (@_);
1071
1072     $class =~ s{::}{/}g;
1073     return $self->dump_directory . q{/} . $class . q{.pm};
1074 }
1075
1076 sub _ensure_dump_subdirs {
1077     my ($self, $class) = (@_);
1078
1079     my @name_parts = split(/::/, $class);
1080     pop @name_parts; # we don't care about the very last element,
1081                      # which is a filename
1082
1083     my $dir = $self->dump_directory;
1084     while (1) {
1085         if(!-d $dir) {
1086             mkdir($dir) or croak "mkdir('$dir') failed: $!";
1087         }
1088         last if !@name_parts;
1089         $dir = File::Spec->catdir($dir, shift @name_parts);
1090     }
1091 }
1092
1093 sub _dump_to_dir {
1094     my ($self, @classes) = @_;
1095
1096     my $schema_class = $self->schema_class;
1097     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1098
1099     my $target_dir = $self->dump_directory;
1100     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1101         unless $self->{dynamic} or $self->{quiet};
1102
1103     my $schema_text =
1104           qq|package $schema_class;\n\n|
1105         . qq|# Created by DBIx::Class::Schema::Loader\n|
1106         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1107         . qq|use strict;\nuse warnings;\n\n|
1108         . qq|use base '$schema_base_class';\n\n|;
1109
1110     if ($self->use_namespaces) {
1111         $schema_text .= qq|__PACKAGE__->load_namespaces|;
1112         my $namespace_options;
1113
1114         my @attr = qw/resultset_namespace default_resultset_class/;
1115
1116         unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1117
1118         for my $attr (@attr) {
1119             if ($self->$attr) {
1120                 $namespace_options .= qq|    $attr => '| . $self->$attr . qq|',\n|
1121             }
1122         }
1123         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1124         $schema_text .= qq|;\n|;
1125     }
1126     else {
1127         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1128     }
1129
1130     {
1131         local $self->{version_to_dump} = $self->schema_version_to_dump;
1132         $self->_write_classfile($schema_class, $schema_text, 1);
1133     }
1134
1135     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1136
1137     foreach my $src_class (@classes) {
1138         my $src_text = 
1139               qq|package $src_class;\n\n|
1140             . qq|# Created by DBIx::Class::Schema::Loader\n|
1141             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1142             . qq|use strict;\nuse warnings;\n\n|
1143             . qq|use base '$result_base_class';\n\n|;
1144
1145         $self->_write_classfile($src_class, $src_text);
1146     }
1147
1148     # remove Result dir if downgrading from use_namespaces, and there are no
1149     # files left.
1150     if (my $result_ns = $self->_downgrading_to_load_classes
1151                         || $self->_rewriting_result_namespace) {
1152         my $result_namespace = $self->_result_namespace(
1153             $schema_class,
1154             $result_ns,
1155         );
1156
1157         (my $result_dir = $result_namespace) =~ s{::}{/}g;
1158         $result_dir = $self->dump_directory . '/' . $result_dir;
1159
1160         unless (my @files = glob "$result_dir/*") {
1161             rmdir $result_dir;
1162         }
1163     }
1164
1165     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1166
1167 }
1168
1169 sub _sig_comment {
1170     my ($self, $version, $ts) = @_;
1171     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1172          . qq| v| . $version
1173          . q| @ | . $ts 
1174          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1175 }
1176
1177 sub _write_classfile {
1178     my ($self, $class, $text, $is_schema) = @_;
1179
1180     my $filename = $self->_get_dump_filename($class);
1181     $self->_ensure_dump_subdirs($class);
1182
1183     if (-f $filename && $self->really_erase_my_files) {
1184         warn "Deleting existing file '$filename' due to "
1185             . "'really_erase_my_files' setting\n" unless $self->{quiet};
1186         unlink($filename);
1187     }    
1188
1189     my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
1190
1191     if (my $old_class = $self->_upgrading_classes->{$class}) {
1192         my $old_filename = $self->_get_dump_filename($old_class);
1193
1194         my ($old_custom_content) = $self->_get_custom_content(
1195             $old_class, $old_filename, 0 # do not add default comment
1196         );
1197
1198         $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
1199
1200         if ($old_custom_content) {
1201             $custom_content =
1202                 "\n" . $old_custom_content . "\n" . $custom_content;
1203         }
1204
1205         unlink $old_filename;
1206     }
1207
1208     $custom_content = $self->_rewrite_old_classnames($custom_content);
1209
1210     $text .= qq|$_\n|
1211         for @{$self->{_dump_storage}->{$class} || []};
1212
1213     # Check and see if the dump is infact differnt
1214
1215     my $compare_to;
1216     if ($old_md5) {
1217       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1218       
1219
1220       if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1221         return unless $self->_upgrading_from && $is_schema;
1222       }
1223     }
1224
1225     $text .= $self->_sig_comment(
1226       $self->version_to_dump,
1227       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1228     );
1229
1230     open(my $fh, '>', $filename)
1231         or croak "Cannot open '$filename' for writing: $!";
1232
1233     # Write the top half and its MD5 sum
1234     print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1235
1236     # Write out anything loaded via external partial class file in @INC
1237     print $fh qq|$_\n|
1238         for @{$self->{_ext_storage}->{$class} || []};
1239
1240     # Write out any custom content the user has added
1241     print $fh $custom_content;
1242
1243     close($fh)
1244         or croak "Error closing '$filename': $!";
1245 }
1246
1247 sub _default_custom_content {
1248     return qq|\n\n# You can replace this text with custom|
1249          . qq| content, and it will be preserved on regeneration|
1250          . qq|\n1;\n|;
1251 }
1252
1253 sub _get_custom_content {
1254     my ($self, $class, $filename, $add_default) = @_;
1255
1256     $add_default = 1 unless defined $add_default;
1257
1258     return ($self->_default_custom_content) if ! -f $filename;
1259
1260     open(my $fh, '<', $filename)
1261         or croak "Cannot open '$filename' for reading: $!";
1262
1263     my $mark_re = 
1264         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1265
1266     my $buffer = '';
1267     my ($md5, $ts, $ver);
1268     while(<$fh>) {
1269         if(!$md5 && /$mark_re/) {
1270             $md5 = $2;
1271             my $line = $1;
1272
1273             # Pull out the previous version and timestamp
1274             ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
1275
1276             $buffer .= $line;
1277             croak "Checksum mismatch in '$filename', the auto-generated part of the file has been modified outside of this loader.  Aborting.\nIf you want to overwrite these modifications, set the 'overwrite_modifications' loader option.\n"
1278                 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
1279
1280             $buffer = '';
1281         }
1282         else {
1283             $buffer .= $_;
1284         }
1285     }
1286
1287     croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
1288         . " it does not appear to have been generated by Loader"
1289             if !$md5;
1290
1291     # Default custom content:
1292     $buffer ||= $self->_default_custom_content if $add_default;
1293
1294     return ($buffer, $md5, $ver, $ts);
1295 }
1296
1297 sub _use {
1298     my $self = shift;
1299     my $target = shift;
1300
1301     foreach (@_) {
1302         warn "$target: use $_;" if $self->debug;
1303         $self->_raw_stmt($target, "use $_;");
1304     }
1305 }
1306
1307 sub _inject {
1308     my $self = shift;
1309     my $target = shift;
1310     my $schema_class = $self->schema_class;
1311
1312     my $blist = join(q{ }, @_);
1313     warn "$target: use base qw/ $blist /;" if $self->debug && @_;
1314     $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
1315 }
1316
1317 sub _result_namespace {
1318     my ($self, $schema_class, $ns) = @_;
1319     my @result_namespace;
1320
1321     if ($ns =~ /^\+(.*)/) {
1322         # Fully qualified namespace
1323         @result_namespace = ($1)
1324     }
1325     else {
1326         # Relative namespace
1327         @result_namespace = ($schema_class, $ns);
1328     }
1329
1330     return wantarray ? @result_namespace : join '::', @result_namespace;
1331 }
1332
1333 # Create class with applicable bases, setup monikers, etc
1334 sub _make_src_class {
1335     my ($self, $table) = @_;
1336
1337     my $schema       = $self->schema;
1338     my $schema_class = $self->schema_class;
1339
1340     my $table_moniker = $self->_table2moniker($table);
1341     my @result_namespace = ($schema_class);
1342     if ($self->use_namespaces) {
1343         my $result_namespace = $self->result_namespace || 'Result';
1344         @result_namespace = $self->_result_namespace(
1345             $schema_class,
1346             $result_namespace,
1347         );
1348     }
1349     my $table_class = join(q{::}, @result_namespace, $table_moniker);
1350
1351     if ((my $upgrading_v = $self->_upgrading_from)
1352             || $self->_rewriting) {
1353         local $self->naming->{monikers} = $upgrading_v
1354             if $upgrading_v;
1355
1356         my @result_namespace = @result_namespace;
1357         if ($self->_upgrading_from_load_classes) {
1358             @result_namespace = ($schema_class);
1359         }
1360         elsif (my $ns = $self->_downgrading_to_load_classes) {
1361             @result_namespace = $self->_result_namespace(
1362                 $schema_class,
1363                 $ns,
1364             );
1365         }
1366         elsif ($ns = $self->_rewriting_result_namespace) {
1367             @result_namespace = $self->_result_namespace(
1368                 $schema_class,
1369                 $ns,
1370             );
1371         }
1372
1373         my $old_class = join(q{::}, @result_namespace,
1374             $self->_table2moniker($table));
1375
1376         $self->_upgrading_classes->{$table_class} = $old_class
1377             unless $table_class eq $old_class;
1378     }
1379
1380 # this was a bad idea, should be ok now without it
1381 #    my $table_normalized = lc $table;
1382 #    $self->classes->{$table_normalized} = $table_class;
1383 #    $self->monikers->{$table_normalized} = $table_moniker;
1384
1385     $self->classes->{$table} = $table_class;
1386     $self->monikers->{$table} = $table_moniker;
1387
1388     $self->_use   ($table_class, @{$self->additional_classes});
1389     $self->_inject($table_class, @{$self->left_base_classes});
1390
1391     if (my @components = @{ $self->components }) {
1392         $self->_dbic_stmt($table_class, 'load_components', @components);
1393     }
1394
1395     $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1396         if @{$self->resultset_components};
1397     $self->_inject($table_class, @{$self->additional_base_classes});
1398 }
1399
1400 # Set up metadata (cols, pks, etc)
1401 sub _setup_src_meta {
1402     my ($self, $table) = @_;
1403
1404     my $schema       = $self->schema;
1405     my $schema_class = $self->schema_class;
1406
1407     my $table_class = $self->classes->{$table};
1408     my $table_moniker = $self->monikers->{$table};
1409
1410     my $table_name = $table;
1411     my $name_sep   = $self->schema->storage->sql_maker->name_sep;
1412
1413     if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1414         $table_name = \ $self->_quote_table_name($table_name);
1415     }
1416
1417     $self->_dbic_stmt($table_class,'table',$table_name);
1418
1419     my $cols = $self->_table_columns($table);
1420     my $col_info = $self->__columns_info_for($table);
1421     if ($self->_is_case_sensitive) {
1422         for my $col (keys %$col_info) {
1423             $col_info->{$col}{accessor} = lc $col
1424                 if $col ne lc($col);
1425         }
1426     } else {
1427         $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1428     }
1429
1430     my $fks = $self->_table_fk_info($table);
1431
1432     for my $fkdef (@$fks) {
1433         for my $col (@{ $fkdef->{local_columns} }) {
1434             $col_info->{$col}{is_foreign_key} = 1;
1435         }
1436     }
1437     $self->_dbic_stmt(
1438         $table_class,
1439         'add_columns',
1440         map { $_, ($col_info->{$_}||{}) } @$cols
1441     );
1442
1443     my %uniq_tag; # used to eliminate duplicate uniqs
1444
1445     my $pks = $self->_table_pk_info($table) || [];
1446     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1447           : carp("$table has no primary key");
1448     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1449
1450     my $uniqs = $self->_table_uniq_info($table) || [];
1451     for (@$uniqs) {
1452         my ($name, $cols) = @$_;
1453         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1454         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1455     }
1456
1457 }
1458
1459 sub __columns_info_for {
1460     my ($self, $table) = @_;
1461
1462     my $result = $self->_columns_info_for($table);
1463
1464     while (my ($col, $info) = each %$result) {
1465         $info = { %$info, %{ $self->_custom_column_info  ($table, $col, $info) } };
1466         $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1467
1468         $result->{$col} = $info;
1469     }
1470
1471     return $result;
1472 }
1473
1474 =head2 tables
1475
1476 Returns a sorted list of loaded tables, using the original database table
1477 names.
1478
1479 =cut
1480
1481 sub tables {
1482     my $self = shift;
1483
1484     return keys %{$self->_tables};
1485 }
1486
1487 # Make a moniker from a table
1488 sub _default_table2moniker {
1489     no warnings 'uninitialized';
1490     my ($self, $table) = @_;
1491
1492     if ($self->naming->{monikers} eq 'v4') {
1493         return join '', map ucfirst, split /[\W_]+/, lc $table;
1494     }
1495     elsif ($self->naming->{monikers} eq 'v5') {
1496         return join '', map ucfirst, split /[\W_]+/,
1497             Lingua::EN::Inflect::Number::to_S(lc $table);
1498     }
1499
1500     (my $as_phrase = lc $table) =~ s/_+/ /g;
1501     my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1502
1503     return join '', map ucfirst, split /\W+/, $inflected;
1504 }
1505
1506 sub _table2moniker {
1507     my ( $self, $table ) = @_;
1508
1509     my $moniker;
1510
1511     if( ref $self->moniker_map eq 'HASH' ) {
1512         $moniker = $self->moniker_map->{$table};
1513     }
1514     elsif( ref $self->moniker_map eq 'CODE' ) {
1515         $moniker = $self->moniker_map->($table);
1516     }
1517
1518     $moniker ||= $self->_default_table2moniker($table);
1519
1520     return $moniker;
1521 }
1522
1523 sub _load_relationships {
1524     my ($self, $table) = @_;
1525
1526     my $tbl_fk_info = $self->_table_fk_info($table);
1527     foreach my $fkdef (@$tbl_fk_info) {
1528         $fkdef->{remote_source} =
1529             $self->monikers->{delete $fkdef->{remote_table}};
1530     }
1531     my $tbl_uniq_info = $self->_table_uniq_info($table);
1532
1533     my $local_moniker = $self->monikers->{$table};
1534     my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1535
1536     foreach my $src_class (sort keys %$rel_stmts) {
1537         my $src_stmts = $rel_stmts->{$src_class};
1538         foreach my $stmt (@$src_stmts) {
1539             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1540         }
1541     }
1542 }
1543
1544 # Overload these in driver class:
1545
1546 # Returns an arrayref of column names
1547 sub _table_columns { croak "ABSTRACT METHOD" }
1548
1549 # Returns arrayref of pk col names
1550 sub _table_pk_info { croak "ABSTRACT METHOD" }
1551
1552 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1553 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1554
1555 # Returns an arrayref of foreign key constraints, each
1556 #   being a hashref with 3 keys:
1557 #   local_columns (arrayref), remote_columns (arrayref), remote_table
1558 sub _table_fk_info { croak "ABSTRACT METHOD" }
1559
1560 # Returns an array of lower case table names
1561 sub _tables_list { croak "ABSTRACT METHOD" }
1562
1563 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1564 sub _dbic_stmt {
1565     my $self   = shift;
1566     my $class  = shift;
1567     my $method = shift;
1568
1569     # generate the pod for this statement, storing it with $self->_pod
1570     $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
1571
1572     my $args = dump(@_);
1573     $args = '(' . $args . ')' if @_ < 2;
1574     my $stmt = $method . $args . q{;};
1575
1576     warn qq|$class\->$stmt\n| if $self->debug;
1577     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1578     return;
1579 }
1580
1581 # generates the accompanying pod for a DBIC class method statement,
1582 # storing it with $self->_pod
1583 sub _make_pod {
1584     my $self   = shift;
1585     my $class  = shift;
1586     my $method = shift;
1587
1588     if ( $method eq 'table' ) {
1589         my ($table) = @_;
1590         my $pcm = $self->pod_comment_mode;
1591         my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
1592         if ( $self->can('_table_comment') ) {
1593             $comment = $self->_table_comment($table);
1594             $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1595             $comment_in_name   = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1596             $comment_in_desc   = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
1597         }
1598         $self->_pod( $class, "=head1 NAME" );
1599         my $table_descr = $class;
1600         $table_descr .= " - " . $comment if $comment and $comment_in_name;
1601         $self->{_class2table}{ $class } = $table;
1602         $self->_pod( $class, $table_descr );
1603         if ($comment and $comment_in_desc) {
1604             $self->_pod( $class, "=head1 DESCRIPTION" );
1605             $self->_pod( $class, $comment );
1606         }
1607         $self->_pod_cut( $class );
1608     } elsif ( $method eq 'add_columns' ) {
1609         $self->_pod( $class, "=head1 ACCESSORS" );
1610         my $col_counter = 0;
1611         my @cols = @_;
1612         while( my ($name,$attrs) = splice @cols,0,2 ) {
1613             $col_counter++;
1614             $self->_pod( $class, '=head2 ' . $name  );
1615             $self->_pod( $class,
1616                          join "\n", map {
1617                              my $s = $attrs->{$_};
1618                              $s = !defined $s         ? 'undef'          :
1619                                   length($s) == 0     ? '(empty string)' :
1620                                   ref($s) eq 'SCALAR' ? $$s :
1621                                   ref($s)             ? do {
1622                                                         my $dd = Dumper;
1623                                                         $dd->Indent(0);
1624                                                         $dd->Values([$s]);
1625                                                         $dd->Dump;
1626                                                       } :
1627                                   looks_like_number($s) ? $s :
1628                                                         qq{'$s'}
1629                                   ;
1630
1631                              "  $_: $s"
1632                          } sort keys %$attrs,
1633                        );
1634
1635             if( $self->can('_column_comment')
1636                 and my $comment = $self->_column_comment( $self->{_class2table}{$class}, $col_counter)
1637               ) {
1638                 $self->_pod( $class, $comment );
1639             }
1640         }
1641         $self->_pod_cut( $class );
1642     } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1643         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1644         my ( $accessor, $rel_class ) = @_;
1645         $self->_pod( $class, "=head2 $accessor" );
1646         $self->_pod( $class, 'Type: ' . $method );
1647         $self->_pod( $class, "Related object: L<$rel_class>" );
1648         $self->_pod_cut( $class );
1649         $self->{_relations_started} { $class } = 1;
1650     }
1651 }
1652
1653 # Stores a POD documentation
1654 sub _pod {
1655     my ($self, $class, $stmt) = @_;
1656     $self->_raw_stmt( $class, "\n" . $stmt  );
1657 }
1658
1659 sub _pod_cut {
1660     my ($self, $class ) = @_;
1661     $self->_raw_stmt( $class, "\n=cut\n" );
1662 }
1663
1664 # Store a raw source line for a class (for dumping purposes)
1665 sub _raw_stmt {
1666     my ($self, $class, $stmt) = @_;
1667     push(@{$self->{_dump_storage}->{$class}}, $stmt);
1668 }
1669
1670 # Like above, but separately for the externally loaded stuff
1671 sub _ext_stmt {
1672     my ($self, $class, $stmt) = @_;
1673     push(@{$self->{_ext_storage}->{$class}}, $stmt);
1674 }
1675
1676 sub _quote_table_name {
1677     my ($self, $table) = @_;
1678
1679     my $qt = $self->schema->storage->sql_maker->quote_char;
1680
1681     return $table unless $qt;
1682
1683     if (ref $qt) {
1684         return $qt->[0] . $table . $qt->[1];
1685     }
1686
1687     return $qt . $table . $qt;
1688 }
1689
1690 sub _is_case_sensitive { 0 }
1691
1692 sub _custom_column_info {
1693     my ( $self, $table_name, $column_name, $column_info ) = @_;
1694
1695     if (my $code = $self->custom_column_info) {
1696         return $code->($table_name, $column_name, $column_info) || {};
1697     }
1698     return {};
1699 }
1700
1701 sub _datetime_column_info {
1702     my ( $self, $table_name, $column_name, $column_info ) = @_;
1703     my $result = {};
1704     my $type = $column_info->{data_type} || '';
1705     if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
1706             or ($type =~ /date|timestamp/i)) {
1707         $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
1708         $result->{locale}   = $self->datetime_locale   if $self->datetime_locale;
1709     }
1710     return $result;
1711 }
1712
1713 # remove the dump dir from @INC on destruction
1714 sub DESTROY {
1715     my $self = shift;
1716
1717     @INC = grep $_ ne $self->dump_directory, @INC;
1718 }
1719
1720 =head2 monikers
1721
1722 Returns a hashref of loaded table to moniker mappings.  There will
1723 be two entries for each table, the original name and the "normalized"
1724 name, in the case that the two are different (such as databases
1725 that like uppercase table names, or preserve your original mixed-case
1726 definitions, or what-have-you).
1727
1728 =head2 classes
1729
1730 Returns a hashref of table to class mappings.  In some cases it will
1731 contain multiple entries per table for the original and normalized table
1732 names, as above in L</monikers>.
1733
1734 =head1 SEE ALSO
1735
1736 L<DBIx::Class::Schema::Loader>
1737
1738 =head1 AUTHOR
1739
1740 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1741
1742 =head1 LICENSE
1743
1744 This library is free software; you can redistribute it and/or modify it under
1745 the same terms as Perl itself.
1746
1747 =cut
1748
1749 1;
1750 # vim:et sts=4 sw=4 tw=0: