don't set result_namespace if it's 'Result'
[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
2a8e93e9 24our $VERSION = '0.06000';
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
2a8e93e9 436my $CURRENT_V = 'v6';
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
2a8e93e9 649See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
650from version 0.04006.
a0e0a56a 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;
2a8e93e9 1092
1093 my @attr = qw/resultset_namespace default_resultset_class/;
1094
1095 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1096
1097 for my $attr (@attr) {
f44ecc2f 1098 if ($self->$attr) {
1099 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
1100 }
1101 }
1102 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1103 $schema_text .= qq|;\n|;
1104 }
1105 else {
1106 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
f44ecc2f 1107 }
996be9ee 1108
1c95b304 1109 {
1110 local $self->{version_to_dump} = $self->schema_version_to_dump;
68d49e50 1111 $self->_write_classfile($schema_class, $schema_text, 1);
1c95b304 1112 }
996be9ee 1113
2229729e 1114 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
9c9c2f2b 1115
af31090c 1116 foreach my $src_class (@classes) {
7cab3ab7 1117 my $src_text =
1118 qq|package $src_class;\n\n|
b4dcbcc5 1119 . qq|# Created by DBIx::Class::Schema::Loader\n|
1120 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
7cab3ab7 1121 . qq|use strict;\nuse warnings;\n\n|
9c9c2f2b 1122 . qq|use base '$result_base_class';\n\n|;
996be9ee 1123
7cab3ab7 1124 $self->_write_classfile($src_class, $src_text);
02356864 1125 }
996be9ee 1126
a4b94090 1127 # remove Result dir if downgrading from use_namespaces, and there are no
1128 # files left.
b5f1b43c 1129 if (my $result_ns = $self->_downgrading_to_load_classes
1130 || $self->_rewriting_result_namespace) {
540a8149 1131 my $result_namespace = $self->_result_namespace(
1132 $schema_class,
1133 $result_ns,
1134 );
a4b94090 1135
540a8149 1136 (my $result_dir = $result_namespace) =~ s{::}{/}g;
a4b94090 1137 $result_dir = $self->dump_directory . '/' . $result_dir;
1138
1139 unless (my @files = glob "$result_dir/*") {
1140 rmdir $result_dir;
1141 }
1142 }
1143
af31090c 1144 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1145
7cab3ab7 1146}
1147
79193756 1148sub _sig_comment {
1149 my ($self, $version, $ts) = @_;
1150 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1151 . qq| v| . $version
1152 . q| @ | . $ts
1153 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1154}
1155
7cab3ab7 1156sub _write_classfile {
68d49e50 1157 my ($self, $class, $text, $is_schema) = @_;
7cab3ab7 1158
1159 my $filename = $self->_get_dump_filename($class);
1160 $self->_ensure_dump_subdirs($class);
1161
28b4691d 1162 if (-f $filename && $self->really_erase_my_files) {
7cab3ab7 1163 warn "Deleting existing file '$filename' due to "
af31090c 1164 . "'really_erase_my_files' setting\n" unless $self->{quiet};
7cab3ab7 1165 unlink($filename);
1166 }
1167
79193756 1168 my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
17ca645f 1169
e1373c52 1170 if (my $old_class = $self->_upgrading_classes->{$class}) {
1171 my $old_filename = $self->_get_dump_filename($old_class);
f53dcdf0 1172
e1373c52 1173 my ($old_custom_content) = $self->_get_custom_content(
1174 $old_class, $old_filename, 0 # do not add default comment
1175 );
ffc705f3 1176
e1373c52 1177 $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
f53dcdf0 1178
e1373c52 1179 if ($old_custom_content) {
1180 $custom_content =
1181 "\n" . $old_custom_content . "\n" . $custom_content;
f53dcdf0 1182 }
e1373c52 1183
1184 unlink $old_filename;
f53dcdf0 1185 }
1186
b24cb177 1187 $custom_content = $self->_rewrite_old_classnames($custom_content);
1188
7cab3ab7 1189 $text .= qq|$_\n|
1190 for @{$self->{_dump_storage}->{$class} || []};
1191
79193756 1192 # Check and see if the dump is infact differnt
1193
1194 my $compare_to;
1195 if ($old_md5) {
1196 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1197
1198
1199 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
68d49e50 1200 return unless $self->_upgrading_from && $is_schema;
79193756 1201 }
1202 }
1203
1204 $text .= $self->_sig_comment(
01012543 1205 $self->version_to_dump,
79193756 1206 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1207 );
7cab3ab7 1208
1209 open(my $fh, '>', $filename)
1210 or croak "Cannot open '$filename' for writing: $!";
1211
1212 # Write the top half and its MD5 sum
a4476f41 1213 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
7cab3ab7 1214
1215 # Write out anything loaded via external partial class file in @INC
1216 print $fh qq|$_\n|
1217 for @{$self->{_ext_storage}->{$class} || []};
1218
1eea4fb1 1219 # Write out any custom content the user has added
7cab3ab7 1220 print $fh $custom_content;
1221
1222 close($fh)
e9b8719e 1223 or croak "Error closing '$filename': $!";
7cab3ab7 1224}
1225
79193756 1226sub _default_custom_content {
1227 return qq|\n\n# You can replace this text with custom|
1228 . qq| content, and it will be preserved on regeneration|
1229 . qq|\n1;\n|;
1230}
1231
7cab3ab7 1232sub _get_custom_content {
ffc705f3 1233 my ($self, $class, $filename, $add_default) = @_;
1234
1235 $add_default = 1 unless defined $add_default;
7cab3ab7 1236
79193756 1237 return ($self->_default_custom_content) if ! -f $filename;
1238
7cab3ab7 1239 open(my $fh, '<', $filename)
1240 or croak "Cannot open '$filename' for reading: $!";
1241
1242 my $mark_re =
419a2eeb 1243 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
7cab3ab7 1244
7cab3ab7 1245 my $buffer = '';
79193756 1246 my ($md5, $ts, $ver);
7cab3ab7 1247 while(<$fh>) {
79193756 1248 if(!$md5 && /$mark_re/) {
1249 $md5 = $2;
1250 my $line = $1;
1251
1252 # Pull out the previous version and timestamp
1253 ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
1254
1255 $buffer .= $line;
b4cc5793 1256 croak "Checksum mismatch in '$filename', the auto-generated part of the file has been modified outside of this loader. Aborting.\nIf you want to overwrite these modifications, set the 'overwrite_modifications' loader option.\n"
639a1367 1257 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
7cab3ab7 1258
1259 $buffer = '';
1260 }
1261 else {
1262 $buffer .= $_;
1263 }
996be9ee 1264 }
1265
28b4691d 1266 croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
419a2eeb 1267 . " it does not appear to have been generated by Loader"
79193756 1268 if !$md5;
5ef3c771 1269
79193756 1270 # Default custom content:
ffc705f3 1271 $buffer ||= $self->_default_custom_content if $add_default;
5ef3c771 1272
79193756 1273 return ($buffer, $md5, $ver, $ts);
996be9ee 1274}
1275
1276sub _use {
1277 my $self = shift;
1278 my $target = shift;
1279
1280 foreach (@_) {
cb54990b 1281 warn "$target: use $_;" if $self->debug;
996be9ee 1282 $self->_raw_stmt($target, "use $_;");
996be9ee 1283 }
1284}
1285
1286sub _inject {
1287 my $self = shift;
1288 my $target = shift;
1289 my $schema_class = $self->schema_class;
1290
af31090c 1291 my $blist = join(q{ }, @_);
1292 warn "$target: use base qw/ $blist /;" if $self->debug && @_;
1293 $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
996be9ee 1294}
1295
540a8149 1296sub _result_namespace {
1297 my ($self, $schema_class, $ns) = @_;
1298 my @result_namespace;
1299
1300 if ($ns =~ /^\+(.*)/) {
1301 # Fully qualified namespace
1302 @result_namespace = ($1)
1303 }
1304 else {
1305 # Relative namespace
1306 @result_namespace = ($schema_class, $ns);
1307 }
1308
1309 return wantarray ? @result_namespace : join '::', @result_namespace;
1310}
1311
f96ef30f 1312# Create class with applicable bases, setup monikers, etc
1313sub _make_src_class {
1314 my ($self, $table) = @_;
996be9ee 1315
a13b2803 1316 my $schema = $self->schema;
1317 my $schema_class = $self->schema_class;
996be9ee 1318
f96ef30f 1319 my $table_moniker = $self->_table2moniker($table);
f44ecc2f 1320 my @result_namespace = ($schema_class);
1321 if ($self->use_namespaces) {
1322 my $result_namespace = $self->result_namespace || 'Result';
540a8149 1323 @result_namespace = $self->_result_namespace(
1324 $schema_class,
1325 $result_namespace,
1326 );
f44ecc2f 1327 }
1328 my $table_class = join(q{::}, @result_namespace, $table_moniker);
996be9ee 1329
805dbe0a 1330 if ((my $upgrading_v = $self->_upgrading_from)
a4b94090 1331 || $self->_rewriting) {
805dbe0a 1332 local $self->naming->{monikers} = $upgrading_v
1333 if $upgrading_v;
1334
1335 my @result_namespace = @result_namespace;
a4b94090 1336 if ($self->_upgrading_from_load_classes) {
1337 @result_namespace = ($schema_class);
1338 }
1339 elsif (my $ns = $self->_downgrading_to_load_classes) {
540a8149 1340 @result_namespace = $self->_result_namespace(
1341 $schema_class,
1342 $ns,
1343 );
1344 }
1345 elsif ($ns = $self->_rewriting_result_namespace) {
1346 @result_namespace = $self->_result_namespace(
1347 $schema_class,
1348 $ns,
1349 );
a4b94090 1350 }
f53dcdf0 1351
1352 my $old_class = join(q{::}, @result_namespace,
1353 $self->_table2moniker($table));
1354
68d49e50 1355 $self->_upgrading_classes->{$table_class} = $old_class
1356 unless $table_class eq $old_class;
f53dcdf0 1357 }
1358
bfb43060 1359# this was a bad idea, should be ok now without it
1360# my $table_normalized = lc $table;
1361# $self->classes->{$table_normalized} = $table_class;
1362# $self->monikers->{$table_normalized} = $table_moniker;
1363
f96ef30f 1364 $self->classes->{$table} = $table_class;
f96ef30f 1365 $self->monikers->{$table} = $table_moniker;
996be9ee 1366
f96ef30f 1367 $self->_use ($table_class, @{$self->additional_classes});
af31090c 1368 $self->_inject($table_class, @{$self->left_base_classes});
996be9ee 1369
2229729e 1370 if (my @components = @{ $self->components }) {
1371 $self->_dbic_stmt($table_class, 'load_components', @components);
1372 }
996be9ee 1373
f96ef30f 1374 $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1375 if @{$self->resultset_components};
af31090c 1376 $self->_inject($table_class, @{$self->additional_base_classes});
f96ef30f 1377}
996be9ee 1378
af31090c 1379# Set up metadata (cols, pks, etc)
f96ef30f 1380sub _setup_src_meta {
1381 my ($self, $table) = @_;
996be9ee 1382
f96ef30f 1383 my $schema = $self->schema;
1384 my $schema_class = $self->schema_class;
a13b2803 1385
f96ef30f 1386 my $table_class = $self->classes->{$table};
1387 my $table_moniker = $self->monikers->{$table};
996be9ee 1388
ff30991a 1389 my $table_name = $table;
1390 my $name_sep = $self->schema->storage->sql_maker->name_sep;
1391
c177d483 1392 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
ff30991a 1393 $table_name = \ $self->_quote_table_name($table_name);
1394 }
1395
1396 $self->_dbic_stmt($table_class,'table',$table_name);
996be9ee 1397
f96ef30f 1398 my $cols = $self->_table_columns($table);
45be2ce7 1399 my $col_info = $self->__columns_info_for($table);
1400 if ($self->_is_case_sensitive) {
1401 for my $col (keys %$col_info) {
1402 $col_info->{$col}{accessor} = lc $col
1403 if $col ne lc($col);
c9373b79 1404 }
45be2ce7 1405 } else {
1406 $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1407 }
c9373b79 1408
45be2ce7 1409 my $fks = $self->_table_fk_info($table);
565335e6 1410
45be2ce7 1411 for my $fkdef (@$fks) {
1412 for my $col (@{ $fkdef->{local_columns} }) {
1413 $col_info->{$col}{is_foreign_key} = 1;
e7213f4f 1414 }
996be9ee 1415 }
45be2ce7 1416 $self->_dbic_stmt(
1417 $table_class,
1418 'add_columns',
1419 map { $_, ($col_info->{$_}||{}) } @$cols
1420 );
996be9ee 1421
d70c335f 1422 my %uniq_tag; # used to eliminate duplicate uniqs
1423
f96ef30f 1424 my $pks = $self->_table_pk_info($table) || [];
1425 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1426 : carp("$table has no primary key");
d70c335f 1427 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
996be9ee 1428
f96ef30f 1429 my $uniqs = $self->_table_uniq_info($table) || [];
d70c335f 1430 for (@$uniqs) {
1431 my ($name, $cols) = @$_;
1432 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1433 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1434 }
1435
996be9ee 1436}
1437
d67d058e 1438sub __columns_info_for {
1439 my ($self, $table) = @_;
1440
1441 my $result = $self->_columns_info_for($table);
1442
1443 while (my ($col, $info) = each %$result) {
1444 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
1445 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1446
1447 $result->{$col} = $info;
1448 }
1449
1450 return $result;
1451}
1452
996be9ee 1453=head2 tables
1454
1455Returns a sorted list of loaded tables, using the original database table
1456names.
1457
1458=cut
1459
1460sub tables {
1461 my $self = shift;
1462
b97c2c1e 1463 return keys %{$self->_tables};
996be9ee 1464}
1465
1466# Make a moniker from a table
c39e403e 1467sub _default_table2moniker {
66afce69 1468 no warnings 'uninitialized';
c39e403e 1469 my ($self, $table) = @_;
1470
a8d229ff 1471 if ($self->naming->{monikers} eq 'v4') {
1472 return join '', map ucfirst, split /[\W_]+/, lc $table;
1473 }
1474
c39e403e 1475 return join '', map ucfirst, split /[\W_]+/,
1476 Lingua::EN::Inflect::Number::to_S(lc $table);
1477}
1478
996be9ee 1479sub _table2moniker {
1480 my ( $self, $table ) = @_;
1481
1482 my $moniker;
1483
1484 if( ref $self->moniker_map eq 'HASH' ) {
1485 $moniker = $self->moniker_map->{$table};
1486 }
1487 elsif( ref $self->moniker_map eq 'CODE' ) {
1488 $moniker = $self->moniker_map->($table);
1489 }
1490
c39e403e 1491 $moniker ||= $self->_default_table2moniker($table);
996be9ee 1492
1493 return $moniker;
1494}
1495
1496sub _load_relationships {
e8ad6491 1497 my ($self, $table) = @_;
996be9ee 1498
e8ad6491 1499 my $tbl_fk_info = $self->_table_fk_info($table);
1500 foreach my $fkdef (@$tbl_fk_info) {
1501 $fkdef->{remote_source} =
1502 $self->monikers->{delete $fkdef->{remote_table}};
996be9ee 1503 }
26f1c8c9 1504 my $tbl_uniq_info = $self->_table_uniq_info($table);
996be9ee 1505
e8ad6491 1506 my $local_moniker = $self->monikers->{$table};
7824616e 1507 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
996be9ee 1508
996be9ee 1509 foreach my $src_class (sort keys %$rel_stmts) {
1510 my $src_stmts = $rel_stmts->{$src_class};
1511 foreach my $stmt (@$src_stmts) {
1512 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1513 }
1514 }
1515}
1516
1517# Overload these in driver class:
1518
1519# Returns an arrayref of column names
1520sub _table_columns { croak "ABSTRACT METHOD" }
1521
1522# Returns arrayref of pk col names
1523sub _table_pk_info { croak "ABSTRACT METHOD" }
1524
1525# Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1526sub _table_uniq_info { croak "ABSTRACT METHOD" }
1527
1528# Returns an arrayref of foreign key constraints, each
1529# being a hashref with 3 keys:
1530# local_columns (arrayref), remote_columns (arrayref), remote_table
1531sub _table_fk_info { croak "ABSTRACT METHOD" }
1532
1533# Returns an array of lower case table names
1534sub _tables_list { croak "ABSTRACT METHOD" }
1535
1536# Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1537sub _dbic_stmt {
bf654ab9 1538 my $self = shift;
1539 my $class = shift;
996be9ee 1540 my $method = shift;
bf654ab9 1541
1542 # generate the pod for this statement, storing it with $self->_pod
43b982ea 1543 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
bf654ab9 1544
1545 my $args = dump(@_);
1546 $args = '(' . $args . ')' if @_ < 2;
1547 my $stmt = $method . $args . q{;};
1548
1549 warn qq|$class\->$stmt\n| if $self->debug;
1550 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1551 return;
1552}
1553
1554# generates the accompanying pod for a DBIC class method statement,
1555# storing it with $self->_pod
1556sub _make_pod {
1557 my $self = shift;
1558 my $class = shift;
1559 my $method = shift;
1560
fbcfebdd 1561 if ( $method eq 'table' ) {
1562 my ($table) = @_;
43b982ea 1563 my $pcm = $self->pod_comment_mode;
1564 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
fbcfebdd 1565 if ( $self->can('_table_comment') ) {
43b982ea 1566 $comment = $self->_table_comment($table);
1567 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1568 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1569 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
fbcfebdd 1570 }
43b982ea 1571 $self->_pod( $class, "=head1 NAME" );
1572 my $table_descr = $class;
1573 $table_descr .= " - " . $comment if $comment and $comment_in_name;
fbcfebdd 1574 $self->{_class2table}{ $class } = $table;
1575 $self->_pod( $class, $table_descr );
43b982ea 1576 if ($comment and $comment_in_desc) {
1577 $self->_pod( $class, "=head1 DESCRIPTION" );
1578 $self->_pod( $class, $comment );
1579 }
fbcfebdd 1580 $self->_pod_cut( $class );
1581 } elsif ( $method eq 'add_columns' ) {
1582 $self->_pod( $class, "=head1 ACCESSORS" );
79a00530 1583 my $col_counter = 0;
1584 my @cols = @_;
1585 while( my ($name,$attrs) = splice @cols,0,2 ) {
1586 $col_counter++;
1587 $self->_pod( $class, '=head2 ' . $name );
1588 $self->_pod( $class,
1589 join "\n", map {
1590 my $s = $attrs->{$_};
fca5431b 1591 $s = !defined $s ? 'undef' :
1592 length($s) == 0 ? '(empty string)' :
f170d55b 1593 ref($s) eq 'SCALAR' ? $$s :
1594 ref($s) ? do {
1595 my $dd = Dumper;
1596 $dd->Indent(0);
1597 $dd->Values([$s]);
1598 $dd->Dump;
1599 } :
1600 looks_like_number($s) ? $s :
1601 qq{'$s'}
fca5431b 1602 ;
79a00530 1603
1604 " $_: $s"
1605 } sort keys %$attrs,
1606 );
1607
1608 if( $self->can('_column_comment')
1609 and my $comment = $self->_column_comment( $self->{_class2table}{$class}, $col_counter)
1610 ) {
1611 $self->_pod( $class, $comment );
1612 }
fbcfebdd 1613 }
1614 $self->_pod_cut( $class );
1615 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1616 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1617 my ( $accessor, $rel_class ) = @_;
1618 $self->_pod( $class, "=head2 $accessor" );
1619 $self->_pod( $class, 'Type: ' . $method );
1620 $self->_pod( $class, "Related object: L<$rel_class>" );
1621 $self->_pod_cut( $class );
1622 $self->{_relations_started} { $class } = 1;
1623 }
996be9ee 1624}
1625
fbcfebdd 1626# Stores a POD documentation
1627sub _pod {
1628 my ($self, $class, $stmt) = @_;
1629 $self->_raw_stmt( $class, "\n" . $stmt );
1630}
1631
1632sub _pod_cut {
1633 my ($self, $class ) = @_;
1634 $self->_raw_stmt( $class, "\n=cut\n" );
1635}
1636
996be9ee 1637# Store a raw source line for a class (for dumping purposes)
1638sub _raw_stmt {
1639 my ($self, $class, $stmt) = @_;
af31090c 1640 push(@{$self->{_dump_storage}->{$class}}, $stmt);
996be9ee 1641}
1642
7cab3ab7 1643# Like above, but separately for the externally loaded stuff
1644sub _ext_stmt {
1645 my ($self, $class, $stmt) = @_;
af31090c 1646 push(@{$self->{_ext_storage}->{$class}}, $stmt);
7cab3ab7 1647}
1648
565335e6 1649sub _quote_table_name {
1650 my ($self, $table) = @_;
1651
1652 my $qt = $self->schema->storage->sql_maker->quote_char;
1653
c177d483 1654 return $table unless $qt;
1655
565335e6 1656 if (ref $qt) {
1657 return $qt->[0] . $table . $qt->[1];
1658 }
1659
1660 return $qt . $table . $qt;
1661}
1662
1663sub _is_case_sensitive { 0 }
1664
b639d969 1665sub _custom_column_info {
23d1f36b 1666 my ( $self, $table_name, $column_name, $column_info ) = @_;
b639d969 1667
d67d058e 1668 if (my $code = $self->custom_column_info) {
1669 return $code->($table_name, $column_name, $column_info) || {};
b639d969 1670 }
3a368709 1671 return {};
b639d969 1672}
1673
42e785fa 1674sub _datetime_column_info {
23d1f36b 1675 my ( $self, $table_name, $column_name, $column_info ) = @_;
d67d058e 1676 my $result = {};
1677 my $type = $column_info->{data_type} || '';
1678 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
1679 or ($type =~ /date|timestamp/i)) {
1680 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
1681 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
42e785fa 1682 }
d67d058e 1683 return $result;
42e785fa 1684}
1685
ffc705f3 1686# remove the dump dir from @INC on destruction
1687sub DESTROY {
1688 my $self = shift;
1689
1690 @INC = grep $_ ne $self->dump_directory, @INC;
1691}
1692
996be9ee 1693=head2 monikers
1694
8f9d7ce5 1695Returns a hashref of loaded table to moniker mappings. There will
996be9ee 1696be two entries for each table, the original name and the "normalized"
1697name, in the case that the two are different (such as databases
1698that like uppercase table names, or preserve your original mixed-case
1699definitions, or what-have-you).
1700
1701=head2 classes
1702
8f9d7ce5 1703Returns a hashref of table to class mappings. In some cases it will
996be9ee 1704contain multiple entries per table for the original and normalized table
1705names, as above in L</monikers>.
1706
1707=head1 SEE ALSO
1708
1709L<DBIx::Class::Schema::Loader>
1710
be80bba7 1711=head1 AUTHOR
1712
9cc8e7e1 1713See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
be80bba7 1714
1715=head1 LICENSE
1716
1717This library is free software; you can redistribute it and/or modify it under
1718the same terms as Perl itself.
1719
996be9ee 1720=cut
1721
17221;
bfb43060 1723# vim:et sts=4 sw=4 tw=0: