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