lib/DBIx/Class/Schema/Loader/Base.pm

   1 package DBIx::Class::Schema::Loader::Base;
   2
   3 use strict;
   4 use warnings;
   5 use base qw/Class::Accessor::Grouped Class::C3::Componentised/;
   6 use mro 'c3';
   7 use Carp::Clan qw/^DBIx::Class/;
   8 use DBIx::Class::Schema::Loader::RelBuilder;
   9 use Data::Dump qw/ dump /;
  10 use POSIX qw//;
  11 use File::Spec qw//;
  12 use Cwd qw//;
  13 use Digest::MD5 qw//;
  14 use Lingua::EN::Inflect::Number qw//;
  15 use Lingua::EN::Inflect::Phrase qw//;
  16 use File::Temp qw//;
  17 use Class::Unload;
  18 use Class::Inspector ();
  19 use Scalar::Util 'looks_like_number';
  20 use File::Slurp 'read_file';
  21 use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path/;
  22 use DBIx::Class::Schema::Loader::Optional::Dependencies ();
  23 use Try::Tiny;
  24 use DBIx::Class ();
  25 use Encode qw/encode/;
  26 use List::MoreUtils 'all';
  27 use namespace::clean;
  28
  29 our $VERSION = '0.07010';
  30
  31 __PACKAGE__->mk_group_ro_accessors('simple', qw/
  32                                 schema
  33                                 schema_class
  34
  35                                 exclude
  36                                 constraint
  37                                 additional_classes
  38                                 additional_base_classes
  39                                 left_base_classes
  40                                 components
  41                                 skip_relationships
  42                                 skip_load_external
  43                                 moniker_map
  44                                 col_accessor_map
  45                                 custom_column_info
  46                                 inflect_singular
  47                                 inflect_plural
  48                                 debug
  49                                 dump_directory
  50                                 dump_overwrite
  51                                 really_erase_my_files
  52                                 resultset_namespace
  53                                 default_resultset_class
  54                                 schema_base_class
  55                                 result_base_class
  56                                 result_roles
  57                                 use_moose
  58                                 overwrite_modifications
  59
  60                                 relationship_attrs
  61
  62                                 db_schema
  63                                 _tables
  64                                 classes
  65                                 _upgrading_classes
  66                                 monikers
  67                                 dynamic
  68                                 naming
  69                                 datetime_timezone
  70                                 datetime_locale
  71                                 config_file
  72                                 loader_class
  73                                 qualify_objects
  74                                 tables
  75                                 class_to_table
  76                                 uniq_to_primary
  77 /);
  78
  79
  80 __PACKAGE__->mk_group_accessors('simple', qw/
  81                                 version_to_dump
  82                                 schema_version_to_dump
  83                                 _upgrading_from
  84                                 _upgrading_from_load_classes
  85                                 _downgrading_to_load_classes
  86                                 _rewriting_result_namespace
  87                                 use_namespaces
  88                                 result_namespace
  89                                 generate_pod
  90                                 pod_comment_mode
  91                                 pod_comment_spillover_length
  92                                 preserve_case
  93                                 col_collision_map
  94                                 rel_collision_map
  95                                 rel_name_map
  96                                 real_dump_directory
  97                                 result_components_map
  98                                 result_roles_map
  99                                 datetime_undef_if_invalid
 100                                 _result_class_methods
 101                                 naming_set
 102 /);
 103
 104 =head1 NAME
 105
 106 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
 107
 108 =head1 SYNOPSIS
 109
 110 See L<DBIx::Class::Schema::Loader>
 111
 112 =head1 DESCRIPTION
 113
 114 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
 115 classes, and implements the common functionality between them.
 116
 117 =head1 CONSTRUCTOR OPTIONS
 118
 119 These constructor options are the base options for
 120 L<DBIx::Class::Schema::Loader/loader_options>.  Available constructor options are:
 121
 122 =head2 skip_relationships
 123
 124 Skip setting up relationships.  The default is to attempt the loading
 125 of relationships.
 126
 127 =head2 skip_load_external
 128
 129 Skip loading of other classes in @INC. The default is to merge all other classes
 130 with the same name found in @INC into the schema file we are creating.
 131
 132 =head2 naming
 133
 134 Static schemas (ones dumped to disk) will, by default, use the new-style
 135 relationship names and singularized Results, unless you're overwriting an
 136 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
 137 which case the backward compatible RelBuilder will be activated, and the
 138 appropriate monikerization used.
 139
 140 Specifying
 141
 142     naming => 'current'
 143
 144 will disable the backward-compatible RelBuilder and use
 145 the new-style relationship names along with singularized Results, even when
 146 overwriting a dump made with an earlier version.
 147
 148 The option also takes a hashref:
 149
 150     naming => { relationships => 'v7', monikers => 'v7' }
 151
 152 The keys are:
 153
 154 =over 4
 155
 156 =item relationships
 157
 158 How to name relationship accessors.
 159
 160 =item monikers
 161
 162 How to name Result classes.
 163
 164 =item column_accessors
 165
 166 How to name column accessors in Result classes.
 167
 168 =back
 169
 170 The values can be:
 171
 172 =over 4
 173
 174 =item current
 175
 176 Latest style, whatever that happens to be.
 177
 178 =item v4
 179
 180 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
 181
 182 =item v5
 183
 184 Monikers singularized as whole words, C<might_have> relationships for FKs on
 185 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
 186
 187 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
 188 the v5 RelBuilder.
 189
 190 =item v6
 191
 192 All monikers and relationships are inflected using
 193 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
 194 from relationship names.
 195
 196 In general, there is very little difference between v5 and v6 schemas.
 197
 198 =item v7
 199
 200 This mode is identical to C<v6> mode, except that monikerization of CamelCase
 201 table names is also done correctly.
 202
 203 CamelCase column names in case-preserving mode will also be handled correctly
 204 for relationship name inflection. See L</preserve_case>.
 205
 206 In this mode, CamelCase L</column_accessors> are normalized based on case
 207 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
 208
 209 If you don't have any CamelCase table or column names, you can upgrade without
 210 breaking any of your code.
 211
 212 =item preserve
 213
 214 For L</monikers>, this option does not inflect the table names but makes
 215 monikers based on the actual name. For L</column_accessors> this option does
 216 not normalize CamelCase column names to lowercase column accessors, but makes
 217 accessors that are the same names as the columns (with any non-\w chars
 218 replaced with underscores.)
 219
 220 =item singular
 221
 222 For L</monikers>, singularizes the names using the most current inflector. This
 223 is the same as setting the option to L</current>.
 224
 225 =item plural
 226
 227 For L</monikers>, pluralizes the names, using the most current inflector.
 228
 229 =back
 230
 231 Dynamic schemas will always default to the 0.04XXX relationship names and won't
 232 singularize Results for backward compatibility, to activate the new RelBuilder
 233 and singularization put this in your C<Schema.pm> file:
 234
 235     __PACKAGE__->naming('current');
 236
 237 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
 238 next major version upgrade:
 239
 240     __PACKAGE__->naming('v7');
 241
 242 =head2 generate_pod
 243
 244 By default POD will be generated for columns and relationships, using database
 245 metadata for the text if available and supported.
 246
 247 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
 248 supported for Postgres right now.
 249
 250 Set this to C<0> to turn off all POD generation.
 251
 252 =head2 pod_comment_mode
 253
 254 Controls where table comments appear in the generated POD. Smaller table
 255 comments are appended to the C<NAME> section of the documentation, and larger
 256 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
 257 section to be generated with the comment always, only use C<NAME>, or choose
 258 the length threshold at which the comment is forced into the description.
 259
 260 =over 4
 261
 262 =item name
 263
 264 Use C<NAME> section only.
 265
 266 =item description
 267
 268 Force C<DESCRIPTION> always.
 269
 270 =item auto
 271
 272 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
 273 default.
 274
 275 =back
 276
 277 =head2 pod_comment_spillover_length
 278
 279 When pod_comment_mode is set to C<auto>, this is the length of the comment at
 280 which it will be forced into a separate description section.
 281
 282 The default is C<60>
 283
 284 =head2 relationship_attrs
 285
 286 Hashref of attributes to pass to each generated relationship, listed
 287 by type.  Also supports relationship type 'all', containing options to
 288 pass to all generated relationships.  Attributes set for more specific
 289 relationship types override those set in 'all'.
 290
 291 For example:
 292
 293   relationship_attrs => {
 294     belongs_to => { is_deferrable => 0 },
 295   },
 296
 297 use this to turn off DEFERRABLE on your foreign key constraints.
 298
 299 =head2 debug
 300
 301 If set to true, each constructive L<DBIx::Class> statement the loader
 302 decides to execute will be C<warn>-ed before execution.
 303
 304 =head2 db_schema
 305
 306 Set the name of the schema to load (schema in the sense that your database
 307 vendor means it).  Does not currently support loading more than one schema
 308 name.
 309
 310 =head2 constraint
 311
 312 Only load tables matching regex.  Best specified as a qr// regex.
 313
 314 =head2 exclude
 315
 316 Exclude tables matching regex.  Best specified as a qr// regex.
 317
 318 =head2 moniker_map
 319
 320 Overrides the default table name to moniker translation.  Can be either
 321 a hashref of table keys and moniker values, or a coderef for a translator
 322 function taking a single scalar table name argument and returning
 323 a scalar moniker.  If the hash entry does not exist, or the function
 324 returns a false value, the code falls back to default behavior
 325 for that table name.
 326
 327 The default behavior is to split on case transition and non-alphanumeric
 328 boundaries, singularize the resulting phrase, then join the titlecased words
 329 together. Examples:
 330
 331     Table Name       | Moniker Name
 332     ---------------------------------
 333     luser            | Luser
 334     luser_group      | LuserGroup
 335     luser-opts       | LuserOpt
 336     stations_visited | StationVisited
 337     routeChange      | RouteChange
 338
 339 =head2 col_accessor_map
 340
 341 Same as moniker_map, but for column accessor names.  If a coderef is
 342 passed, the code is called with arguments of
 343
 344    the name of the column in the underlying database,
 345    default accessor name that DBICSL would ordinarily give this column,
 346    {
 347       table_class     => name of the DBIC class we are building,
 348       table_moniker   => calculated moniker for this table (after moniker_map if present),
 349       table_name      => name of the database table,
 350       full_table_name => schema-qualified name of the database table (RDBMS specific),
 351       schema_class    => name of the schema class we are building,
 352       column_info     => hashref of column info (data_type, is_nullable, etc),
 353     }
 354
 355 =head2 rel_name_map
 356
 357 Similar in idea to moniker_map, but different in the details.  It can be
 358 a hashref or a code ref.
 359
 360 If it is a hashref, keys can be either the default relationship name, or the
 361 moniker. The keys that are the default relationship name should map to the
 362 name you want to change the relationship to. Keys that are monikers should map
 363 to hashes mapping relationship names to their translation.  You can do both at
 364 once, and the more specific moniker version will be picked up first.  So, for
 365 instance, you could have
 366
 367     {
 368         bar => "baz",
 369         Foo => {
 370             bar => "blat",
 371         },
 372     }
 373
 374 and relationships that would have been named C<bar> will now be named C<baz>
 375 except that in the table whose moniker is C<Foo> it will be named C<blat>.
 376
 377 If it is a coderef, the argument passed will be a hashref of this form:
 378
 379     {
 380         name           => default relationship name,
 381         type           => the relationship type eg: C<has_many>,
 382         local_class    => name of the DBIC class we are building,
 383         local_moniker  => moniker of the DBIC class we are building,
 384         local_columns  => columns in this table in the relationship,
 385         remote_class   => name of the DBIC class we are related to,
 386         remote_moniker => moniker of the DBIC class we are related to,
 387         remote_columns => columns in the other table in the relationship,
 388     }
 389
 390 DBICSL will try to use the value returned as the relationship name.
 391
 392 =head2 inflect_plural
 393
 394 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
 395 if hash key does not exist or coderef returns false), but acts as a map
 396 for pluralizing relationship names.  The default behavior is to utilize
 397 L<Lingua::EN::Inflect::Phrase/to_PL>.
 398
 399 =head2 inflect_singular
 400
 401 As L</inflect_plural> above, but for singularizing relationship names.
 402 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
 403
 404 =head2 schema_base_class
 405
 406 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
 407
 408 =head2 result_base_class
 409
 410 Base class for your table classes (aka result classes). Defaults to
 411 'DBIx::Class::Core'.
 412
 413 =head2 additional_base_classes
 414
 415 List of additional base classes all of your table classes will use.
 416
 417 =head2 left_base_classes
 418
 419 List of additional base classes all of your table classes will use
 420 that need to be leftmost.
 421
 422 =head2 additional_classes
 423
 424 List of additional classes which all of your table classes will use.
 425
 426 =head2 components
 427
 428 List of additional components to be loaded into all of your table
 429 classes.  A good example would be
 430 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
 431
 432 =head2 result_components_map
 433
 434 A hashref of moniker keys and component values.  Unlike L</components>, which
 435 loads the given components into every Result class, this option allows you to
 436 load certain components for specified Result classes. For example:
 437
 438   result_components_map => {
 439       StationVisited => '+YourApp::Schema::Component::StationVisited',
 440       RouteChange    => [
 441                             '+YourApp::Schema::Component::RouteChange',
 442                             'InflateColumn::DateTime',
 443                         ],
 444   }
 445
 446 You may use this in conjunction with L</components>.
 447
 448 =head2 result_roles
 449
 450 List of L<Moose> roles to be applied to all of your Result classes.
 451
 452 =head2 result_roles_map
 453
 454 A hashref of moniker keys and role values.  Unlike L</result_roles>, which
 455 applies the given roles to every Result class, this option allows you to apply
 456 certain roles for specified Result classes. For example:
 457
 458   result_roles_map => {
 459       StationVisited => [
 460                             'YourApp::Role::Building',
 461                             'YourApp::Role::Destination',
 462                         ],
 463       RouteChange    => 'YourApp::Role::TripEvent',
 464   }
 465
 466 You may use this in conjunction with L</result_roles>.
 467
 468 =head2 use_namespaces
 469
 470 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
 471 a C<0>.
 472
 473 Generate result class names suitable for
 474 L<DBIx::Class::Schema/load_namespaces> and call that instead of
 475 L<DBIx::Class::Schema/load_classes>. When using this option you can also
 476 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
 477 C<resultset_namespace>, C<default_resultset_class>), and they will be added
 478 to the call (and the generated result class names adjusted appropriately).
 479
 480 =head2 dump_directory
 481
 482 The value of this option is a perl libdir pathname.  Within
 483 that directory this module will create a baseline manual
 484 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
 485
 486 The created schema class will have the same classname as the one on
 487 which you are setting this option (and the ResultSource classes will be
 488 based on this name as well).
 489
 490 Normally you wouldn't hard-code this setting in your schema class, as it
 491 is meant for one-time manual usage.
 492
 493 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
 494 recommended way to access this functionality.
 495
 496 =head2 dump_overwrite
 497
 498 Deprecated.  See L</really_erase_my_files> below, which does *not* mean
 499 the same thing as the old C<dump_overwrite> setting from previous releases.
 500
 501 =head2 really_erase_my_files
 502
 503 Default false.  If true, Loader will unconditionally delete any existing
 504 files before creating the new ones from scratch when dumping a schema to disk.
 505
 506 The default behavior is instead to only replace the top portion of the
 507 file, up to and including the final stanza which contains
 508 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
 509 leaving any customizations you placed after that as they were.
 510
 511 When C<really_erase_my_files> is not set, if the output file already exists,
 512 but the aforementioned final stanza is not found, or the checksum
 513 contained there does not match the generated contents, Loader will
 514 croak and not touch the file.
 515
 516 You should really be using version control on your schema classes (and all
 517 of the rest of your code for that matter).  Don't blame me if a bug in this
 518 code wipes something out when it shouldn't have, you've been warned.
 519
 520 =head2 overwrite_modifications
 521
 522 Default false.  If false, when updating existing files, Loader will
 523 refuse to modify any Loader-generated code that has been modified
 524 since its last run (as determined by the checksum Loader put in its
 525 comment lines).
 526
 527 If true, Loader will discard any manual modifications that have been
 528 made to Loader-generated code.
 529
 530 Again, you should be using version control on your schema classes.  Be
 531 careful with this option.
 532
 533 =head2 custom_column_info
 534
 535 Hook for adding extra attributes to the
 536 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
 537
 538 Must be a coderef that returns a hashref with the extra attributes.
 539
 540 Receives the table name, column name and column_info.
 541
 542 For example:
 543
 544   custom_column_info => sub {
 545       my ($table_name, $column_name, $column_info) = @_;
 546
 547       if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
 548           return { is_snoopy => 1 };
 549       }
 550   },
 551
 552 This attribute can also be used to set C<inflate_datetime> on a non-datetime
 553 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
 554
 555 =head2 datetime_timezone
 556
 557 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
 558 columns with the DATE/DATETIME/TIMESTAMP data_types.
 559
 560 =head2 datetime_locale
 561
 562 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
 563 columns with the DATE/DATETIME/TIMESTAMP data_types.
 564
 565 =head2 datetime_undef_if_invalid
 566
 567 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
 568 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
 569 TIMESTAMP columns.
 570
 571 The default is recommended to deal with data such as C<00/00/00> which
 572 sometimes ends up in such columns in MySQL.
 573
 574 =head2 config_file
 575
 576 File in Perl format, which should return a HASH reference, from which to read
 577 loader options.
 578
 579 =head2 preserve_case
 580
 581 Usually column names are lowercased, to make them easier to work with in
 582 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
 583 supports it.
 584
 585 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
 586 case-sensitive collation will turn this option on unconditionally.
 587
 588 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
 589 setting this option.
 590
 591 =head2 qualify_objects
 592
 593 Set to true to prepend the L</db_schema> to table names for C<<
 594 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
 595
 596 =head2 use_moose
 597
 598 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
 599 L<namespace::autoclean>. The default content after the md5 sum also makes the
 600 classes immutable.
 601
 602 It is safe to upgrade your existing Schema to this option.
 603
 604 =head2 col_collision_map
 605
 606 This option controls how accessors for column names which collide with perl
 607 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
 608
 609 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
 610 strings which are compiled to regular expressions that map to
 611 L<sprintf|perlfunc/sprintf> formats.
 612
 613 Examples:
 614
 615     col_collision_map => 'column_%s'
 616
 617     col_collision_map => { '(.*)' => 'column_%s' }
 618
 619     col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
 620
 621 =head2 rel_collision_map
 622
 623 Works just like L</col_collision_map>, but for relationship names/accessors
 624 rather than column names/accessors.
 625
 626 The default is to just append C<_rel> to the relationship name, see
 627 L</RELATIONSHIP NAME COLLISIONS>.
 628
 629 =head2 uniq_to_primary
 630
 631 Automatically promotes the largest unique constraints with non-nullable columns
 632 on tables to primary keys, assuming there is only one largest unique
 633 constraint.
 634
 635 =head1 METHODS
 636
 637 None of these methods are intended for direct invocation by regular
 638 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
 639 L<DBIx::Class::Schema::Loader>.
 640
 641 =cut
 642
 643 my $CURRENT_V = 'v7';
 644
 645 my @CLASS_ARGS = qw(
 646     schema_base_class result_base_class additional_base_classes
 647     left_base_classes additional_classes components result_roles
 648 );
 649
 650 # ensure that a peice of object data is a valid arrayref, creating
 651 # an empty one or encapsulating whatever's there.
 652 sub _ensure_arrayref {
 653     my $self = shift;
 654
 655     foreach (@_) {
 656         $self->{$_} ||= [];
 657         $self->{$_} = [ $self->{$_} ]
 658             unless ref $self->{$_} eq 'ARRAY';
 659     }
 660 }
 661
 662 =head2 new
 663
 664 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
 665 by L<DBIx::Class::Schema::Loader>.
 666
 667 =cut
 668
 669 sub new {
 670     my ( $class, %args ) = @_;
 671
 672     if (exists $args{column_accessor_map}) {
 673         $args{col_accessor_map} = delete $args{column_accessor_map};
 674     }
 675
 676     my $self = { %args };
 677
 678     # don't lose undef options
 679     for (values %$self) {
 680         $_ = 0 unless defined $_;
 681     }
 682
 683     bless $self => $class;
 684
 685     if (my $config_file = $self->config_file) {
 686         my $config_opts = do $config_file;
 687
 688         croak "Error reading config from $config_file: $@" if $@;
 689
 690         croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
 691
 692         while (my ($k, $v) = each %$config_opts) {
 693             $self->{$k} = $v unless exists $self->{$k};
 694         }
 695     }
 696
 697     if (defined $self->{result_component_map}) {
 698         if (defined $self->result_components_map) {
 699             croak "Specify only one of result_components_map or result_component_map";
 700         }
 701         $self->result_components_map($self->{result_component_map})
 702     }
 703
 704     if (defined $self->{result_role_map}) {
 705         if (defined $self->result_roles_map) {
 706             croak "Specify only one of result_roles_map or result_role_map";
 707         }
 708         $self->result_roles_map($self->{result_role_map})
 709     }
 710
 711     croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
 712         if ((not defined $self->use_moose) || (not $self->use_moose))
 713             && ((defined $self->result_roles) || (defined $self->result_roles_map));
 714
 715     $self->_ensure_arrayref(qw/additional_classes
 716                                additional_base_classes
 717                                left_base_classes
 718                                components
 719                                result_roles
 720                               /);
 721
 722     $self->_validate_class_args;
 723
 724     croak "result_components_map must be a hash"
 725         if defined $self->result_components_map
 726             && ref $self->result_components_map ne 'HASH';
 727
 728     if ($self->result_components_map) {
 729         my %rc_map = %{ $self->result_components_map };
 730         foreach my $moniker (keys %rc_map) {
 731             $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
 732         }
 733         $self->result_components_map(\%rc_map);
 734     }
 735     else {
 736         $self->result_components_map({});
 737     }
 738     $self->_validate_result_components_map;
 739
 740     croak "result_roles_map must be a hash"
 741         if defined $self->result_roles_map
 742             && ref $self->result_roles_map ne 'HASH';
 743
 744     if ($self->result_roles_map) {
 745         my %rr_map = %{ $self->result_roles_map };
 746         foreach my $moniker (keys %rr_map) {
 747             $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
 748         }
 749         $self->result_roles_map(\%rr_map);
 750     } else {
 751         $self->result_roles_map({});
 752     }
 753     $self->_validate_result_roles_map;
 754
 755     if ($self->use_moose) {
 756         if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
 757             die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
 758                 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
 759         }
 760     }
 761
 762     $self->{monikers} = {};
 763     $self->{tables}   = {};
 764     $self->{class_to_table} = {};
 765     $self->{classes}  = {};
 766     $self->{_upgrading_classes} = {};
 767
 768     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
 769     $self->{schema} ||= $self->{schema_class};
 770
 771     croak "dump_overwrite is deprecated.  Please read the"
 772         . " DBIx::Class::Schema::Loader::Base documentation"
 773             if $self->{dump_overwrite};
 774
 775     $self->{dynamic} = ! $self->{dump_directory};
 776     $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
 777                                                      TMPDIR  => 1,
 778                                                      CLEANUP => 1,
 779                                                    );
 780
 781     $self->{dump_directory} ||= $self->{temp_directory};
 782
 783     $self->real_dump_directory($self->{dump_directory});
 784
 785     $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 786     $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 787
 788     if (not defined $self->naming) {
 789         $self->naming_set(0);
 790     }
 791     else {
 792         $self->naming_set(1);
 793     }
 794
 795     if ((not ref $self->naming) && defined $self->naming) {
 796         my $naming_ver = $self->naming;
 797         $self->{naming} = {
 798             relationships => $naming_ver,
 799             monikers => $naming_ver,
 800             column_accessors => $naming_ver,
 801         };
 802     }
 803
 804     if ($self->naming) {
 805         for (values %{ $self->naming }) {
 806             $_ = $CURRENT_V if $_ eq 'current';
 807         }
 808     }
 809     $self->{naming} ||= {};
 810
 811     if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
 812         croak 'custom_column_info must be a CODE ref';
 813     }
 814
 815     $self->_check_back_compat;
 816
 817     $self->use_namespaces(1) unless defined $self->use_namespaces;
 818     $self->generate_pod(1)   unless defined $self->generate_pod;
 819     $self->pod_comment_mode('auto')         unless defined $self->pod_comment_mode;
 820     $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
 821
 822     if (my $col_collision_map = $self->col_collision_map) {
 823         if (my $reftype = ref $col_collision_map) {
 824             if ($reftype ne 'HASH') {
 825                 croak "Invalid type $reftype for option 'col_collision_map'";
 826             }
 827         }
 828         else {
 829             $self->col_collision_map({ '(.*)' => $col_collision_map });
 830         }
 831     }
 832
 833     if (my $rel_collision_map = $self->rel_collision_map) {
 834         if (my $reftype = ref $rel_collision_map) {
 835             if ($reftype ne 'HASH') {
 836                 croak "Invalid type $reftype for option 'rel_collision_map'";
 837             }
 838         }
 839         else {
 840             $self->rel_collision_map({ '(.*)' => $rel_collision_map });
 841         }
 842     }
 843
 844     if (defined(my $rel_name_map = $self->rel_name_map)) {
 845         my $reftype = ref $rel_name_map;
 846         if ($reftype ne 'HASH' && $reftype ne 'CODE') {
 847             croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
 848         }
 849     }
 850
 851     $self;
 852 }
 853
 854 sub _check_back_compat {
 855     my ($self) = @_;
 856
 857 # dynamic schemas will always be in 0.04006 mode, unless overridden
 858     if ($self->dynamic) {
 859 # just in case, though no one is likely to dump a dynamic schema
 860         $self->schema_version_to_dump('0.04006');
 861
 862         if (not $self->naming_set) {
 863             warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 864
 865 Dynamic schema detected, will run in 0.04006 mode.
 866
 867 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 868 to disable this warning.
 869
 870 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 871 details.
 872 EOF
 873         }
 874         else {
 875             $self->_upgrading_from('v4');
 876         }
 877
 878         if ((not defined $self->use_namespaces) && ($self->naming_set)) {
 879             $self->use_namespaces(1);
 880         }
 881
 882         $self->naming->{relationships} ||= 'v4';
 883         $self->naming->{monikers}      ||= 'v4';
 884
 885         if ($self->use_namespaces) {
 886             $self->_upgrading_from_load_classes(1);
 887         }
 888         else {
 889             $self->use_namespaces(0);
 890         }
 891
 892         return;
 893     }
 894
 895 # otherwise check if we need backcompat mode for a static schema
 896     my $filename = $self->get_dump_filename($self->schema_class);
 897     return unless -e $filename;
 898
 899     my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
 900       $self->_parse_generated_file($filename);
 901
 902     return unless $old_ver;
 903
 904     # determine if the existing schema was dumped with use_moose => 1
 905     if (! defined $self->use_moose) {
 906         $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
 907     }
 908
 909     my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
 910
 911     my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
 912     my $ds = eval $result_namespace;
 913     die <<"EOF" if $@;
 914 Could not eval expression '$result_namespace' for result_namespace from
 915 $filename: $@
 916 EOF
 917     $result_namespace = $ds || '';
 918
 919     if ($load_classes && (not defined $self->use_namespaces)) {
 920         warn <<"EOF"  unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 921
 922 'load_classes;' static schema detected, turning off 'use_namespaces'.
 923
 924 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
 925 variable to disable this warning.
 926
 927 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 928 details.
 929 EOF
 930         $self->use_namespaces(0);
 931     }
 932     elsif ($load_classes && $self->use_namespaces) {
 933         $self->_upgrading_from_load_classes(1);
 934     }
 935     elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
 936         $self->_downgrading_to_load_classes(
 937             $result_namespace || 'Result'
 938         );
 939     }
 940     elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
 941         if (not $self->result_namespace) {
 942             $self->result_namespace($result_namespace || 'Result');
 943         }
 944         elsif ($result_namespace ne $self->result_namespace) {
 945             $self->_rewriting_result_namespace(
 946                 $result_namespace || 'Result'
 947             );
 948         }
 949     }
 950
 951     # XXX when we go past .0 this will need fixing
 952     my ($v) = $old_ver =~ /([1-9])/;
 953     $v = "v$v";
 954
 955     return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
 956
 957     if (not %{ $self->naming }) {
 958         warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 959
 960 Version $old_ver static schema detected, turning on backcompat mode.
 961
 962 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 963 to disable this warning.
 964
 965 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
 966
 967 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
 968 from version 0.04006.
 969 EOF
 970
 971         $self->naming->{relationships}    ||= $v;
 972         $self->naming->{monikers}         ||= $v;
 973         $self->naming->{column_accessors} ||= $v;
 974
 975         $self->schema_version_to_dump($old_ver);
 976     }
 977     else {
 978         $self->_upgrading_from($v);
 979     }
 980 }
 981
 982 sub _validate_class_args {
 983     my $self = shift;
 984
 985     foreach my $k (@CLASS_ARGS) {
 986         next unless $self->$k;
 987
 988         my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
 989         $self->_validate_classes($k, \@classes);
 990     }
 991 }
 992
 993 sub _validate_result_components_map {
 994     my $self = shift;
 995
 996     foreach my $classes (values %{ $self->result_components_map }) {
 997         $self->_validate_classes('result_components_map', $classes);
 998     }
 999 }
1000
1001 sub _validate_result_roles_map {
1002     my $self = shift;
1003
1004     foreach my $classes (values %{ $self->result_roles_map }) {
1005         $self->_validate_classes('result_roles_map', $classes);
1006     }
1007 }
1008
1009 sub _validate_classes {
1010     my $self = shift;
1011     my $key  = shift;
1012     my $classes = shift;
1013
1014     # make a copy to not destroy original
1015     my @classes = @$classes;
1016
1017     foreach my $c (@classes) {
1018         # components default to being under the DBIx::Class namespace unless they
1019         # are preceeded with a '+'
1020         if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1021             $c = 'DBIx::Class::' . $c;
1022         }
1023
1024         # 1 == installed, 0 == not installed, undef == invalid classname
1025         my $installed = Class::Inspector->installed($c);
1026         if ( defined($installed) ) {
1027             if ( $installed == 0 ) {
1028                 croak qq/$c, as specified in the loader option "$key", is not installed/;
1029             }
1030         } else {
1031             croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1032         }
1033     }
1034 }
1035
1036
1037 sub _find_file_in_inc {
1038     my ($self, $file) = @_;
1039
1040     foreach my $prefix (@INC) {
1041         my $fullpath = File::Spec->catfile($prefix, $file);
1042         return $fullpath if -f $fullpath
1043             # abs_path throws on Windows for nonexistant files
1044             and (try { Cwd::abs_path($fullpath) }) ne
1045                ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1046     }
1047
1048     return;
1049 }
1050
1051 sub _find_class_in_inc {
1052     my ($self, $class) = @_;
1053
1054     return $self->_find_file_in_inc(class_path($class));
1055 }
1056
1057 sub _rewriting {
1058     my $self = shift;
1059
1060     return $self->_upgrading_from
1061         || $self->_upgrading_from_load_classes
1062         || $self->_downgrading_to_load_classes
1063         || $self->_rewriting_result_namespace
1064     ;
1065 }
1066
1067 sub _rewrite_old_classnames {
1068     my ($self, $code) = @_;
1069
1070     return $code unless $self->_rewriting;
1071
1072     my %old_classes = reverse %{ $self->_upgrading_classes };
1073
1074     my $re = join '|', keys %old_classes;
1075     $re = qr/\b($re)\b/;
1076
1077     $code =~ s/$re/$old_classes{$1} || $1/eg;
1078
1079     return $code;
1080 }
1081
1082 sub _load_external {
1083     my ($self, $class) = @_;
1084
1085     return if $self->{skip_load_external};
1086
1087     # so that we don't load our own classes, under any circumstances
1088     local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1089
1090     my $real_inc_path = $self->_find_class_in_inc($class);
1091
1092     my $old_class = $self->_upgrading_classes->{$class}
1093         if $self->_rewriting;
1094
1095     my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1096         if $old_class && $old_class ne $class;
1097
1098     return unless $real_inc_path || $old_real_inc_path;
1099
1100     if ($real_inc_path) {
1101         # If we make it to here, we loaded an external definition
1102         warn qq/# Loaded external class definition for '$class'\n/
1103             if $self->debug;
1104
1105         my $code = $self->_rewrite_old_classnames(scalar read_file($real_inc_path, binmode => ':encoding(UTF-8)'));
1106
1107         if ($self->dynamic) { # load the class too
1108             eval_package_without_redefine_warnings($class, $code);
1109         }
1110
1111         $self->_ext_stmt($class,
1112           qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1113          .qq|# They are now part of the custom portion of this file\n|
1114          .qq|# for you to hand-edit.  If you do not either delete\n|
1115          .qq|# this section or remove that file from \@INC, this section\n|
1116          .qq|# will be repeated redundantly when you re-create this\n|
1117          .qq|# file again via Loader!  See skip_load_external to disable\n|
1118          .qq|# this feature.\n|
1119         );
1120         chomp $code;
1121         $self->_ext_stmt($class, $code);
1122         $self->_ext_stmt($class,
1123             qq|# End of lines loaded from '$real_inc_path' |
1124         );
1125     }
1126
1127     if ($old_real_inc_path) {
1128         my $code = read_file($old_real_inc_path, binmode => ':encoding(UTF-8)');
1129
1130         $self->_ext_stmt($class, <<"EOF");
1131
1132 # These lines were loaded from '$old_real_inc_path',
1133 # based on the Result class name that would have been created by an older
1134 # version of the Loader. For a static schema, this happens only once during
1135 # upgrade. See skip_load_external to disable this feature.
1136 EOF
1137
1138         $code = $self->_rewrite_old_classnames($code);
1139
1140         if ($self->dynamic) {
1141             warn <<"EOF";
1142
1143 Detected external content in '$old_real_inc_path', a class name that would have
1144 been used by an older version of the Loader.
1145
1146 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1147 new name of the Result.
1148 EOF
1149             eval_package_without_redefine_warnings($class, $code);
1150         }
1151
1152         chomp $code;
1153         $self->_ext_stmt($class, $code);
1154         $self->_ext_stmt($class,
1155             qq|# End of lines loaded from '$old_real_inc_path' |
1156         );
1157     }
1158 }
1159
1160 =head2 load
1161
1162 Does the actual schema-construction work.
1163
1164 =cut
1165
1166 sub load {
1167     my $self = shift;
1168
1169     $self->_load_tables(
1170         $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1171     );
1172 }
1173
1174 =head2 rescan
1175
1176 Arguments: schema
1177
1178 Rescan the database for changes. Returns a list of the newly added table
1179 monikers.
1180
1181 The schema argument should be the schema class or object to be affected.  It
1182 should probably be derived from the original schema_class used during L</load>.
1183
1184 =cut
1185
1186 sub rescan {
1187     my ($self, $schema) = @_;
1188
1189     $self->{schema} = $schema;
1190     $self->_relbuilder->{schema} = $schema;
1191
1192     my @created;
1193     my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1194
1195     foreach my $table (@current) {
1196         if(!exists $self->{_tables}->{$table}) {
1197             push(@created, $table);
1198         }
1199     }
1200
1201     my %current;
1202     @current{@current} = ();
1203     foreach my $table (keys %{ $self->{_tables} }) {
1204         if (not exists $current{$table}) {
1205             $self->_unregister_source_for_table($table);
1206         }
1207     }
1208
1209     delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1210
1211     my $loaded = $self->_load_tables(@current);
1212
1213     return map { $self->monikers->{$_} } @created;
1214 }
1215
1216 sub _relbuilder {
1217     my ($self) = @_;
1218
1219     return if $self->{skip_relationships};
1220
1221     return $self->{relbuilder} ||= do {
1222
1223         no warnings 'uninitialized';
1224         my $relbuilder_suff =
1225             {qw{
1226                 v4  ::Compat::v0_040
1227                 v5  ::Compat::v0_05
1228                 v6  ::Compat::v0_06
1229             }}
1230             ->{ $self->naming->{relationships}};
1231
1232         my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1233         $self->ensure_class_loaded($relbuilder_class);
1234         $relbuilder_class->new( $self );
1235
1236     };
1237 }
1238
1239 sub _load_tables {
1240     my ($self, @tables) = @_;
1241
1242     # Save the new tables to the tables list
1243     foreach (@tables) {
1244         $self->{_tables}->{$_} = 1;
1245     }
1246
1247     $self->_make_src_class($_) for @tables;
1248
1249     # sanity-check for moniker clashes
1250     my $inverse_moniker_idx;
1251     for (keys %{$self->monikers}) {
1252       push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1253     }
1254
1255     my @clashes;
1256     for (keys %$inverse_moniker_idx) {
1257       my $tables = $inverse_moniker_idx->{$_};
1258       if (@$tables > 1) {
1259         push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1260           join (', ', map { "'$_'" } @$tables),
1261           $_,
1262         );
1263       }
1264     }
1265
1266     if (@clashes) {
1267       die   'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1268           . 'Either change the naming style, or supply an explicit moniker_map: '
1269           . join ('; ', @clashes)
1270           . "\n"
1271       ;
1272     }
1273
1274
1275     $self->_setup_src_meta($_) for @tables;
1276
1277     if(!$self->skip_relationships) {
1278         # The relationship loader needs a working schema
1279         $self->{quiet} = 1;
1280         local $self->{dump_directory} = $self->{temp_directory};
1281         $self->_reload_classes(\@tables);
1282         $self->_load_relationships(\@tables);
1283         $self->{quiet} = 0;
1284
1285         # Remove that temp dir from INC so it doesn't get reloaded
1286         @INC = grep $_ ne $self->dump_directory, @INC;
1287     }
1288
1289     $self->_load_roles($_) for @tables;
1290
1291     $self->_load_external($_)
1292         for map { $self->classes->{$_} } @tables;
1293
1294     # Reload without unloading first to preserve any symbols from external
1295     # packages.
1296     $self->_reload_classes(\@tables, { unload => 0 });
1297
1298     # Drop temporary cache
1299     delete $self->{_cache};
1300
1301     return \@tables;
1302 }
1303
1304 sub _reload_classes {
1305     my ($self, $tables, $opts) = @_;
1306
1307     my @tables = @$tables;
1308
1309     my $unload = $opts->{unload};
1310     $unload = 1 unless defined $unload;
1311
1312     # so that we don't repeat custom sections
1313     @INC = grep $_ ne $self->dump_directory, @INC;
1314
1315     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1316
1317     unshift @INC, $self->dump_directory;
1318
1319     my @to_register;
1320     my %have_source = map { $_ => $self->schema->source($_) }
1321         $self->schema->sources;
1322
1323     for my $table (@tables) {
1324         my $moniker = $self->monikers->{$table};
1325         my $class = $self->classes->{$table};
1326
1327         {
1328             no warnings 'redefine';
1329             local *Class::C3::reinitialize = sub {};  # to speed things up, reinitialized below
1330             use warnings;
1331
1332             if (my $mc = $self->_moose_metaclass($class)) {
1333                 $mc->make_mutable;
1334             }
1335             Class::Unload->unload($class) if $unload;
1336             my ($source, $resultset_class);
1337             if (
1338                 ($source = $have_source{$moniker})
1339                 && ($resultset_class = $source->resultset_class)
1340                 && ($resultset_class ne 'DBIx::Class::ResultSet')
1341             ) {
1342                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1343                 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1344                     $mc->make_mutable;
1345                 }
1346                 Class::Unload->unload($resultset_class) if $unload;
1347                 $self->_reload_class($resultset_class) if $has_file;
1348             }
1349             $self->_reload_class($class);
1350         }
1351         push @to_register, [$moniker, $class];
1352     }
1353
1354     Class::C3->reinitialize;
1355     for (@to_register) {
1356         $self->schema->register_class(@$_);
1357     }
1358 }
1359
1360 sub _moose_metaclass {
1361   return undef unless $INC{'Class/MOP.pm'};   # if CMOP is not loaded the class could not have loaded in the 1st place
1362
1363   my $class = $_[1];
1364
1365   my $mc = try { Class::MOP::class_of($class) }
1366     or return undef;
1367
1368   return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1369 }
1370
1371 # We use this instead of ensure_class_loaded when there are package symbols we
1372 # want to preserve.
1373 sub _reload_class {
1374     my ($self, $class) = @_;
1375
1376     delete $INC{ +class_path($class) };
1377
1378     try {
1379         eval_package_without_redefine_warnings ($class, "require $class");
1380     }
1381     catch {
1382         my $source = read_file($self->_get_dump_filename($class), binmode => ':encoding(UTF-8)');
1383         die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1384     };
1385 }
1386
1387 sub _get_dump_filename {
1388     my ($self, $class) = (@_);
1389
1390     $class =~ s{::}{/}g;
1391     return $self->dump_directory . q{/} . $class . q{.pm};
1392 }
1393
1394 =head2 get_dump_filename
1395
1396 Arguments: class
1397
1398 Returns the full path to the file for a class that the class has been or will
1399 be dumped to. This is a file in a temp dir for a dynamic schema.
1400
1401 =cut
1402
1403 sub get_dump_filename {
1404     my ($self, $class) = (@_);
1405
1406     local $self->{dump_directory} = $self->real_dump_directory;
1407
1408     return $self->_get_dump_filename($class);
1409 }
1410
1411 sub _ensure_dump_subdirs {
1412     my ($self, $class) = (@_);
1413
1414     my @name_parts = split(/::/, $class);
1415     pop @name_parts; # we don't care about the very last element,
1416                      # which is a filename
1417
1418     my $dir = $self->dump_directory;
1419     while (1) {
1420         if(!-d $dir) {
1421             mkdir($dir) or croak "mkdir('$dir') failed: $!";
1422         }
1423         last if !@name_parts;
1424         $dir = File::Spec->catdir($dir, shift @name_parts);
1425     }
1426 }
1427
1428 sub _dump_to_dir {
1429     my ($self, @classes) = @_;
1430
1431     my $schema_class = $self->schema_class;
1432     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1433
1434     my $target_dir = $self->dump_directory;
1435     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1436         unless $self->{dynamic} or $self->{quiet};
1437
1438     my $schema_text =
1439           qq|package $schema_class;\n\n|
1440         . qq|# Created by DBIx::Class::Schema::Loader\n|
1441         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1442
1443     if ($self->use_moose) {
1444         $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1445     }
1446     else {
1447         $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1448     }
1449
1450     if ($self->use_namespaces) {
1451         $schema_text .= qq|__PACKAGE__->load_namespaces|;
1452         my $namespace_options;
1453
1454         my @attr = qw/resultset_namespace default_resultset_class/;
1455
1456         unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1457
1458         for my $attr (@attr) {
1459             if ($self->$attr) {
1460                 my $code = dumper_squashed $self->$attr;
1461                 $namespace_options .= qq|    $attr => $code,\n|
1462             }
1463         }
1464         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1465         $schema_text .= qq|;\n|;
1466     }
1467     else {
1468         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1469     }
1470
1471     {
1472         local $self->{version_to_dump} = $self->schema_version_to_dump;
1473         $self->_write_classfile($schema_class, $schema_text, 1);
1474     }
1475
1476     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1477
1478     foreach my $src_class (@classes) {
1479         my $src_text =
1480               qq|package $src_class;\n\n|
1481             . qq|# Created by DBIx::Class::Schema::Loader\n|
1482             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1483
1484         $src_text .= $self->_make_pod_heading($src_class);
1485
1486         $src_text .= qq|use strict;\nuse warnings;\n\n|;
1487
1488         $src_text .= $self->_base_class_pod($result_base_class)
1489             unless $result_base_class eq 'DBIx::Class::Core';
1490
1491         if ($self->use_moose) {
1492             $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1493
1494             # these options 'use base' which is compile time
1495             if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1496                 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1497             }
1498             else {
1499                 $src_text .= qq|\nextends '$result_base_class';\n|;
1500             }
1501         }
1502         else {
1503              $src_text .= qq|use base '$result_base_class';\n|;
1504         }
1505
1506         $self->_write_classfile($src_class, $src_text);
1507     }
1508
1509     # remove Result dir if downgrading from use_namespaces, and there are no
1510     # files left.
1511     if (my $result_ns = $self->_downgrading_to_load_classes
1512                         || $self->_rewriting_result_namespace) {
1513         my $result_namespace = $self->_result_namespace(
1514             $schema_class,
1515             $result_ns,
1516         );
1517
1518         (my $result_dir = $result_namespace) =~ s{::}{/}g;
1519         $result_dir = $self->dump_directory . '/' . $result_dir;
1520
1521         unless (my @files = glob "$result_dir/*") {
1522             rmdir $result_dir;
1523         }
1524     }
1525
1526     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1527
1528 }
1529
1530 sub _sig_comment {
1531     my ($self, $version, $ts) = @_;
1532     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1533          . qq| v| . $version
1534          . q| @ | . $ts
1535          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1536 }
1537
1538 sub _write_classfile {
1539     my ($self, $class, $text, $is_schema) = @_;
1540
1541     my $filename = $self->_get_dump_filename($class);
1542     $self->_ensure_dump_subdirs($class);
1543
1544     if (-f $filename && $self->really_erase_my_files) {
1545         warn "Deleting existing file '$filename' due to "
1546             . "'really_erase_my_files' setting\n" unless $self->{quiet};
1547         unlink($filename);
1548     }
1549
1550     my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1551         = $self->_parse_generated_file($filename);
1552
1553     if (! $old_gen && -f $filename) {
1554         croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1555             . " it does not appear to have been generated by Loader"
1556     }
1557
1558     my $custom_content = $old_custom || '';
1559
1560     # prepend extra custom content from a *renamed* class (singularization effect)
1561     if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1562         my $old_filename = $self->_get_dump_filename($renamed_class);
1563
1564         if (-f $old_filename) {
1565             my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1566
1567             $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1568
1569             $custom_content = join ("\n", '', $extra_custom, $custom_content)
1570                 if $extra_custom;
1571
1572             unlink $old_filename;
1573         }
1574     }
1575
1576     $custom_content ||= $self->_default_custom_content($is_schema);
1577
1578     # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1579     # If there is already custom content, which does not have the Moose content, add it.
1580     if ($self->use_moose) {
1581
1582         my $non_moose_custom_content = do {
1583             local $self->{use_moose} = 0;
1584             $self->_default_custom_content;
1585         };
1586
1587         if ($custom_content eq $non_moose_custom_content) {
1588             $custom_content = $self->_default_custom_content($is_schema);
1589         }
1590         elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1591             $custom_content .= $self->_default_custom_content($is_schema);
1592         }
1593     }
1594     elsif (defined $self->use_moose && $old_gen) {
1595         croak 'It is not possible to "downgrade" a schema that was loaded with use_moose => 1 to use_moose => 0, due to differing custom content'
1596             if $old_gen =~ /use \s+ MooseX?\b/x;
1597     }
1598
1599     $custom_content = $self->_rewrite_old_classnames($custom_content);
1600
1601     $text .= qq|$_\n|
1602         for @{$self->{_dump_storage}->{$class} || []};
1603
1604     # Check and see if the dump is infact differnt
1605
1606     my $compare_to;
1607     if ($old_md5) {
1608       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1609       if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1610         return unless $self->_upgrading_from && $is_schema;
1611       }
1612     }
1613
1614     $text .= $self->_sig_comment(
1615       $self->version_to_dump,
1616       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1617     );
1618
1619     open(my $fh, '>:encoding(UTF-8)', $filename)
1620         or croak "Cannot open '$filename' for writing: $!";
1621
1622     # Write the top half and its MD5 sum
1623     print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1624
1625     # Write out anything loaded via external partial class file in @INC
1626     print $fh qq|$_\n|
1627         for @{$self->{_ext_storage}->{$class} || []};
1628
1629     # Write out any custom content the user has added
1630     print $fh $custom_content;
1631
1632     close($fh)
1633         or croak "Error closing '$filename': $!";
1634 }
1635
1636 sub _default_moose_custom_content {
1637     my ($self, $is_schema) = @_;
1638
1639     if (not $is_schema) {
1640         return qq|\n__PACKAGE__->meta->make_immutable;|;
1641     }
1642
1643     return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1644 }
1645
1646 sub _default_custom_content {
1647     my ($self, $is_schema) = @_;
1648     my $default = qq|\n\n# You can replace this text with custom|
1649          . qq| code or comments, and it will be preserved on regeneration|;
1650     if ($self->use_moose) {
1651         $default .= $self->_default_moose_custom_content($is_schema);
1652     }
1653     $default .= qq|\n1;\n|;
1654     return $default;
1655 }
1656
1657 sub _parse_generated_file {
1658     my ($self, $fn) = @_;
1659
1660     return unless -f $fn;
1661
1662     open(my $fh, '<:encoding(UTF-8)', $fn)
1663         or croak "Cannot open '$fn' for reading: $!";
1664
1665     my $mark_re =
1666         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1667
1668     my ($md5, $ts, $ver, $gen);
1669     while(<$fh>) {
1670         if(/$mark_re/) {
1671             my $pre_md5 = $1;
1672             $md5 = $2;
1673
1674             # Pull out the version and timestamp from the line above
1675             ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1676
1677             $gen .= $pre_md5;
1678             croak "Checksum mismatch in '$fn', 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"
1679                 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
1680
1681             last;
1682         }
1683         else {
1684             $gen .= $_;
1685         }
1686     }
1687
1688     my $custom = do { local $/; <$fh> }
1689         if $md5;
1690
1691     close ($fh);
1692
1693     return ($gen, $md5, $ver, $ts, $custom);
1694 }
1695
1696 sub _use {
1697     my $self = shift;
1698     my $target = shift;
1699
1700     foreach (@_) {
1701         warn "$target: use $_;" if $self->debug;
1702         $self->_raw_stmt($target, "use $_;");
1703     }
1704 }
1705
1706 sub _inject {
1707     my $self = shift;
1708     my $target = shift;
1709
1710     my $blist = join(q{ }, @_);
1711
1712     return unless $blist;
1713
1714     warn "$target: use base qw/$blist/;" if $self->debug;
1715     $self->_raw_stmt($target, "use base qw/$blist/;");
1716 }
1717
1718 sub _with {
1719     my $self = shift;
1720     my $target = shift;
1721
1722     my $rlist = join(q{, }, map { qq{'$_'} } @_);
1723
1724     return unless $rlist;
1725
1726     warn "$target: with $rlist;" if $self->debug;
1727     $self->_raw_stmt($target, "\nwith $rlist;");
1728 }
1729
1730 sub _result_namespace {
1731     my ($self, $schema_class, $ns) = @_;
1732     my @result_namespace;
1733
1734     $ns = $ns->[0] if ref $ns;
1735
1736     if ($ns =~ /^\+(.*)/) {
1737         # Fully qualified namespace
1738         @result_namespace = ($1)
1739     }
1740     else {
1741         # Relative namespace
1742         @result_namespace = ($schema_class, $ns);
1743     }
1744
1745     return wantarray ? @result_namespace : join '::', @result_namespace;
1746 }
1747
1748 # Create class with applicable bases, setup monikers, etc
1749 sub _make_src_class {
1750     my ($self, $table) = @_;
1751
1752     my $schema       = $self->schema;
1753     my $schema_class = $self->schema_class;
1754
1755     my $table_moniker = $self->_table2moniker($table);
1756     my @result_namespace = ($schema_class);
1757     if ($self->use_namespaces) {
1758         my $result_namespace = $self->result_namespace || 'Result';
1759         @result_namespace = $self->_result_namespace(
1760             $schema_class,
1761             $result_namespace,
1762         );
1763     }
1764     my $table_class = join(q{::}, @result_namespace, $table_moniker);
1765
1766     if ((my $upgrading_v = $self->_upgrading_from)
1767             || $self->_rewriting) {
1768         local $self->naming->{monikers} = $upgrading_v
1769             if $upgrading_v;
1770
1771         my @result_namespace = @result_namespace;
1772         if ($self->_upgrading_from_load_classes) {
1773             @result_namespace = ($schema_class);
1774         }
1775         elsif (my $ns = $self->_downgrading_to_load_classes) {
1776             @result_namespace = $self->_result_namespace(
1777                 $schema_class,
1778                 $ns,
1779             );
1780         }
1781         elsif ($ns = $self->_rewriting_result_namespace) {
1782             @result_namespace = $self->_result_namespace(
1783                 $schema_class,
1784                 $ns,
1785             );
1786         }
1787
1788         my $old_class = join(q{::}, @result_namespace,
1789             $self->_table2moniker($table));
1790
1791         $self->_upgrading_classes->{$table_class} = $old_class
1792             unless $table_class eq $old_class;
1793     }
1794
1795     $self->classes->{$table}  = $table_class;
1796     $self->monikers->{$table} = $table_moniker;
1797     $self->tables->{$table_moniker} = $table;
1798     $self->class_to_table->{$table_class} = $table;
1799
1800     $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
1801
1802     $self->_use   ($table_class, @{$self->additional_classes});
1803
1804     $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
1805
1806     $self->_inject($table_class, @{$self->left_base_classes});
1807
1808     my @components = @{ $self->components || [] };
1809
1810     push @components, @{ $self->result_components_map->{$table_moniker} }
1811         if exists $self->result_components_map->{$table_moniker};
1812
1813     my @fq_components = @components;
1814     foreach my $component (@fq_components) {
1815         if ($component !~ s/^\+//) {
1816             $component = "DBIx::Class::$component";
1817         }
1818     }
1819
1820     $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
1821
1822     $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
1823
1824     $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
1825
1826     $self->_inject($table_class, @{$self->additional_base_classes});
1827 }
1828
1829 sub _is_result_class_method {
1830     my ($self, $name, $table_name) = @_;
1831
1832     my $table_moniker = $table_name ? $self->monikers->{$table_name} : '';
1833
1834     $self->_result_class_methods({})
1835         if not defined $self->_result_class_methods;
1836
1837     if (not exists $self->_result_class_methods->{$table_moniker}) {
1838         my (@methods, %methods);
1839         my $base       = $self->result_base_class || 'DBIx::Class::Core';
1840
1841         my @components = @{ $self->components || [] };
1842
1843         push @components, @{ $self->result_components_map->{$table_moniker} }
1844             if exists $self->result_components_map->{$table_moniker};
1845
1846         for my $c (@components) {
1847             $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
1848         }
1849
1850         my @roles = @{ $self->result_roles || [] };
1851
1852         push @roles, @{ $self->result_roles_map->{$table_moniker} }
1853             if exists $self->result_roles_map->{$table_moniker};
1854
1855         for my $class ($base, @components,
1856                        ($self->use_moose ? 'Moose::Object' : ()), @roles) {
1857             $self->ensure_class_loaded($class);
1858
1859             push @methods, @{ Class::Inspector->methods($class) || [] };
1860         }
1861
1862         push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1863
1864         @methods{@methods} = ();
1865
1866         $self->_result_class_methods->{$table_moniker} = \%methods;
1867     }
1868     my $result_methods = $self->_result_class_methods->{$table_moniker};
1869
1870     return exists $result_methods->{$name};
1871 }
1872
1873 sub _resolve_col_accessor_collisions {
1874     my ($self, $table, $col_info) = @_;
1875
1876     my $table_name = ref $table ? $$table : $table;
1877
1878     while (my ($col, $info) = each %$col_info) {
1879         my $accessor = $info->{accessor} || $col;
1880
1881         next if $accessor eq 'id'; # special case (very common column)
1882
1883         if ($self->_is_result_class_method($accessor, $table_name)) {
1884             my $mapped = 0;
1885
1886             if (my $map = $self->col_collision_map) {
1887                 for my $re (keys %$map) {
1888                     if (my @matches = $col =~ /$re/) {
1889                         $info->{accessor} = sprintf $map->{$re}, @matches;
1890                         $mapped = 1;
1891                     }
1892                 }
1893             }
1894
1895             if (not $mapped) {
1896                 warn <<"EOF";
1897 Column '$col' in table '$table_name' collides with an inherited method.
1898 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1899 EOF
1900                 $info->{accessor} = undef;
1901             }
1902         }
1903     }
1904 }
1905
1906 # use the same logic to run moniker_map, col_accessor_map
1907 sub _run_user_map {
1908     my ( $self, $map, $default_code, $ident, @extra ) = @_;
1909
1910     my $default_ident = $default_code->( $ident, @extra );
1911     my $new_ident;
1912     if( $map && ref $map eq 'HASH' ) {
1913         $new_ident = $map->{ $ident };
1914     }
1915     elsif( $map && ref $map eq 'CODE' ) {
1916         $new_ident = $map->( $ident, $default_ident, @extra );
1917     }
1918
1919     $new_ident ||= $default_ident;
1920
1921     return $new_ident;
1922 }
1923
1924 sub _default_column_accessor_name {
1925     my ( $self, $column_name ) = @_;
1926
1927     my $accessor_name = $column_name;
1928     $accessor_name =~ s/\W+/_/g;
1929
1930     if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
1931         # older naming just lc'd the col accessor and that's all.
1932         return lc $accessor_name;
1933     }
1934     elsif (($self->naming->{column_accessors}||'') eq 'preserve') {
1935         return $accessor_name;
1936     }
1937
1938     return join '_', map lc, split_name $column_name;
1939 }
1940
1941 sub _make_column_accessor_name {
1942     my ($self, $column_name, $column_context_info ) = @_;
1943
1944     my $accessor = $self->_run_user_map(
1945         $self->col_accessor_map,
1946         sub { $self->_default_column_accessor_name( shift ) },
1947         $column_name,
1948         $column_context_info,
1949        );
1950
1951     return $accessor;
1952 }
1953
1954 sub _quote {
1955     my ($self, $identifier) = @_;
1956
1957     my $qt = $self->schema->storage->sql_maker->quote_char || '';
1958
1959     if (ref $qt) {
1960         return $qt->[0] . $identifier . $qt->[1];
1961     }
1962
1963     return "${qt}${identifier}${qt}";
1964 }
1965
1966 # Set up metadata (cols, pks, etc)
1967 sub _setup_src_meta {
1968     my ($self, $table) = @_;
1969
1970     my $schema       = $self->schema;
1971     my $schema_class = $self->schema_class;
1972
1973     my $table_class   = $self->classes->{$table};
1974     my $table_moniker = $self->monikers->{$table};
1975
1976     my $table_name = $table;
1977
1978     my $sql_maker  = $self->schema->storage->sql_maker;
1979     my $name_sep   = $sql_maker->name_sep;
1980
1981     if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1982         $table_name = \ $self->_quote($table_name);
1983     }
1984
1985     my $full_table_name = ($self->qualify_objects ?
1986         ($self->_quote($self->db_schema) . '.') : '')
1987         . (ref $table_name ? $$table_name : $table_name);
1988
1989     # be careful to not create refs Data::Dump can "optimize"
1990     $full_table_name = \do {"".$full_table_name} if ref $table_name;
1991
1992     $self->_dbic_stmt($table_class, 'table', $full_table_name);
1993
1994     my $cols     = $self->_table_columns($table);
1995     my $col_info = $self->__columns_info_for($table);
1996
1997     ### generate all the column accessor names
1998     while (my ($col, $info) = each %$col_info) {
1999         # hashref of other info that could be used by
2000         # user-defined accessor map functions
2001         my $context = {
2002             table_class     => $table_class,
2003             table_moniker   => $table_moniker,
2004             table_name      => $table_name,
2005             full_table_name => $full_table_name,
2006             schema_class    => $schema_class,
2007             column_info     => $info,
2008         };
2009
2010         $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2011     }
2012
2013     $self->_resolve_col_accessor_collisions($table, $col_info);
2014
2015     # prune any redundant accessor names
2016     while (my ($col, $info) = each %$col_info) {
2017         no warnings 'uninitialized';
2018         delete $info->{accessor} if $info->{accessor} eq $col;
2019     }
2020
2021     my $fks = $self->_table_fk_info($table);
2022
2023     foreach my $fkdef (@$fks) {
2024         for my $col (@{ $fkdef->{local_columns} }) {
2025             $col_info->{$col}{is_foreign_key} = 1;
2026         }
2027     }
2028
2029     my $pks = $self->_table_pk_info($table) || [];
2030
2031     my %uniq_tag; # used to eliminate duplicate uniqs
2032
2033     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2034
2035     my $uniqs = $self->_table_uniq_info($table) || [];
2036     my @uniqs;
2037
2038     foreach my $uniq (@$uniqs) {
2039         my ($name, $cols) = @$uniq;
2040         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2041         push @uniqs, [$name, $cols];
2042     }
2043
2044     my @non_nullable_uniqs = grep {
2045         all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2046     } @uniqs;
2047
2048     if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2049         my @by_colnum = sort { $b->[0] <=> $a->[0] }
2050             map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2051
2052         if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2053             my @keys = map $_->[1], @by_colnum;
2054
2055             my $pk = $keys[0];
2056
2057             # remove the uniq from list
2058             @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2059
2060             $pks = $pk->[1];
2061         }
2062     }
2063
2064     foreach my $pkcol (@$pks) {
2065         $col_info->{$pkcol}{is_nullable} = 0;
2066     }
2067
2068     $self->_dbic_stmt(
2069         $table_class,
2070         'add_columns',
2071         map { $_, ($col_info->{$_}||{}) } @$cols
2072     );
2073
2074     $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2075         if @$pks;
2076
2077     foreach my $uniq (@uniqs) {
2078         my ($name, $cols) = @$uniq;
2079         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2080     }
2081 }
2082
2083 sub __columns_info_for {
2084     my ($self, $table) = @_;
2085
2086     my $result = $self->_columns_info_for($table);
2087
2088     while (my ($col, $info) = each %$result) {
2089         $info = { %$info, %{ $self->_custom_column_info  ($table, $col, $info) } };
2090         $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2091
2092         $result->{$col} = $info;
2093     }
2094
2095     return $result;
2096 }
2097
2098 =head2 tables
2099
2100 Returns a sorted list of loaded tables, using the original database table
2101 names.
2102
2103 =cut
2104
2105 sub tables {
2106     my $self = shift;
2107
2108     return keys %{$self->_tables};
2109 }
2110
2111 # Make a moniker from a table
2112 sub _default_table2moniker {
2113     no warnings 'uninitialized';
2114     my ($self, $table) = @_;
2115
2116     if ($self->naming->{monikers} eq 'v4') {
2117         return join '', map ucfirst, split /[\W_]+/, lc $table;
2118     }
2119     elsif ($self->naming->{monikers} eq 'v5') {
2120         return join '', map ucfirst, split /[\W_]+/,
2121             Lingua::EN::Inflect::Number::to_S(lc $table);
2122     }
2123     elsif ($self->naming->{monikers} eq 'v6') {
2124         (my $as_phrase = lc $table) =~ s/_+/ /g;
2125         my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2126
2127         return join '', map ucfirst, split /\W+/, $inflected;
2128     }
2129
2130     my @words = map lc, split_name $table;
2131     my $as_phrase = join ' ', @words;
2132
2133     my $inflected = $self->naming->{monikers} eq 'plural' ?
2134         Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2135         :
2136         $self->naming->{monikers} eq 'preserve' ?
2137             $as_phrase
2138             :
2139             Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2140
2141     return join '', map ucfirst, split /\W+/, $inflected;
2142 }
2143
2144 sub _table2moniker {
2145     my ( $self, $table ) = @_;
2146
2147     $self->_run_user_map(
2148         $self->moniker_map,
2149         sub { $self->_default_table2moniker( shift ) },
2150         $table
2151        );
2152 }
2153
2154 sub _load_relationships {
2155     my ($self, $tables) = @_;
2156
2157     my @tables;
2158
2159     foreach my $table (@$tables) {
2160         my $tbl_fk_info = $self->_table_fk_info($table);
2161         foreach my $fkdef (@$tbl_fk_info) {
2162             $fkdef->{remote_source} =
2163                 $self->monikers->{delete $fkdef->{remote_table}};
2164         }
2165         my $tbl_uniq_info = $self->_table_uniq_info($table);
2166
2167         my $local_moniker = $self->monikers->{$table};
2168
2169         push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2170     }
2171
2172     my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2173
2174     foreach my $src_class (sort keys %$rel_stmts) {
2175         my $src_stmts = $rel_stmts->{$src_class};
2176         foreach my $stmt (@$src_stmts) {
2177             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
2178         }
2179     }
2180 }
2181
2182 sub _load_roles {
2183     my ($self, $table) = @_;
2184
2185     my $table_moniker = $self->monikers->{$table};
2186     my $table_class   = $self->classes->{$table};
2187
2188     my @roles = @{ $self->result_roles || [] };
2189     push @roles, @{ $self->result_roles_map->{$table_moniker} }
2190         if exists $self->result_roles_map->{$table_moniker};
2191
2192     if (@roles) {
2193         $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2194
2195         $self->_with($table_class, @roles);
2196     }
2197 }
2198
2199 # Overload these in driver class:
2200
2201 # Returns an arrayref of column names
2202 sub _table_columns { croak "ABSTRACT METHOD" }
2203
2204 # Returns arrayref of pk col names
2205 sub _table_pk_info { croak "ABSTRACT METHOD" }
2206
2207 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2208 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2209
2210 # Returns an arrayref of foreign key constraints, each
2211 #   being a hashref with 3 keys:
2212 #   local_columns (arrayref), remote_columns (arrayref), remote_table
2213 sub _table_fk_info { croak "ABSTRACT METHOD" }
2214
2215 # Returns an array of lower case table names
2216 sub _tables_list { croak "ABSTRACT METHOD" }
2217
2218 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2219 sub _dbic_stmt {
2220     my $self   = shift;
2221     my $class  = shift;
2222     my $method = shift;
2223
2224     # generate the pod for this statement, storing it with $self->_pod
2225     $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2226
2227     my $args = dump(@_);
2228     $args = '(' . $args . ')' if @_ < 2;
2229     my $stmt = $method . $args . q{;};
2230
2231     warn qq|$class\->$stmt\n| if $self->debug;
2232     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2233     return;
2234 }
2235
2236 sub _make_pod_heading {
2237     my ($self, $class) = @_;
2238
2239     return '' if not $self->generate_pod;
2240
2241     my $table = $self->class_to_table->{$class};
2242     my $pod;
2243
2244     my $pcm = $self->pod_comment_mode;
2245     my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2246     $comment = $self->__table_comment($table);
2247     $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2248     $comment_in_name   = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2249     $comment_in_desc   = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2250
2251     $pod .= "=head1 NAME\n\n";
2252
2253     my $table_descr = $class;
2254     $table_descr .= " - " . $comment if $comment and $comment_in_name;
2255
2256     $pod .= "$table_descr\n\n";
2257
2258     if ($comment and $comment_in_desc) {
2259         $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2260     }
2261     $pod .= "=cut\n\n";
2262
2263     return $pod;
2264 }
2265
2266 # generates the accompanying pod for a DBIC class method statement,
2267 # storing it with $self->_pod
2268 sub _make_pod {
2269     my $self   = shift;
2270     my $class  = shift;
2271     my $method = shift;
2272
2273     if ($method eq 'table') {
2274         my $table = $_[0];
2275         $table = $$table if ref $table eq 'SCALAR';
2276         $self->_pod($class, "=head1 TABLE: C<$table>");
2277         $self->_pod_cut($class);
2278     }
2279     elsif ( $method eq 'add_columns' ) {
2280         $self->_pod( $class, "=head1 ACCESSORS" );
2281         my $col_counter = 0;
2282         my @cols = @_;
2283         while( my ($name,$attrs) = splice @cols,0,2 ) {
2284             $col_counter++;
2285             $self->_pod( $class, '=head2 ' . $name  );
2286             $self->_pod( $class,
2287                 join "\n", map {
2288                     my $s = $attrs->{$_};
2289                     $s = !defined $s          ? 'undef'             :
2290                         length($s) == 0       ? '(empty string)'    :
2291                         ref($s) eq 'SCALAR'   ? $$s                 :
2292                         ref($s)               ? dumper_squashed $s  :
2293                         looks_like_number($s) ? $s                  : qq{'$s'};
2294
2295                     "  $_: $s"
2296                  } sort keys %$attrs,
2297             );
2298             if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2299                 $self->_pod( $class, $comment );
2300             }
2301         }
2302         $self->_pod_cut( $class );
2303     } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2304         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2305         my ( $accessor, $rel_class ) = @_;
2306         $self->_pod( $class, "=head2 $accessor" );
2307         $self->_pod( $class, 'Type: ' . $method );
2308         $self->_pod( $class, "Related object: L<$rel_class>" );
2309         $self->_pod_cut( $class );
2310         $self->{_relations_started} { $class } = 1;
2311     }
2312     elsif ($method eq 'add_unique_constraint') {
2313         $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2314             unless $self->{_uniqs_started}{$class};
2315
2316         my ($name, $cols) = @_;
2317
2318         $self->_pod($class, "=head2 C<$name>");
2319         $self->_pod($class, '=over 4');
2320
2321         foreach my $col (@$cols) {
2322             $self->_pod($class, "=item \* L</$col>");
2323         }
2324
2325         $self->_pod($class, '=back');
2326         $self->_pod_cut($class);
2327
2328         $self->{_uniqs_started}{$class} = 1;
2329     }
2330     elsif ($method eq 'set_primary_key') {
2331         $self->_pod($class, "=head1 PRIMARY KEY");
2332         $self->_pod($class, '=over 4');
2333
2334         foreach my $col (@_) {
2335             $self->_pod($class, "=item \* L</$col>");
2336         }
2337
2338         $self->_pod($class, '=back');
2339         $self->_pod_cut($class);
2340     }
2341 }
2342
2343 sub _pod_class_list {
2344     my ($self, $class, $title, @classes) = @_;
2345
2346     return unless @classes && $self->generate_pod;
2347
2348     $self->_pod($class, "=head1 $title");
2349     $self->_pod($class, '=over 4');
2350
2351     foreach my $link (@classes) {
2352         $self->_pod($class, "=item * L<$link>");
2353     }
2354
2355     $self->_pod($class, '=back');
2356     $self->_pod_cut($class);
2357 }
2358
2359 sub _base_class_pod {
2360     my ($self, $base_class) = @_;
2361
2362     return unless $self->generate_pod;
2363
2364     return <<"EOF"
2365 =head1 BASE CLASS: L<$base_class>
2366
2367 =cut
2368
2369 EOF
2370 }
2371
2372 sub _filter_comment {
2373     my ($self, $txt) = @_;
2374
2375     $txt = '' if not defined $txt;
2376
2377     $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2378
2379     return $txt;
2380 }
2381
2382 sub __table_comment {
2383     my $self = shift;
2384
2385     if (my $code = $self->can('_table_comment')) {
2386         return $self->_filter_comment($self->$code(@_));
2387     }
2388
2389     return '';
2390 }
2391
2392 sub __column_comment {
2393     my $self = shift;
2394
2395     if (my $code = $self->can('_column_comment')) {
2396         return $self->_filter_comment($self->$code(@_));
2397     }
2398
2399     return '';
2400 }
2401
2402 # Stores a POD documentation
2403 sub _pod {
2404     my ($self, $class, $stmt) = @_;
2405     $self->_raw_stmt( $class, "\n" . $stmt  );
2406 }
2407
2408 sub _pod_cut {
2409     my ($self, $class ) = @_;
2410     $self->_raw_stmt( $class, "\n=cut\n" );
2411 }
2412
2413 # Store a raw source line for a class (for dumping purposes)
2414 sub _raw_stmt {
2415     my ($self, $class, $stmt) = @_;
2416     push(@{$self->{_dump_storage}->{$class}}, $stmt);
2417 }
2418
2419 # Like above, but separately for the externally loaded stuff
2420 sub _ext_stmt {
2421     my ($self, $class, $stmt) = @_;
2422     push(@{$self->{_ext_storage}->{$class}}, $stmt);
2423 }
2424
2425 sub _custom_column_info {
2426     my ( $self, $table_name, $column_name, $column_info ) = @_;
2427
2428     if (my $code = $self->custom_column_info) {
2429         return $code->($table_name, $column_name, $column_info) || {};
2430     }
2431     return {};
2432 }
2433
2434 sub _datetime_column_info {
2435     my ( $self, $table_name, $column_name, $column_info ) = @_;
2436     my $result = {};
2437     my $type = $column_info->{data_type} || '';
2438     if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2439             or ($type =~ /date|timestamp/i)) {
2440         $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2441         $result->{locale}   = $self->datetime_locale   if $self->datetime_locale;
2442     }
2443     return $result;
2444 }
2445
2446 sub _lc {
2447     my ($self, $name) = @_;
2448
2449     return $self->preserve_case ? $name : lc($name);
2450 }
2451
2452 sub _uc {
2453     my ($self, $name) = @_;
2454
2455     return $self->preserve_case ? $name : uc($name);
2456 }
2457
2458 sub _unregister_source_for_table {
2459     my ($self, $table) = @_;
2460
2461     try {
2462         local $@;
2463         my $schema = $self->schema;
2464         # in older DBIC it's a private method
2465         my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2466         $schema->$unregister($self->_table2moniker($table));
2467         delete $self->monikers->{$table};
2468         delete $self->classes->{$table};
2469         delete $self->_upgrading_classes->{$table};
2470         delete $self->{_tables}{$table};
2471     };
2472 }
2473
2474 # remove the dump dir from @INC on destruction
2475 sub DESTROY {
2476     my $self = shift;
2477
2478     @INC = grep $_ ne $self->dump_directory, @INC;
2479 }
2480
2481 =head2 monikers
2482
2483 Returns a hashref of loaded table to moniker mappings.  There will
2484 be two entries for each table, the original name and the "normalized"
2485 name, in the case that the two are different (such as databases
2486 that like uppercase table names, or preserve your original mixed-case
2487 definitions, or what-have-you).
2488
2489 =head2 classes
2490
2491 Returns a hashref of table to class mappings.  In some cases it will
2492 contain multiple entries per table for the original and normalized table
2493 names, as above in L</monikers>.
2494
2495 =head1 COLUMN ACCESSOR COLLISIONS
2496
2497 Occasionally you may have a column name that collides with a perl method, such
2498 as C<can>. In such cases, the default action is to set the C<accessor> of the
2499 column spec to C<undef>.
2500
2501 You can then name the accessor yourself by placing code such as the following
2502 below the md5:
2503
2504     __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2505
2506 Another option is to use the L</col_collision_map> option.
2507
2508 =head1 RELATIONSHIP NAME COLLISIONS
2509
2510 In very rare cases, you may get a collision between a generated relationship
2511 name and a method in your Result class, for example if you have a foreign key
2512 called C<belongs_to>.
2513
2514 This is a problem because relationship names are also relationship accessor
2515 methods in L<DBIx::Class>.
2516
2517 The default behavior is to append C<_rel> to the relationship name and print
2518 out a warning that refers to this text.
2519
2520 You can also control the renaming with the L</rel_collision_map> option.
2521
2522 =head1 SEE ALSO
2523
2524 L<DBIx::Class::Schema::Loader>
2525
2526 =head1 AUTHOR
2527
2528 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2529
2530 =head1 LICENSE
2531
2532 This library is free software; you can redistribute it and/or modify it under
2533 the same terms as Perl itself.
2534
2535 =cut
2536
2537 1;
2538 # vim:et sts=4 sw=4 tw=0: