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