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

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