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