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