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

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