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