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