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