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