lib/DBIx/Class/Schema/Loader/Base.pm

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