f425f4a6db74bcb4d1b5e9ed8fa22acc5b88e54d
[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 mro '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 Lingua::EN::Inflect::Phrase qw//;
16 use File::Temp qw//;
17 use Class::Unload;
18 use Class::Inspector ();
19 use Scalar::Util 'looks_like_number';
20 use File::Slurp 'slurp';
21 use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path/;
22 use DBIx::Class::Schema::Loader::Optional::Dependencies ();
23 use Try::Tiny;
24 use DBIx::Class ();
25 use namespace::clean;
26
27 our $VERSION = '0.07010';
28
29 __PACKAGE__->mk_group_ro_accessors('simple', qw/
30                                 schema
31                                 schema_class
32
33                                 exclude
34                                 constraint
35                                 additional_classes
36                                 additional_base_classes
37                                 left_base_classes
38                                 components
39                                 skip_relationships
40                                 skip_load_external
41                                 moniker_map
42                                 col_accessor_map
43                                 custom_column_info
44                                 inflect_singular
45                                 inflect_plural
46                                 debug
47                                 dump_directory
48                                 dump_overwrite
49                                 really_erase_my_files
50                                 resultset_namespace
51                                 default_resultset_class
52                                 schema_base_class
53                                 result_base_class
54                                 result_roles
55                                 use_moose
56                                 overwrite_modifications
57
58                                 relationship_attrs
59
60                                 db_schema
61                                 _tables
62                                 classes
63                                 _upgrading_classes
64                                 monikers
65                                 dynamic
66                                 naming
67                                 datetime_timezone
68                                 datetime_locale
69                                 config_file
70                                 loader_class
71                                 qualify_objects
72 /);
73
74
75 __PACKAGE__->mk_group_accessors('simple', qw/
76                                 version_to_dump
77                                 schema_version_to_dump
78                                 _upgrading_from
79                                 _upgrading_from_load_classes
80                                 _downgrading_to_load_classes
81                                 _rewriting_result_namespace
82                                 use_namespaces
83                                 result_namespace
84                                 generate_pod
85                                 pod_comment_mode
86                                 pod_comment_spillover_length
87                                 preserve_case
88                                 col_collision_map
89                                 rel_collision_map
90                                 real_dump_directory
91                                 result_components_map
92                                 result_roles_map
93                                 datetime_undef_if_invalid
94                                 _result_class_methods
95                                 naming_set
96 /);
97
98 =head1 NAME
99
100 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
101
102 =head1 SYNOPSIS
103
104 See L<DBIx::Class::Schema::Loader>
105
106 =head1 DESCRIPTION
107
108 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
109 classes, and implements the common functionality between them.
110
111 =head1 CONSTRUCTOR OPTIONS
112
113 These constructor options are the base options for
114 L<DBIx::Class::Schema::Loader/loader_options>.  Available constructor options are:
115
116 =head2 skip_relationships
117
118 Skip setting up relationships.  The default is to attempt the loading
119 of relationships.
120
121 =head2 skip_load_external
122
123 Skip loading of other classes in @INC. The default is to merge all other classes
124 with the same name found in @INC into the schema file we are creating.
125
126 =head2 naming
127
128 Static schemas (ones dumped to disk) will, by default, use the new-style
129 relationship names and singularized Results, unless you're overwriting an
130 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
131 which case the backward compatible RelBuilder will be activated, and the
132 appropriate monikerization used.
133
134 Specifying
135
136     naming => 'current'
137
138 will disable the backward-compatible RelBuilder and use
139 the new-style relationship names along with singularized Results, even when
140 overwriting a dump made with an earlier version.
141
142 The option also takes a hashref:
143
144     naming => { relationships => 'v7', monikers => 'v7' }
145
146 The keys are:
147
148 =over 4
149
150 =item relationships
151
152 How to name relationship accessors.
153
154 =item monikers
155
156 How to name Result classes.
157
158 =item column_accessors
159
160 How to name column accessors in Result classes.
161
162 =back
163
164 The values can be:
165
166 =over 4
167
168 =item current
169
170 Latest style, whatever that happens to be.
171
172 =item v4
173
174 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
175
176 =item v5
177
178 Monikers singularized as whole words, C<might_have> relationships for FKs on
179 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
180
181 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
182 the v5 RelBuilder.
183
184 =item v6
185
186 All monikers and relationships are inflected using
187 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
188 from relationship names.
189
190 In general, there is very little difference between v5 and v6 schemas.
191
192 =item v7
193
194 This mode is identical to C<v6> mode, except that monikerization of CamelCase
195 table names is also done correctly.
196
197 CamelCase column names in case-preserving mode will also be handled correctly
198 for relationship name inflection. See L</preserve_case>.
199
200 In this mode, CamelCase L</column_accessors> are normalized based on case
201 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
202
203 If you don't have any CamelCase table or column names, you can upgrade without
204 breaking any of your code.
205
206 =back
207
208 Dynamic schemas will always default to the 0.04XXX relationship names and won't
209 singularize Results for backward compatibility, to activate the new RelBuilder
210 and singularization put this in your C<Schema.pm> file:
211
212     __PACKAGE__->naming('current');
213
214 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
215 next major version upgrade:
216
217     __PACKAGE__->naming('v7');
218
219 =head2 generate_pod
220
221 By default POD will be generated for columns and relationships, using database
222 metadata for the text if available and supported.
223
224 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
225 supported for Postgres right now.
226
227 Set this to C<0> to turn off all POD generation.
228
229 =head2 pod_comment_mode
230
231 Controls where table comments appear in the generated POD. Smaller table
232 comments are appended to the C<NAME> section of the documentation, and larger
233 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
234 section to be generated with the comment always, only use C<NAME>, or choose
235 the length threshold at which the comment is forced into the description.
236
237 =over 4
238
239 =item name
240
241 Use C<NAME> section only.
242
243 =item description
244
245 Force C<DESCRIPTION> always.
246
247 =item auto
248
249 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
250 default.
251
252 =back
253
254 =head2 pod_comment_spillover_length
255
256 When pod_comment_mode is set to C<auto>, this is the length of the comment at
257 which it will be forced into a separate description section.
258
259 The default is C<60>
260
261 =head2 relationship_attrs
262
263 Hashref of attributes to pass to each generated relationship, listed
264 by type.  Also supports relationship type 'all', containing options to
265 pass to all generated relationships.  Attributes set for more specific
266 relationship types override those set in 'all'.
267
268 For example:
269
270   relationship_attrs => {
271     belongs_to => { is_deferrable => 0 },
272   },
273
274 use this to turn off DEFERRABLE on your foreign key constraints.
275
276 =head2 debug
277
278 If set to true, each constructive L<DBIx::Class> statement the loader
279 decides to execute will be C<warn>-ed before execution.
280
281 =head2 db_schema
282
283 Set the name of the schema to load (schema in the sense that your database
284 vendor means it).  Does not currently support loading more than one schema
285 name.
286
287 =head2 constraint
288
289 Only load tables matching regex.  Best specified as a qr// regex.
290
291 =head2 exclude
292
293 Exclude tables matching regex.  Best specified as a qr// regex.
294
295 =head2 moniker_map
296
297 Overrides the default table name to moniker translation.  Can be either
298 a hashref of table keys and moniker values, or a coderef for a translator
299 function taking a single scalar table name argument and returning
300 a scalar moniker.  If the hash entry does not exist, or the function
301 returns a false value, the code falls back to default behavior
302 for that table name.
303
304 The default behavior is to split on case transition and non-alphanumeric
305 boundaries, singularize the resulting phrase, then join the titlecased words
306 together. Examples:
307
308     Table Name       | Moniker Name
309     ---------------------------------
310     luser            | Luser
311     luser_group      | LuserGroup
312     luser-opts       | LuserOpt
313     stations_visited | StationVisited
314     routeChange      | RouteChange
315
316 =head2 col_accessor_map
317
318 Same as moniker_map, but for column accessor names.  If a coderef is
319 passed, the code is called with arguments of
320
321    the name of the column in the underlying database,
322    default accessor name that DBICSL would ordinarily give this column,
323    {
324       table_class     => name of the DBIC class we are building,
325       table_moniker   => calculated moniker for this table (after moniker_map if present),
326       table_name      => name of the database table,
327       full_table_name => schema-qualified name of the database table (RDBMS specific),
328       schema_class    => name of the schema class we are building,
329       column_info     => hashref of column info (data_type, is_nullable, etc),
330     }
331
332 =head2 inflect_plural
333
334 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
335 if hash key does not exist or coderef returns false), but acts as a map
336 for pluralizing relationship names.  The default behavior is to utilize
337 L<Lingua::EN::Inflect::Phrase/to_PL>.
338
339 =head2 inflect_singular
340
341 As L</inflect_plural> above, but for singularizing relationship names.
342 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
343
344 =head2 schema_base_class
345
346 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
347
348 =head2 result_base_class
349
350 Base class for your table classes (aka result classes). Defaults to
351 'DBIx::Class::Core'.
352
353 =head2 additional_base_classes
354
355 List of additional base classes all of your table classes will use.
356
357 =head2 left_base_classes
358
359 List of additional base classes all of your table classes will use
360 that need to be leftmost.
361
362 =head2 additional_classes
363
364 List of additional classes which all of your table classes will use.
365
366 =head2 components
367
368 List of additional components to be loaded into all of your table
369 classes.  A good example would be
370 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
371
372 =head2 result_components_map
373
374 A hashref of moniker keys and component values.  Unlike C<components>, which
375 loads the given components into every Result class, this option allows you to
376 load certain components for specified Result classes. For example:
377
378   result_components_map => {
379       StationVisited => '+YourApp::Schema::Component::StationVisited',
380       RouteChange    => [
381                             '+YourApp::Schema::Component::RouteChange',
382                             'InflateColumn::DateTime',
383                         ],
384   }
385   
386 You may use this in conjunction with C<components>.
387
388 =head2 result_roles
389
390 List of L<Moose> roles to be applied to all of your Result classes.
391
392 =head2 result_roles_map
393
394 A hashref of moniker keys and role values.  Unlike C<result_roles>, which
395 applies the given roles to every Result class, this option allows you to apply
396 certain roles for specified Result classes. For example:
397
398   result_roles_map => {
399       StationVisited => [
400                             'YourApp::Role::Building',
401                             'YourApp::Role::Destination',
402                         ],
403       RouteChange    => 'YourApp::Role::TripEvent',
404   }
405   
406 You may use this in conjunction with C<components>.
407
408 =head2 use_namespaces
409
410 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
411 a C<0>.
412
413 Generate result class names suitable for
414 L<DBIx::Class::Schema/load_namespaces> and call that instead of
415 L<DBIx::Class::Schema/load_classes>. When using this option you can also
416 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
417 C<resultset_namespace>, C<default_resultset_class>), and they will be added
418 to the call (and the generated result class names adjusted appropriately).
419
420 =head2 dump_directory
421
422 The value of this option is a perl libdir pathname.  Within
423 that directory this module will create a baseline manual
424 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
425
426 The created schema class will have the same classname as the one on
427 which you are setting this option (and the ResultSource classes will be
428 based on this name as well).
429
430 Normally you wouldn't hard-code this setting in your schema class, as it
431 is meant for one-time manual usage.
432
433 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
434 recommended way to access this functionality.
435
436 =head2 dump_overwrite
437
438 Deprecated.  See L</really_erase_my_files> below, which does *not* mean
439 the same thing as the old C<dump_overwrite> setting from previous releases.
440
441 =head2 really_erase_my_files
442
443 Default false.  If true, Loader will unconditionally delete any existing
444 files before creating the new ones from scratch when dumping a schema to disk.
445
446 The default behavior is instead to only replace the top portion of the
447 file, up to and including the final stanza which contains
448 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
449 leaving any customizations you placed after that as they were.
450
451 When C<really_erase_my_files> is not set, if the output file already exists,
452 but the aforementioned final stanza is not found, or the checksum
453 contained there does not match the generated contents, Loader will
454 croak and not touch the file.
455
456 You should really be using version control on your schema classes (and all
457 of the rest of your code for that matter).  Don't blame me if a bug in this
458 code wipes something out when it shouldn't have, you've been warned.
459
460 =head2 overwrite_modifications
461
462 Default false.  If false, when updating existing files, Loader will
463 refuse to modify any Loader-generated code that has been modified
464 since its last run (as determined by the checksum Loader put in its
465 comment lines).
466
467 If true, Loader will discard any manual modifications that have been
468 made to Loader-generated code.
469
470 Again, you should be using version control on your schema classes.  Be
471 careful with this option.
472
473 =head2 custom_column_info
474
475 Hook for adding extra attributes to the
476 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
477
478 Must be a coderef that returns a hashref with the extra attributes.
479
480 Receives the table name, column name and column_info.
481
482 For example:
483
484   custom_column_info => sub {
485       my ($table_name, $column_name, $column_info) = @_;
486
487       if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
488           return { is_snoopy => 1 };
489       }
490   },
491
492 This attribute can also be used to set C<inflate_datetime> on a non-datetime
493 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
494
495 =head2 datetime_timezone
496
497 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
498 columns with the DATE/DATETIME/TIMESTAMP data_types.
499
500 =head2 datetime_locale
501
502 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
503 columns with the DATE/DATETIME/TIMESTAMP data_types.
504
505 =head2 datetime_undef_if_invalid
506
507 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
508 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
509 TIMESTAMP columns.
510
511 The default is recommended to deal with data such as C<00/00/00> which
512 sometimes ends up in such columns in MySQL.
513
514 =head2 config_file
515
516 File in Perl format, which should return a HASH reference, from which to read
517 loader options.
518
519 =head2 preserve_case
520
521 Usually column names are lowercased, to make them easier to work with in
522 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
523 supports it.
524
525 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
526 case-sensitive collation will turn this option on unconditionally.
527
528 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
529 setting this option.
530
531 =head2 qualify_objects
532
533 Set to true to prepend the L</db_schema> to table names for C<<
534 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
535
536 =head2 use_moose
537
538 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
539 L<namespace::autoclean>. The default content after the md5 sum also makes the
540 classes immutable.
541
542 It is safe to upgrade your existing Schema to this option.
543
544 =head2 col_collision_map
545
546 This option controls how accessors for column names which collide with perl
547 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
548
549 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
550 strings which are compiled to regular expressions that map to
551 L<sprintf|perlfunc/sprintf> formats.
552
553 Examples:
554
555     col_collision_map => 'column_%s'
556
557     col_collision_map => { '(.*)' => 'column_%s' }
558
559     col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
560
561 =head2 rel_collision_map
562
563 Works just like L</col_collision_map>, but for relationship names/accessors
564 rather than column names/accessors.
565
566 The default is to just append C<_rel> to the relationship name, see
567 L</RELATIONSHIP NAME COLLISIONS>.
568
569 =head1 METHODS
570
571 None of these methods are intended for direct invocation by regular
572 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
573 L<DBIx::Class::Schema::Loader>.
574
575 =cut
576
577 my $CURRENT_V = 'v7';
578
579 my @CLASS_ARGS = qw(
580     schema_base_class result_base_class additional_base_classes
581     left_base_classes additional_classes components result_roles
582 );
583
584 # ensure that a peice of object data is a valid arrayref, creating
585 # an empty one or encapsulating whatever's there.
586 sub _ensure_arrayref {
587     my $self = shift;
588
589     foreach (@_) {
590         $self->{$_} ||= [];
591         $self->{$_} = [ $self->{$_} ]
592             unless ref $self->{$_} eq 'ARRAY';
593     }
594 }
595
596 =head2 new
597
598 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
599 by L<DBIx::Class::Schema::Loader>.
600
601 =cut
602
603 sub new {
604     my ( $class, %args ) = @_;
605
606     if (exists $args{column_accessor_map}) {
607         $args{col_accessor_map} = delete $args{column_accessor_map};
608     }
609
610     my $self = { %args };
611
612     # don't lose undef options
613     for (values %$self) {
614         $_ = 0 unless defined $_;
615     }
616
617     bless $self => $class;
618
619     if (my $config_file = $self->config_file) {
620         my $config_opts = do $config_file;
621
622         croak "Error reading config from $config_file: $@" if $@;
623
624         croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
625
626         while (my ($k, $v) = each %$config_opts) {
627             $self->{$k} = $v unless exists $self->{$k};
628         }
629     }
630
631     $self->result_components_map($self->{result_component_map})
632         if defined $self->{result_component_map};
633
634     $self->result_roles_map($self->{result_role_map})
635         if defined $self->{result_role_map};
636
637     croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
638         if ((not defined $self->use_moose) || (not $self->use_moose))
639             && ((defined $self->result_roles) || (defined $self->result_roles_map));
640
641     $self->_ensure_arrayref(qw/additional_classes
642                                additional_base_classes
643                                left_base_classes
644                                components
645                                result_roles
646                               /);
647
648     $self->_validate_class_args;
649
650     croak "result_components_map must be a hash"
651         if defined $self->result_components_map
652             && ref $self->result_components_map ne 'HASH';
653
654     if ($self->result_components_map) {
655         my %rc_map = %{ $self->result_components_map };
656         foreach my $moniker (keys %rc_map) {
657             $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
658         }
659         $self->result_components_map(\%rc_map);
660     }
661     else {
662         $self->result_components_map({});
663     }
664     $self->_validate_result_components_map;
665
666     croak "result_roles_map must be a hash"
667         if defined $self->result_roles_map
668             && ref $self->result_roles_map ne 'HASH';
669
670     if ($self->result_roles_map) {
671         my %rr_map = %{ $self->result_roles_map };
672         foreach my $moniker (keys %rr_map) {
673             $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
674         }
675         $self->result_roles_map(\%rr_map);
676     } else {
677         $self->result_roles_map({});
678     }
679     $self->_validate_result_roles_map;
680
681     if ($self->use_moose) {
682         if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
683             die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
684                 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
685         }
686     }
687
688     $self->{monikers} = {};
689     $self->{classes} = {};
690     $self->{_upgrading_classes} = {};
691
692     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
693     $self->{schema} ||= $self->{schema_class};
694
695     croak "dump_overwrite is deprecated.  Please read the"
696         . " DBIx::Class::Schema::Loader::Base documentation"
697             if $self->{dump_overwrite};
698
699     $self->{dynamic} = ! $self->{dump_directory};
700     $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
701                                                      TMPDIR  => 1,
702                                                      CLEANUP => 1,
703                                                    );
704
705     $self->{dump_directory} ||= $self->{temp_directory};
706
707     $self->real_dump_directory($self->{dump_directory});
708
709     $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
710     $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
711
712     if (not defined $self->naming) {
713         $self->naming_set(0);
714     }
715     else {
716         $self->naming_set(1);
717     }
718
719     if ((not ref $self->naming) && defined $self->naming) {
720         my $naming_ver = $self->naming;
721         $self->{naming} = {
722             relationships => $naming_ver,
723             monikers => $naming_ver,
724             column_accessors => $naming_ver,
725         };
726     }
727
728     if ($self->naming) {
729         for (values %{ $self->naming }) {
730             $_ = $CURRENT_V if $_ eq 'current';
731         }
732     }
733     $self->{naming} ||= {};
734
735     if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
736         croak 'custom_column_info must be a CODE ref';
737     }
738
739     $self->_check_back_compat;
740
741     $self->use_namespaces(1) unless defined $self->use_namespaces;
742     $self->generate_pod(1)   unless defined $self->generate_pod;
743     $self->pod_comment_mode('auto')         unless defined $self->pod_comment_mode;
744     $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
745
746     if (my $col_collision_map = $self->col_collision_map) {
747         if (my $reftype = ref $col_collision_map) {
748             if ($reftype ne 'HASH') {
749                 croak "Invalid type $reftype for option 'col_collision_map'";
750             }
751         }
752         else {
753             $self->col_collision_map({ '(.*)' => $col_collision_map });
754         }
755     }
756
757     $self;
758 }
759
760 sub _check_back_compat {
761     my ($self) = @_;
762
763 # dynamic schemas will always be in 0.04006 mode, unless overridden
764     if ($self->dynamic) {
765 # just in case, though no one is likely to dump a dynamic schema
766         $self->schema_version_to_dump('0.04006');
767
768         if (not $self->naming_set) {
769             warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
770
771 Dynamic schema detected, will run in 0.04006 mode.
772
773 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
774 to disable this warning.
775
776 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
777 details.
778 EOF
779         }
780         else {
781             $self->_upgrading_from('v4');
782         }
783
784         if ((not defined $self->use_namespaces) && ($self->naming_set)) {
785             $self->use_namespaces(1);
786         }
787
788         $self->naming->{relationships} ||= 'v4';
789         $self->naming->{monikers}      ||= 'v4';
790
791         if ($self->use_namespaces) {
792             $self->_upgrading_from_load_classes(1);
793         }
794         else {
795             $self->use_namespaces(0);
796         }
797
798         return;
799     }
800
801 # otherwise check if we need backcompat mode for a static schema
802     my $filename = $self->_get_dump_filename($self->schema_class);
803     return unless -e $filename;
804
805     my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
806       $self->_parse_generated_file($filename);
807
808     return unless $old_ver;
809
810     # determine if the existing schema was dumped with use_moose => 1
811     if (! defined $self->use_moose) {
812         $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
813     }
814
815     my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
816     my $result_namespace = do { ($old_gen =~ /result_namespace => '([^']+)'/) ? $1 : '' };
817
818     if ($load_classes && (not defined $self->use_namespaces)) {
819         warn <<"EOF"  unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
820
821 'load_classes;' static schema detected, turning off 'use_namespaces'.
822
823 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
824 variable to disable this warning.
825
826 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
827 details.
828 EOF
829         $self->use_namespaces(0);
830     }
831     elsif ($load_classes && $self->use_namespaces) {
832         $self->_upgrading_from_load_classes(1);
833     }
834     elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
835         $self->_downgrading_to_load_classes(
836             $result_namespace || 'Result'
837         );
838     }
839     elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
840         if (not $self->result_namespace) {
841             $self->result_namespace($result_namespace || 'Result');
842         }
843         elsif ($result_namespace ne $self->result_namespace) {
844             $self->_rewriting_result_namespace(
845                 $result_namespace || 'Result'
846             );
847         }
848     }
849
850     # XXX when we go past .0 this will need fixing
851     my ($v) = $old_ver =~ /([1-9])/;
852     $v = "v$v";
853
854     return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
855
856     if (not %{ $self->naming }) {
857         warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
858
859 Version $old_ver static schema detected, turning on backcompat mode.
860
861 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
862 to disable this warning.
863
864 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
865
866 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
867 from version 0.04006.
868 EOF
869
870         $self->naming->{relationships}    ||= $v;
871         $self->naming->{monikers}         ||= $v;
872         $self->naming->{column_accessors} ||= $v;
873
874         $self->schema_version_to_dump($old_ver);
875     }
876     else {
877         $self->_upgrading_from($v);
878     }
879 }
880
881 sub _validate_class_args {
882     my $self = shift;
883
884     foreach my $k (@CLASS_ARGS) {
885         next unless $self->$k;
886
887         my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
888         $self->_validate_classes($k, \@classes);
889     }
890 }
891
892 sub _validate_result_components_map {
893     my $self = shift;
894
895     foreach my $classes (values %{ $self->result_components_map }) {
896         $self->_validate_classes('result_components_map', $classes);
897     }
898 }
899
900 sub _validate_result_roles_map {
901     my $self = shift;
902
903     foreach my $classes (values %{ $self->result_roles_map }) {
904         $self->_validate_classes('result_roles_map', $classes);
905     }
906 }
907
908 sub _validate_classes {
909     my $self = shift;
910     my $key  = shift;
911     my $classes = shift;
912
913     # make a copy to not destroy original
914     my @classes = @$classes;
915
916     foreach my $c (@classes) {
917         # components default to being under the DBIx::Class namespace unless they
918         # are preceeded with a '+'
919         if ( $key =~ m/component/ && $c !~ s/^\+// ) {
920             $c = 'DBIx::Class::' . $c;
921         }
922
923         # 1 == installed, 0 == not installed, undef == invalid classname
924         my $installed = Class::Inspector->installed($c);
925         if ( defined($installed) ) {
926             if ( $installed == 0 ) {
927                 croak qq/$c, as specified in the loader option "$key", is not installed/;
928             }
929         } else {
930             croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
931         }
932     }
933 }
934
935
936 sub _find_file_in_inc {
937     my ($self, $file) = @_;
938
939     foreach my $prefix (@INC) {
940         my $fullpath = File::Spec->catfile($prefix, $file);
941         return $fullpath if -f $fullpath
942             # abs_path throws on Windows for nonexistant files
943             and (try { Cwd::abs_path($fullpath) }) ne
944                ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
945     }
946
947     return;
948 }
949
950 sub _find_class_in_inc {
951     my ($self, $class) = @_;
952
953     return $self->_find_file_in_inc(class_path($class));
954 }
955
956 sub _rewriting {
957     my $self = shift;
958
959     return $self->_upgrading_from
960         || $self->_upgrading_from_load_classes
961         || $self->_downgrading_to_load_classes
962         || $self->_rewriting_result_namespace
963     ;
964 }
965
966 sub _rewrite_old_classnames {
967     my ($self, $code) = @_;
968
969     return $code unless $self->_rewriting;
970
971     my %old_classes = reverse %{ $self->_upgrading_classes };
972
973     my $re = join '|', keys %old_classes;
974     $re = qr/\b($re)\b/;
975
976     $code =~ s/$re/$old_classes{$1} || $1/eg;
977
978     return $code;
979 }
980
981 sub _load_external {
982     my ($self, $class) = @_;
983
984     return if $self->{skip_load_external};
985
986     # so that we don't load our own classes, under any circumstances
987     local *INC = [ grep $_ ne $self->dump_directory, @INC ];
988
989     my $real_inc_path = $self->_find_class_in_inc($class);
990
991     my $old_class = $self->_upgrading_classes->{$class}
992         if $self->_rewriting;
993
994     my $old_real_inc_path = $self->_find_class_in_inc($old_class)
995         if $old_class && $old_class ne $class;
996
997     return unless $real_inc_path || $old_real_inc_path;
998
999     if ($real_inc_path) {
1000         # If we make it to here, we loaded an external definition
1001         warn qq/# Loaded external class definition for '$class'\n/
1002             if $self->debug;
1003
1004         my $code = $self->_rewrite_old_classnames(scalar slurp $real_inc_path);
1005
1006         if ($self->dynamic) { # load the class too
1007             eval_package_without_redefine_warnings($class, $code);
1008         }
1009
1010         $self->_ext_stmt($class,
1011           qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1012          .qq|# They are now part of the custom portion of this file\n|
1013          .qq|# for you to hand-edit.  If you do not either delete\n|
1014          .qq|# this section or remove that file from \@INC, this section\n|
1015          .qq|# will be repeated redundantly when you re-create this\n|
1016          .qq|# file again via Loader!  See skip_load_external to disable\n|
1017          .qq|# this feature.\n|
1018         );
1019         chomp $code;
1020         $self->_ext_stmt($class, $code);
1021         $self->_ext_stmt($class,
1022             qq|# End of lines loaded from '$real_inc_path' |
1023         );
1024     }
1025
1026     if ($old_real_inc_path) {
1027         my $code = slurp $old_real_inc_path;
1028
1029         $self->_ext_stmt($class, <<"EOF");
1030
1031 # These lines were loaded from '$old_real_inc_path',
1032 # based on the Result class name that would have been created by an older
1033 # version of the Loader. For a static schema, this happens only once during
1034 # upgrade. See skip_load_external to disable this feature.
1035 EOF
1036
1037         $code = $self->_rewrite_old_classnames($code);
1038
1039         if ($self->dynamic) {
1040             warn <<"EOF";
1041
1042 Detected external content in '$old_real_inc_path', a class name that would have
1043 been used by an older version of the Loader.
1044
1045 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1046 new name of the Result.
1047 EOF
1048             eval_package_without_redefine_warnings($class, $code);
1049         }
1050
1051         chomp $code;
1052         $self->_ext_stmt($class, $code);
1053         $self->_ext_stmt($class,
1054             qq|# End of lines loaded from '$old_real_inc_path' |
1055         );
1056     }
1057 }
1058
1059 =head2 load
1060
1061 Does the actual schema-construction work.
1062
1063 =cut
1064
1065 sub load {
1066     my $self = shift;
1067
1068     $self->_load_tables(
1069         $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1070     );
1071 }
1072
1073 =head2 rescan
1074
1075 Arguments: schema
1076
1077 Rescan the database for changes. Returns a list of the newly added table
1078 monikers.
1079
1080 The schema argument should be the schema class or object to be affected.  It
1081 should probably be derived from the original schema_class used during L</load>.
1082
1083 =cut
1084
1085 sub rescan {
1086     my ($self, $schema) = @_;
1087
1088     $self->{schema} = $schema;
1089     $self->_relbuilder->{schema} = $schema;
1090
1091     my @created;
1092     my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1093
1094     foreach my $table (@current) {
1095         if(!exists $self->{_tables}->{$table}) {
1096             push(@created, $table);
1097         }
1098     }
1099
1100     my %current;
1101     @current{@current} = ();
1102     foreach my $table (keys %{ $self->{_tables} }) {
1103         if (not exists $current{$table}) {
1104             $self->_unregister_source_for_table($table);
1105         }
1106     }
1107
1108     delete $self->{_dump_storage};
1109     delete $self->{_relations_started};
1110
1111     my $loaded = $self->_load_tables(@current);
1112
1113     return map { $self->monikers->{$_} } @created;
1114 }
1115
1116 sub _relbuilder {
1117     my ($self) = @_;
1118
1119     return if $self->{skip_relationships};
1120
1121     return $self->{relbuilder} ||= do {
1122
1123         no warnings 'uninitialized';
1124         my $relbuilder_suff =
1125             {qw{
1126                 v4  ::Compat::v0_040
1127                 v5  ::Compat::v0_05
1128                 v6  ::Compat::v0_06
1129             }}
1130             ->{ $self->naming->{relationships}};
1131
1132         my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1133         $self->ensure_class_loaded($relbuilder_class);
1134         $relbuilder_class->new( $self );
1135
1136     };
1137 }
1138
1139 sub _load_tables {
1140     my ($self, @tables) = @_;
1141
1142     # Save the new tables to the tables list
1143     foreach (@tables) {
1144         $self->{_tables}->{$_} = 1;
1145     }
1146
1147     $self->_make_src_class($_) for @tables;
1148
1149     # sanity-check for moniker clashes
1150     my $inverse_moniker_idx;
1151     for (keys %{$self->monikers}) {
1152       push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1153     }
1154
1155     my @clashes;
1156     for (keys %$inverse_moniker_idx) {
1157       my $tables = $inverse_moniker_idx->{$_};
1158       if (@$tables > 1) {
1159         push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1160           join (', ', map { "'$_'" } @$tables),
1161           $_,
1162         );
1163       }
1164     }
1165
1166     if (@clashes) {
1167       die   'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1168           . 'Either change the naming style, or supply an explicit moniker_map: '
1169           . join ('; ', @clashes)
1170           . "\n"
1171       ;
1172     }
1173
1174
1175     $self->_setup_src_meta($_) for @tables;
1176
1177     if(!$self->skip_relationships) {
1178         # The relationship loader needs a working schema
1179         $self->{quiet} = 1;
1180         local $self->{dump_directory} = $self->{temp_directory};
1181         $self->_reload_classes(\@tables);
1182         $self->_load_relationships($_) for @tables;
1183         $self->_relbuilder->cleanup;
1184         $self->{quiet} = 0;
1185
1186         # Remove that temp dir from INC so it doesn't get reloaded
1187         @INC = grep $_ ne $self->dump_directory, @INC;
1188     }
1189
1190     $self->_load_roles($_) for @tables;
1191
1192     $self->_load_external($_)
1193         for map { $self->classes->{$_} } @tables;
1194
1195     # Reload without unloading first to preserve any symbols from external
1196     # packages.
1197     $self->_reload_classes(\@tables, { unload => 0 });
1198
1199     # Drop temporary cache
1200     delete $self->{_cache};
1201
1202     return \@tables;
1203 }
1204
1205 sub _reload_classes {
1206     my ($self, $tables, $opts) = @_;
1207
1208     my @tables = @$tables;
1209
1210     my $unload = $opts->{unload};
1211     $unload = 1 unless defined $unload;
1212
1213     # so that we don't repeat custom sections
1214     @INC = grep $_ ne $self->dump_directory, @INC;
1215
1216     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1217
1218     unshift @INC, $self->dump_directory;
1219     
1220     my @to_register;
1221     my %have_source = map { $_ => $self->schema->source($_) }
1222         $self->schema->sources;
1223
1224     for my $table (@tables) {
1225         my $moniker = $self->monikers->{$table};
1226         my $class = $self->classes->{$table};
1227         
1228         {
1229             no warnings 'redefine';
1230             local *Class::C3::reinitialize = sub {};  # to speed things up, reinitialized below
1231             use warnings;
1232
1233             if (my $mc = $self->_moose_metaclass($class)) {
1234                 $mc->make_mutable;
1235             }
1236             Class::Unload->unload($class) if $unload;
1237             my ($source, $resultset_class);
1238             if (
1239                 ($source = $have_source{$moniker})
1240                 && ($resultset_class = $source->resultset_class)
1241                 && ($resultset_class ne 'DBIx::Class::ResultSet')
1242             ) {
1243                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1244                 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1245                     $mc->make_mutable;
1246                 }
1247                 Class::Unload->unload($resultset_class) if $unload;
1248                 $self->_reload_class($resultset_class) if $has_file;
1249             }
1250             $self->_reload_class($class);
1251         }
1252         push @to_register, [$moniker, $class];
1253     }
1254
1255     Class::C3->reinitialize;
1256     for (@to_register) {
1257         $self->schema->register_class(@$_);
1258     }
1259 }
1260
1261 sub _moose_metaclass {
1262   return undef unless $INC{'Class/MOP.pm'};   # if CMOP is not loaded the class could not have loaded in the 1st place
1263
1264   my $class = $_[1];
1265
1266   my $mc = try { Class::MOP::class_of($class) }
1267     or return undef;
1268
1269   return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1270 }
1271
1272 # We use this instead of ensure_class_loaded when there are package symbols we
1273 # want to preserve.
1274 sub _reload_class {
1275     my ($self, $class) = @_;
1276
1277     delete $INC{ +class_path($class) };
1278
1279     try {
1280         eval_package_without_redefine_warnings ($class, "require $class");
1281     }
1282     catch {
1283         my $source = slurp $self->_get_dump_filename($class);
1284         die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1285     };
1286 }
1287
1288 sub _get_dump_filename {
1289     my ($self, $class) = (@_);
1290
1291     $class =~ s{::}{/}g;
1292     return $self->dump_directory . q{/} . $class . q{.pm};
1293 }
1294
1295 =head2 get_dump_filename
1296
1297 Arguments: class
1298
1299 Returns the full path to the file for a class that the class has been or will
1300 be dumped to. This is a file in a temp dir for a dynamic schema.
1301
1302 =cut
1303
1304 sub get_dump_filename {
1305     my ($self, $class) = (@_);
1306
1307     local $self->{dump_directory} = $self->real_dump_directory;
1308
1309     return $self->_get_dump_filename($class);
1310 }
1311
1312 sub _ensure_dump_subdirs {
1313     my ($self, $class) = (@_);
1314
1315     my @name_parts = split(/::/, $class);
1316     pop @name_parts; # we don't care about the very last element,
1317                      # which is a filename
1318
1319     my $dir = $self->dump_directory;
1320     while (1) {
1321         if(!-d $dir) {
1322             mkdir($dir) or croak "mkdir('$dir') failed: $!";
1323         }
1324         last if !@name_parts;
1325         $dir = File::Spec->catdir($dir, shift @name_parts);
1326     }
1327 }
1328
1329 sub _dump_to_dir {
1330     my ($self, @classes) = @_;
1331
1332     my $schema_class = $self->schema_class;
1333     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1334
1335     my $target_dir = $self->dump_directory;
1336     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1337         unless $self->{dynamic} or $self->{quiet};
1338
1339     my $schema_text =
1340           qq|package $schema_class;\n\n|
1341         . qq|# Created by DBIx::Class::Schema::Loader\n|
1342         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1343
1344     if ($self->use_moose) {
1345         $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1346     }
1347     else {
1348         $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1349     }
1350
1351     if ($self->use_namespaces) {
1352         $schema_text .= qq|__PACKAGE__->load_namespaces|;
1353         my $namespace_options;
1354
1355         my @attr = qw/resultset_namespace default_resultset_class/;
1356
1357         unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1358
1359         for my $attr (@attr) {
1360             if ($self->$attr) {
1361                 $namespace_options .= qq|    $attr => '| . $self->$attr . qq|',\n|
1362             }
1363         }
1364         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1365         $schema_text .= qq|;\n|;
1366     }
1367     else {
1368         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1369     }
1370
1371     {
1372         local $self->{version_to_dump} = $self->schema_version_to_dump;
1373         $self->_write_classfile($schema_class, $schema_text, 1);
1374     }
1375
1376     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1377
1378     foreach my $src_class (@classes) {
1379         my $src_text = 
1380               qq|package $src_class;\n\n|
1381             . qq|# Created by DBIx::Class::Schema::Loader\n|
1382             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1383             . qq|use strict;\nuse warnings;\n\n|;
1384         if ($self->use_moose) {
1385             $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1386
1387             # these options 'use base' which is compile time
1388             if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1389                 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n\n|;
1390             }
1391             else {
1392                 $src_text .= qq|\nextends '$result_base_class';\n\n|;
1393             }
1394         }
1395         else {
1396              $src_text .= qq|use base '$result_base_class';\n\n|;
1397         }
1398         $self->_write_classfile($src_class, $src_text);
1399     }
1400
1401     # remove Result dir if downgrading from use_namespaces, and there are no
1402     # files left.
1403     if (my $result_ns = $self->_downgrading_to_load_classes
1404                         || $self->_rewriting_result_namespace) {
1405         my $result_namespace = $self->_result_namespace(
1406             $schema_class,
1407             $result_ns,
1408         );
1409
1410         (my $result_dir = $result_namespace) =~ s{::}{/}g;
1411         $result_dir = $self->dump_directory . '/' . $result_dir;
1412
1413         unless (my @files = glob "$result_dir/*") {
1414             rmdir $result_dir;
1415         }
1416     }
1417
1418     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1419
1420 }
1421
1422 sub _sig_comment {
1423     my ($self, $version, $ts) = @_;
1424     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1425          . qq| v| . $version
1426          . q| @ | . $ts 
1427          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1428 }
1429
1430 sub _write_classfile {
1431     my ($self, $class, $text, $is_schema) = @_;
1432
1433     my $filename = $self->_get_dump_filename($class);
1434     $self->_ensure_dump_subdirs($class);
1435
1436     if (-f $filename && $self->really_erase_my_files) {
1437         warn "Deleting existing file '$filename' due to "
1438             . "'really_erase_my_files' setting\n" unless $self->{quiet};
1439         unlink($filename);
1440     }
1441
1442     my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1443         = $self->_parse_generated_file($filename);
1444
1445     if (! $old_gen && -f $filename) {
1446         croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1447             . " it does not appear to have been generated by Loader"
1448     }
1449
1450     my $custom_content = $old_custom || '';
1451
1452     # prepend extra custom content from a *renamed* class (singularization effect)
1453     if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1454         my $old_filename = $self->_get_dump_filename($renamed_class);
1455
1456         if (-f $old_filename) {
1457             my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1458
1459             $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1460
1461             $custom_content = join ("\n", '', $extra_custom, $custom_content)
1462                 if $extra_custom;
1463
1464             unlink $old_filename;
1465         }
1466     }
1467
1468     $custom_content ||= $self->_default_custom_content($is_schema);
1469
1470     # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1471     # If there is already custom content, which does not have the Moose content, add it.
1472     if ($self->use_moose) {
1473
1474         my $non_moose_custom_content = do {
1475             local $self->{use_moose} = 0;
1476             $self->_default_custom_content;
1477         };
1478
1479         if ($custom_content eq $non_moose_custom_content) {
1480             $custom_content = $self->_default_custom_content($is_schema);
1481         }
1482         elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1483             $custom_content .= $self->_default_custom_content($is_schema);
1484         }
1485     }
1486     elsif (defined $self->use_moose && $old_gen) {
1487         croak 'It is not possible to "downgrade" a schema that was loaded with use_moose => 1 to use_moose => 0, due to differing custom content'
1488             if $old_gen =~ /use \s+ MooseX?\b/x;
1489     }
1490
1491     $custom_content = $self->_rewrite_old_classnames($custom_content);
1492
1493     $text .= qq|$_\n|
1494         for @{$self->{_dump_storage}->{$class} || []};
1495
1496     # Check and see if the dump is infact differnt
1497
1498     my $compare_to;
1499     if ($old_md5) {
1500       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1501       if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1502         return unless $self->_upgrading_from && $is_schema;
1503       }
1504     }
1505
1506     $text .= $self->_sig_comment(
1507       $self->version_to_dump,
1508       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1509     );
1510
1511     open(my $fh, '>', $filename)
1512         or croak "Cannot open '$filename' for writing: $!";
1513
1514     # Write the top half and its MD5 sum
1515     print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1516
1517     # Write out anything loaded via external partial class file in @INC
1518     print $fh qq|$_\n|
1519         for @{$self->{_ext_storage}->{$class} || []};
1520
1521     # Write out any custom content the user has added
1522     print $fh $custom_content;
1523
1524     close($fh)
1525         or croak "Error closing '$filename': $!";
1526 }
1527
1528 sub _default_moose_custom_content {
1529     my ($self, $is_schema) = @_;
1530
1531     if (not $is_schema) {
1532         return qq|\n__PACKAGE__->meta->make_immutable;|;
1533     }
1534     
1535     return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1536 }
1537
1538 sub _default_custom_content {
1539     my ($self, $is_schema) = @_;
1540     my $default = qq|\n\n# You can replace this text with custom|
1541          . qq| code or comments, and it will be preserved on regeneration|;
1542     if ($self->use_moose) {
1543         $default .= $self->_default_moose_custom_content($is_schema);
1544     }
1545     $default .= qq|\n1;\n|;
1546     return $default;
1547 }
1548
1549 sub _parse_generated_file {
1550     my ($self, $fn) = @_;
1551
1552     return unless -f $fn;
1553
1554     open(my $fh, '<', $fn)
1555         or croak "Cannot open '$fn' for reading: $!";
1556
1557     my $mark_re =
1558         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1559
1560     my ($md5, $ts, $ver, $gen);
1561     while(<$fh>) {
1562         if(/$mark_re/) {
1563             my $pre_md5 = $1;
1564             $md5 = $2;
1565
1566             # Pull out the version and timestamp from the line above
1567             ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1568
1569             $gen .= $pre_md5;
1570             croak "Checksum mismatch in '$fn', 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"
1571                 if !$self->overwrite_modifications && Digest::MD5::md5_base64($gen) ne $md5;
1572
1573             last;
1574         }
1575         else {
1576             $gen .= $_;
1577         }
1578     }
1579
1580     my $custom = do { local $/; <$fh> }
1581         if $md5;
1582
1583     close ($fh);
1584
1585     return ($gen, $md5, $ver, $ts, $custom);
1586 }
1587
1588 sub _use {
1589     my $self = shift;
1590     my $target = shift;
1591
1592     foreach (@_) {
1593         warn "$target: use $_;" if $self->debug;
1594         $self->_raw_stmt($target, "use $_;");
1595     }
1596 }
1597
1598 sub _inject {
1599     my $self = shift;
1600     my $target = shift;
1601
1602     my $blist = join(q{ }, @_);
1603
1604     return unless $blist;
1605
1606     warn "$target: use base qw/$blist/;" if $self->debug;
1607     $self->_raw_stmt($target, "use base qw/$blist/;");
1608 }
1609
1610 sub _with {
1611     my $self = shift;
1612     my $target = shift;
1613
1614     my $rlist = join(q{, }, map { qq{'$_'} } @_);
1615
1616     return unless $rlist;
1617
1618     warn "$target: with $rlist;" if $self->debug;
1619     $self->_raw_stmt($target, "\nwith $rlist;");
1620 }
1621
1622 sub _result_namespace {
1623     my ($self, $schema_class, $ns) = @_;
1624     my @result_namespace;
1625
1626     if ($ns =~ /^\+(.*)/) {
1627         # Fully qualified namespace
1628         @result_namespace = ($1)
1629     }
1630     else {
1631         # Relative namespace
1632         @result_namespace = ($schema_class, $ns);
1633     }
1634
1635     return wantarray ? @result_namespace : join '::', @result_namespace;
1636 }
1637
1638 # Create class with applicable bases, setup monikers, etc
1639 sub _make_src_class {
1640     my ($self, $table) = @_;
1641
1642     my $schema       = $self->schema;
1643     my $schema_class = $self->schema_class;
1644
1645     my $table_moniker = $self->_table2moniker($table);
1646     my @result_namespace = ($schema_class);
1647     if ($self->use_namespaces) {
1648         my $result_namespace = $self->result_namespace || 'Result';
1649         @result_namespace = $self->_result_namespace(
1650             $schema_class,
1651             $result_namespace,
1652         );
1653     }
1654     my $table_class = join(q{::}, @result_namespace, $table_moniker);
1655
1656     if ((my $upgrading_v = $self->_upgrading_from)
1657             || $self->_rewriting) {
1658         local $self->naming->{monikers} = $upgrading_v
1659             if $upgrading_v;
1660
1661         my @result_namespace = @result_namespace;
1662         if ($self->_upgrading_from_load_classes) {
1663             @result_namespace = ($schema_class);
1664         }
1665         elsif (my $ns = $self->_downgrading_to_load_classes) {
1666             @result_namespace = $self->_result_namespace(
1667                 $schema_class,
1668                 $ns,
1669             );
1670         }
1671         elsif ($ns = $self->_rewriting_result_namespace) {
1672             @result_namespace = $self->_result_namespace(
1673                 $schema_class,
1674                 $ns,
1675             );
1676         }
1677
1678         my $old_class = join(q{::}, @result_namespace,
1679             $self->_table2moniker($table));
1680
1681         $self->_upgrading_classes->{$table_class} = $old_class
1682             unless $table_class eq $old_class;
1683     }
1684
1685     $self->classes->{$table}  = $table_class;
1686     $self->monikers->{$table} = $table_moniker;
1687
1688     $self->_use   ($table_class, @{$self->additional_classes});
1689     $self->_inject($table_class, @{$self->left_base_classes});
1690
1691     my @components = @{ $self->components || [] };
1692
1693     push @components, @{ $self->result_components_map->{$table_moniker} }
1694         if exists $self->result_components_map->{$table_moniker};
1695
1696     $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
1697
1698     $self->_inject($table_class, @{$self->additional_base_classes});
1699 }
1700
1701 sub _is_result_class_method {
1702     my ($self, $name, $table_name) = @_;
1703
1704     my $table_moniker = $table_name ? $self->_table2moniker($table_name) : '';
1705
1706     $self->_result_class_methods({})
1707         if not defined $self->_result_class_methods;
1708
1709     if (not exists $self->_result_class_methods->{$table_moniker}) {
1710         my (@methods, %methods);
1711         my $base       = $self->result_base_class || 'DBIx::Class::Core';
1712
1713         my @components = @{ $self->components || [] };
1714
1715         push @components, @{ $self->result_components_map->{$table_moniker} }
1716             if exists $self->result_components_map->{$table_moniker};
1717
1718         for my $c (@components) {
1719             $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
1720         }
1721
1722         my @roles = @{ $self->result_roles || [] };
1723
1724         push @roles, @{ $self->result_roles_map->{$table_moniker} }
1725             if exists $self->result_roles_map->{$table_moniker};
1726
1727         for my $class ($base, @components,
1728                        ($self->use_moose ? 'Moose::Object' : ()), @roles) {
1729             $self->ensure_class_loaded($class);
1730
1731             push @methods, @{ Class::Inspector->methods($class) || [] };
1732         }
1733
1734         push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1735
1736         @methods{@methods} = ();
1737
1738         $self->_result_class_methods->{$table_moniker} = \%methods;
1739     }
1740     my $result_methods = $self->_result_class_methods->{$table_moniker};
1741
1742     return exists $result_methods->{$name};
1743 }
1744
1745 sub _resolve_col_accessor_collisions {
1746     my ($self, $table, $col_info) = @_;
1747
1748     my $table_name = ref $table ? $$table : $table;
1749
1750     while (my ($col, $info) = each %$col_info) {
1751         my $accessor = $info->{accessor} || $col;
1752
1753         next if $accessor eq 'id'; # special case (very common column)
1754
1755         if ($self->_is_result_class_method($accessor, $table_name)) {
1756             my $mapped = 0;
1757
1758             if (my $map = $self->col_collision_map) {
1759                 for my $re (keys %$map) {
1760                     if (my @matches = $col =~ /$re/) {
1761                         $info->{accessor} = sprintf $map->{$re}, @matches;
1762                         $mapped = 1;
1763                     }
1764                 }
1765             }
1766
1767             if (not $mapped) {
1768                 warn <<"EOF";
1769 Column '$col' in table '$table_name' collides with an inherited method.
1770 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1771 EOF
1772                 $info->{accessor} = undef;
1773             }
1774         }
1775     }
1776 }
1777
1778 # use the same logic to run moniker_map, col_accessor_map, and
1779 # relationship_name_map
1780 sub _run_user_map {
1781     my ( $self, $map, $default_code, $ident, @extra ) = @_;
1782
1783     my $default_ident = $default_code->( $ident, @extra );
1784     my $new_ident;
1785     if( $map && ref $map eq 'HASH' ) {
1786         $new_ident = $map->{ $ident };
1787     }
1788     elsif( $map && ref $map eq 'CODE' ) {
1789         $new_ident = $map->( $ident, $default_ident, @extra );
1790     }
1791
1792     $new_ident ||= $default_ident;
1793
1794     return $new_ident;
1795 }
1796
1797 sub _default_column_accessor_name {
1798     my ( $self, $column_name ) = @_;
1799
1800     my $accessor_name = $column_name;
1801     $accessor_name =~ s/\W+/_/g;
1802
1803     if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
1804         # older naming just lc'd the col accessor and that's all.
1805         return lc $accessor_name;
1806     }
1807
1808     return join '_', map lc, split_name $column_name;
1809
1810 }
1811
1812 sub _make_column_accessor_name {
1813     my ($self, $column_name, $column_context_info ) = @_;
1814
1815     my $accessor = $self->_run_user_map(
1816         $self->col_accessor_map,
1817         sub { $self->_default_column_accessor_name( shift ) },
1818         $column_name,
1819         $column_context_info,
1820        );
1821
1822     return $accessor;
1823 }
1824
1825 # Set up metadata (cols, pks, etc)
1826 sub _setup_src_meta {
1827     my ($self, $table) = @_;
1828
1829     my $schema       = $self->schema;
1830     my $schema_class = $self->schema_class;
1831
1832     my $table_class   = $self->classes->{$table};
1833     my $table_moniker = $self->monikers->{$table};
1834
1835     my $table_name = $table;
1836     my $name_sep   = $self->schema->storage->sql_maker->name_sep;
1837
1838     if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1839         $table_name = \ $self->_quote_table_name($table_name);
1840     }
1841
1842     my $full_table_name = ($self->qualify_objects ? ($self->db_schema . '.') : '') . (ref $table_name ? $$table_name : $table_name);
1843
1844     # be careful to not create refs Data::Dump can "optimize"
1845     $full_table_name    = \do {"".$full_table_name} if ref $table_name;
1846
1847     $self->_dbic_stmt($table_class, 'table', $full_table_name);
1848
1849     my $cols     = $self->_table_columns($table);
1850     my $col_info = $self->__columns_info_for($table);
1851
1852     ### generate all the column accessor names
1853     while (my ($col, $info) = each %$col_info) {
1854         # hashref of other info that could be used by
1855         # user-defined accessor map functions
1856         my $context = {
1857             table_class     => $table_class,
1858             table_moniker   => $table_moniker,
1859             table_name      => $table_name,
1860             full_table_name => $full_table_name,
1861             schema_class    => $schema_class,
1862             column_info     => $info,
1863         };
1864
1865         $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
1866     }
1867
1868     $self->_resolve_col_accessor_collisions($full_table_name, $col_info);
1869
1870     # prune any redundant accessor names
1871     while (my ($col, $info) = each %$col_info) {
1872         no warnings 'uninitialized';
1873         delete $info->{accessor} if $info->{accessor} eq $col;
1874     }
1875
1876     my $fks = $self->_table_fk_info($table);
1877
1878     foreach my $fkdef (@$fks) {
1879         for my $col (@{ $fkdef->{local_columns} }) {
1880             $col_info->{$col}{is_foreign_key} = 1;
1881         }
1882     }
1883
1884     my $pks = $self->_table_pk_info($table) || [];
1885
1886     foreach my $pkcol (@$pks) {
1887         $col_info->{$pkcol}{is_nullable} = 0;
1888     }
1889
1890     $self->_dbic_stmt(
1891         $table_class,
1892         'add_columns',
1893         map { $_, ($col_info->{$_}||{}) } @$cols
1894     );
1895
1896     my %uniq_tag; # used to eliminate duplicate uniqs
1897
1898     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1899           : carp("$table has no primary key");
1900     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1901
1902     my $uniqs = $self->_table_uniq_info($table) || [];
1903     for (@$uniqs) {
1904         my ($name, $cols) = @$_;
1905         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1906         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1907     }
1908
1909 }
1910
1911 sub __columns_info_for {
1912     my ($self, $table) = @_;
1913
1914     my $result = $self->_columns_info_for($table);
1915
1916     while (my ($col, $info) = each %$result) {
1917         $info = { %$info, %{ $self->_custom_column_info  ($table, $col, $info) } };
1918         $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1919
1920         $result->{$col} = $info;
1921     }
1922
1923     return $result;
1924 }
1925
1926 =head2 tables
1927
1928 Returns a sorted list of loaded tables, using the original database table
1929 names.
1930
1931 =cut
1932
1933 sub tables {
1934     my $self = shift;
1935
1936     return keys %{$self->_tables};
1937 }
1938
1939 # Make a moniker from a table
1940 sub _default_table2moniker {
1941     no warnings 'uninitialized';
1942     my ($self, $table) = @_;
1943
1944     if ($self->naming->{monikers} eq 'v4') {
1945         return join '', map ucfirst, split /[\W_]+/, lc $table;
1946     }
1947     elsif ($self->naming->{monikers} eq 'v5') {
1948         return join '', map ucfirst, split /[\W_]+/,
1949             Lingua::EN::Inflect::Number::to_S(lc $table);
1950     }
1951     elsif ($self->naming->{monikers} eq 'v6') {
1952         (my $as_phrase = lc $table) =~ s/_+/ /g;
1953         my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1954
1955         return join '', map ucfirst, split /\W+/, $inflected;
1956     }
1957
1958     my @words = map lc, split_name $table;
1959     my $as_phrase = join ' ', @words;
1960
1961     my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1962
1963     return join '', map ucfirst, split /\W+/, $inflected;
1964 }
1965
1966 sub _table2moniker {
1967     my ( $self, $table ) = @_;
1968
1969     $self->_run_user_map(
1970         $self->moniker_map,
1971         sub { $self->_default_table2moniker( shift ) },
1972         $table
1973        );
1974 }
1975
1976 sub _load_relationships {
1977     my ($self, $table) = @_;
1978
1979     my $tbl_fk_info = $self->_table_fk_info($table);
1980     foreach my $fkdef (@$tbl_fk_info) {
1981         $fkdef->{remote_source} =
1982             $self->monikers->{delete $fkdef->{remote_table}};
1983     }
1984     my $tbl_uniq_info = $self->_table_uniq_info($table);
1985
1986     my $local_moniker = $self->monikers->{$table};
1987     my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1988
1989     foreach my $src_class (sort keys %$rel_stmts) {
1990         my $src_stmts = $rel_stmts->{$src_class};
1991         foreach my $stmt (@$src_stmts) {
1992             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1993         }
1994     }
1995 }
1996
1997 sub _load_roles {
1998     my ($self, $table) = @_;
1999
2000     my $table_moniker = $self->monikers->{$table};
2001     my $table_class   = $self->classes->{$table};
2002
2003     my @roles = @{ $self->result_roles || [] };
2004     push @roles, @{ $self->result_roles_map->{$table_moniker} }
2005         if exists $self->result_roles_map->{$table_moniker};
2006
2007     $self->_with($table_class, @roles) if @roles;
2008 }
2009
2010 # Overload these in driver class:
2011
2012 # Returns an arrayref of column names
2013 sub _table_columns { croak "ABSTRACT METHOD" }
2014
2015 # Returns arrayref of pk col names
2016 sub _table_pk_info { croak "ABSTRACT METHOD" }
2017
2018 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2019 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2020
2021 # Returns an arrayref of foreign key constraints, each
2022 #   being a hashref with 3 keys:
2023 #   local_columns (arrayref), remote_columns (arrayref), remote_table
2024 sub _table_fk_info { croak "ABSTRACT METHOD" }
2025
2026 # Returns an array of lower case table names
2027 sub _tables_list { croak "ABSTRACT METHOD" }
2028
2029 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2030 sub _dbic_stmt {
2031     my $self   = shift;
2032     my $class  = shift;
2033     my $method = shift;
2034
2035     # generate the pod for this statement, storing it with $self->_pod
2036     $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2037
2038     my $args = dump(@_);
2039     $args = '(' . $args . ')' if @_ < 2;
2040     my $stmt = $method . $args . q{;};
2041
2042     warn qq|$class\->$stmt\n| if $self->debug;
2043     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2044     return;
2045 }
2046
2047 # generates the accompanying pod for a DBIC class method statement,
2048 # storing it with $self->_pod
2049 sub _make_pod {
2050     my $self   = shift;
2051     my $class  = shift;
2052     my $method = shift;
2053
2054     if ( $method eq 'table' ) {
2055         my ($table) = @_;
2056         my $pcm = $self->pod_comment_mode;
2057         my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2058         $comment = $self->__table_comment($table);
2059         $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2060         $comment_in_name   = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2061         $comment_in_desc   = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2062         $self->_pod( $class, "=head1 NAME" );
2063         my $table_descr = $class;
2064         $table_descr .= " - " . $comment if $comment and $comment_in_name;
2065         $self->{_class2table}{ $class } = $table;
2066         $self->_pod( $class, $table_descr );
2067         if ($comment and $comment_in_desc) {
2068             $self->_pod( $class, "=head1 DESCRIPTION" );
2069             $self->_pod( $class, $comment );
2070         }
2071         $self->_pod_cut( $class );
2072     } elsif ( $method eq 'add_columns' ) {
2073         $self->_pod( $class, "=head1 ACCESSORS" );
2074         my $col_counter = 0;
2075         my @cols = @_;
2076         while( my ($name,$attrs) = splice @cols,0,2 ) {
2077             $col_counter++;
2078             $self->_pod( $class, '=head2 ' . $name  );
2079             $self->_pod( $class,
2080                 join "\n", map {
2081                     my $s = $attrs->{$_};
2082                     $s = !defined $s          ? 'undef'             :
2083                         length($s) == 0       ? '(empty string)'    :
2084                         ref($s) eq 'SCALAR'   ? $$s                 :
2085                         ref($s)               ? dumper_squashed $s  :
2086                         looks_like_number($s) ? $s                  : qq{'$s'};
2087
2088                     "  $_: $s"
2089                  } sort keys %$attrs,
2090             );
2091             if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter, $name)) {
2092                 $self->_pod( $class, $comment );
2093             }
2094         }
2095         $self->_pod_cut( $class );
2096     } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2097         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2098         my ( $accessor, $rel_class ) = @_;
2099         $self->_pod( $class, "=head2 $accessor" );
2100         $self->_pod( $class, 'Type: ' . $method );
2101         $self->_pod( $class, "Related object: L<$rel_class>" );
2102         $self->_pod_cut( $class );
2103         $self->{_relations_started} { $class } = 1;
2104     }
2105 }
2106
2107 sub _filter_comment {
2108     my ($self, $txt) = @_;
2109
2110     $txt = '' if not defined $txt;
2111
2112     $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2113
2114     return $txt;
2115 }
2116
2117 sub __table_comment {
2118     my $self = shift;
2119
2120     if (my $code = $self->can('_table_comment')) {
2121         return $self->_filter_comment($self->$code(@_));
2122     }
2123     
2124     return '';
2125 }
2126
2127 sub __column_comment {
2128     my $self = shift;
2129
2130     if (my $code = $self->can('_column_comment')) {
2131         return $self->_filter_comment($self->$code(@_));
2132     }
2133
2134     return '';
2135 }
2136
2137 # Stores a POD documentation
2138 sub _pod {
2139     my ($self, $class, $stmt) = @_;
2140     $self->_raw_stmt( $class, "\n" . $stmt  );
2141 }
2142
2143 sub _pod_cut {
2144     my ($self, $class ) = @_;
2145     $self->_raw_stmt( $class, "\n=cut\n" );
2146 }
2147
2148 # Store a raw source line for a class (for dumping purposes)
2149 sub _raw_stmt {
2150     my ($self, $class, $stmt) = @_;
2151     push(@{$self->{_dump_storage}->{$class}}, $stmt);
2152 }
2153
2154 # Like above, but separately for the externally loaded stuff
2155 sub _ext_stmt {
2156     my ($self, $class, $stmt) = @_;
2157     push(@{$self->{_ext_storage}->{$class}}, $stmt);
2158 }
2159
2160 sub _quote_table_name {
2161     my ($self, $table) = @_;
2162
2163     my $qt = $self->schema->storage->sql_maker->quote_char;
2164
2165     return $table unless $qt;
2166
2167     if (ref $qt) {
2168         return $qt->[0] . $table . $qt->[1];
2169     }
2170
2171     return $qt . $table . $qt;
2172 }
2173
2174 sub _custom_column_info {
2175     my ( $self, $table_name, $column_name, $column_info ) = @_;
2176
2177     if (my $code = $self->custom_column_info) {
2178         return $code->($table_name, $column_name, $column_info) || {};
2179     }
2180     return {};
2181 }
2182
2183 sub _datetime_column_info {
2184     my ( $self, $table_name, $column_name, $column_info ) = @_;
2185     my $result = {};
2186     my $type = $column_info->{data_type} || '';
2187     if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2188             or ($type =~ /date|timestamp/i)) {
2189         $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2190         $result->{locale}   = $self->datetime_locale   if $self->datetime_locale;
2191     }
2192     return $result;
2193 }
2194
2195 sub _lc {
2196     my ($self, $name) = @_;
2197
2198     return $self->preserve_case ? $name : lc($name);
2199 }
2200
2201 sub _uc {
2202     my ($self, $name) = @_;
2203
2204     return $self->preserve_case ? $name : uc($name);
2205 }
2206
2207 sub _unregister_source_for_table {
2208     my ($self, $table) = @_;
2209
2210     try {
2211         local $@;
2212         my $schema = $self->schema;
2213         # in older DBIC it's a private method
2214         my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2215         $schema->$unregister($self->_table2moniker($table));
2216         delete $self->monikers->{$table};
2217         delete $self->classes->{$table};
2218         delete $self->_upgrading_classes->{$table};
2219         delete $self->{_tables}{$table};
2220     };
2221 }
2222
2223 # remove the dump dir from @INC on destruction
2224 sub DESTROY {
2225     my $self = shift;
2226
2227     @INC = grep $_ ne $self->dump_directory, @INC;
2228 }
2229
2230 =head2 monikers
2231
2232 Returns a hashref of loaded table to moniker mappings.  There will
2233 be two entries for each table, the original name and the "normalized"
2234 name, in the case that the two are different (such as databases
2235 that like uppercase table names, or preserve your original mixed-case
2236 definitions, or what-have-you).
2237
2238 =head2 classes
2239
2240 Returns a hashref of table to class mappings.  In some cases it will
2241 contain multiple entries per table for the original and normalized table
2242 names, as above in L</monikers>.
2243
2244 =head1 COLUMN ACCESSOR COLLISIONS
2245
2246 Occasionally you may have a column name that collides with a perl method, such
2247 as C<can>. In such cases, the default action is to set the C<accessor> of the
2248 column spec to C<undef>.
2249
2250 You can then name the accessor yourself by placing code such as the following
2251 below the md5:
2252
2253     __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2254
2255 Another option is to use the L</col_collision_map> option.
2256
2257 =head1 RELATIONSHIP NAME COLLISIONS
2258
2259 In very rare cases, you may get a collision between a generated relationship
2260 name and a method in your Result class, for example if you have a foreign key
2261 called C<belongs_to>.
2262
2263 This is a problem because relationship names are also relationship accessor
2264 methods in L<DBIx::Class>.
2265
2266 The default behavior is to append C<_rel> to the relationship name and print
2267 out a warning that refers to this text.
2268
2269 You can also control the renaming with the L</rel_collision_map> option.
2270
2271 =head1 SEE ALSO
2272
2273 L<DBIx::Class::Schema::Loader>
2274
2275 =head1 AUTHOR
2276
2277 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2278
2279 =head1 LICENSE
2280
2281 This library is free software; you can redistribute it and/or modify it under
2282 the same terms as Perl itself.
2283
2284 =cut
2285
2286 1;
2287 # vim:et sts=4 sw=4 tw=0: