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