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