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