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     $self->{_cache} = {};
1647
1648     my @created;
1649     my @current = $self->__tables_list;
1650
1651     foreach my $table (@current) {
1652         if(!exists $self->_tables->{$table->sql_name}) {
1653             push(@created, $table);
1654         }
1655     }
1656
1657     my %current;
1658     @current{map $_->sql_name, @current} = ();
1659     foreach my $table (values %{ $self->_tables }) {
1660         if (not exists $current{$table->sql_name}) {
1661             $self->_remove_table($table);
1662         }
1663     }
1664
1665     delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1666
1667     my $loaded = $self->_load_tables(@current);
1668
1669     foreach my $table (@created) {
1670         $self->monikers->{$table->sql_name} = $self->_table2moniker($table);
1671     }
1672
1673     return map { $self->monikers->{$_->sql_name} } @created;
1674 }
1675
1676 sub _relbuilder {
1677     my ($self) = @_;
1678
1679     return if $self->{skip_relationships};
1680
1681     return $self->{relbuilder} ||= do {
1682         my $relbuilder_suff =
1683             {qw{
1684                 v4  ::Compat::v0_040
1685                 v5  ::Compat::v0_05
1686                 v6  ::Compat::v0_06
1687                 v7  ::Compat::v0_07
1688             }}
1689             ->{$self->naming->{relationships}||$CURRENT_V} || '';
1690
1691         my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1692         $self->ensure_class_loaded($relbuilder_class);
1693         $relbuilder_class->new($self);
1694     };
1695 }
1696
1697 sub _load_tables {
1698     my ($self, @tables) = @_;
1699
1700     # Save the new tables to the tables list and compute monikers
1701     foreach (@tables) {
1702         $self->_tables->{$_->sql_name}  = $_;
1703         $self->monikers->{$_->sql_name} = $self->_table2moniker($_);
1704     }
1705
1706     # check for moniker clashes
1707     my $inverse_moniker_idx;
1708     foreach my $imtable (values %{ $self->_tables }) {
1709         push @{ $inverse_moniker_idx->{$self->monikers->{$imtable->sql_name}} }, $imtable;
1710     }
1711
1712     my @clashes;
1713     foreach my $moniker (keys %$inverse_moniker_idx) {
1714         my $imtables = $inverse_moniker_idx->{$moniker};
1715         if (@$imtables > 1) {
1716             my $different_databases =
1717                 $imtables->[0]->can('database') && (uniq map $_->database||'', @$imtables) > 1;
1718
1719             my $different_schemas =
1720                 (uniq map $_->schema||'', @$imtables) > 1;
1721
1722             if ($different_databases || $different_schemas) {
1723                 my ($use_schema, $use_database) = (1, 0);
1724
1725                 if ($different_databases) {
1726                     $use_database = 1;
1727
1728                     # If any monikers are in the same database, we have to distinguish by
1729                     # both schema and database.
1730                     my %db_counts;
1731                     $db_counts{$_}++ for map $_->database, @$imtables;
1732                     $use_schema = any { $_ > 1 } values %db_counts;
1733                 }
1734
1735                 foreach my $tbl (@$imtables) { delete $self->monikers->{$tbl->sql_name}; }
1736
1737                 my $moniker_parts = [ @{ $self->moniker_parts } ];
1738
1739                 my $have_schema   = any { $_ eq 'schema'   } @{ $self->moniker_parts };
1740                 my $have_database = any { $_ eq 'database' } @{ $self->moniker_parts };
1741
1742                 unshift @$moniker_parts, 'schema'   if $use_schema   && !$have_schema;
1743                 unshift @$moniker_parts, 'database' if $use_database && !$have_database;
1744
1745                 local $self->{moniker_parts} = $moniker_parts;
1746
1747                 my %new_monikers;
1748
1749                 foreach my $tbl  (@$imtables)                   { $new_monikers{$tbl->sql_name} = $self->_table2moniker($tbl); }
1750                 foreach my $name (map $_->sql_name, @$imtables) { $self->monikers->{$name} = $new_monikers{$name}; }
1751
1752                 # check if there are still clashes
1753                 my %by_moniker;
1754
1755                 while (my ($t, $m) = each %new_monikers) {
1756                     push @{ $by_moniker{$m} }, $t;
1757                 }
1758
1759                 foreach my $m (grep @{ $by_moniker{$_} } > 1, keys %by_moniker) {
1760                     push @clashes, sprintf ("tried disambiguating by moniker_parts, but tables %s still reduced to the same source moniker '%s'",
1761                         join (', ', @{ $by_moniker{$m} }),
1762                         $m,
1763                     );
1764                 }
1765             }
1766             else {
1767                 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1768                     join (', ', map $_->sql_name, @$imtables),
1769                     $moniker,
1770                 );
1771             }
1772         }
1773     }
1774
1775     if (@clashes) {
1776         die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1777         . 'Change the naming style, or supply an explicit moniker_map: '
1778         . join ('; ', @clashes)
1779         . "\n"
1780         ;
1781     }
1782
1783     foreach my $tbl (@tables) { $self->_make_src_class($tbl); }
1784     foreach my $tbl (@tables) { $self->_setup_src_meta($tbl); }
1785
1786     if(!$self->skip_relationships) {
1787         # The relationship loader needs a working schema
1788         local $self->{quiet} = 1;
1789         local $self->{dump_directory} = $self->{temp_directory};
1790         local $self->{generated_classes} = [];
1791         local $self->{dry_run} = 0;
1792         $self->_reload_classes(\@tables);
1793         $self->_load_relationships(\@tables);
1794
1795         # Remove that temp dir from INC so it doesn't get reloaded
1796         @INC = grep $_ ne $self->dump_directory, @INC;
1797     }
1798
1799     foreach my $tbl                                        (@tables) { $self->_load_roles($tbl); }
1800     foreach my $tbl (map { $self->classes->{$_->sql_name} } @tables) { $self->_load_external($tbl); }
1801
1802     # Reload without unloading first to preserve any symbols from external
1803     # packages.
1804     $self->_reload_classes(\@tables, { unload => 0 });
1805
1806     # Drop temporary cache
1807     delete $self->{_cache};
1808
1809     return \@tables;
1810 }
1811
1812 sub _reload_classes {
1813     my ($self, $tables, $opts) = @_;
1814
1815     my @tables = @$tables;
1816
1817     my $unload = $opts->{unload};
1818     $unload = 1 unless defined $unload;
1819
1820     # so that we don't repeat custom sections
1821     @INC = grep $_ ne $self->dump_directory, @INC;
1822
1823     $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables);
1824
1825     unshift @INC, $self->dump_directory;
1826
1827     return if $self->dry_run;
1828
1829     my @to_register;
1830     my %have_source = map { $_ => $self->schema->source($_) }
1831         $self->schema->sources;
1832
1833     for my $table (@tables) {
1834         my $moniker = $self->monikers->{$table->sql_name};
1835         my $class = $self->classes->{$table->sql_name};
1836
1837         {
1838             no warnings 'redefine';
1839             local *Class::C3::reinitialize = sub {};  # to speed things up, reinitialized below
1840             use warnings;
1841
1842             if (my $mc = $self->_moose_metaclass($class)) {
1843                 $mc->make_mutable;
1844             }
1845             Class::Unload->unload($class) if $unload;
1846             my ($source, $resultset_class);
1847             if (
1848                 ($source = $have_source{$moniker})
1849                 && ($resultset_class = $source->resultset_class)
1850                 && ($resultset_class ne 'DBIx::Class::ResultSet')
1851             ) {
1852                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1853                 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1854                     $mc->make_mutable;
1855                 }
1856                 Class::Unload->unload($resultset_class) if $unload;
1857                 $self->_reload_class($resultset_class) if $has_file;
1858             }
1859             $self->_reload_class($class);
1860         }
1861         push @to_register, [$moniker, $class];
1862     }
1863
1864     Class::C3->reinitialize;
1865     for (@to_register) {
1866         $self->schema->register_class(@$_);
1867     }
1868 }
1869
1870 sub _moose_metaclass {
1871     return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1872
1873     my $class = $_[1];
1874
1875     my $mc = try { Class::MOP::class_of($class) }
1876         or return undef;
1877
1878     return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1879 }
1880
1881 # We use this instead of ensure_class_loaded when there are package symbols we
1882 # want to preserve.
1883 sub _reload_class {
1884     my ($self, $class) = @_;
1885
1886     delete $INC{ +class_path($class) };
1887
1888     try {
1889         eval_package_without_redefine_warnings ($class, "require $class");
1890     }
1891     catch {
1892         my $source = slurp_file $self->_get_dump_filename($class);
1893         die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1894     };
1895 }
1896
1897 sub _get_dump_filename {
1898     my ($self, $class) = (@_);
1899
1900     $class =~ s{::}{/}g;
1901     return $self->dump_directory . q{/} . $class . q{.pm};
1902 }
1903
1904 =head2 get_dump_filename
1905
1906 Arguments: class
1907
1908 Returns the full path to the file for a class that the class has been or will
1909 be dumped to. This is a file in a temp dir for a dynamic schema.
1910
1911 =cut
1912
1913 sub get_dump_filename {
1914     my ($self, $class) = (@_);
1915
1916     local $self->{dump_directory} = $self->real_dump_directory;
1917
1918     return $self->_get_dump_filename($class);
1919 }
1920
1921 sub _ensure_dump_subdirs {
1922     my ($self, $class) = (@_);
1923
1924     return if $self->dry_run;
1925
1926     my @name_parts = split(/::/, $class);
1927     pop @name_parts; # we don't care about the very last element,
1928                      # which is a filename
1929
1930     my $dir = $self->dump_directory;
1931     while (1) {
1932         if(!-d $dir) {
1933             mkdir($dir) or croak "mkdir('$dir') failed: $!";
1934         }
1935         last if !@name_parts;
1936         $dir = File::Spec->catdir($dir, shift @name_parts);
1937     }
1938 }
1939
1940 sub _dump_to_dir {
1941     my ($self, @classes) = @_;
1942
1943     my $schema_class = $self->schema_class;
1944     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1945
1946     my $target_dir = $self->dump_directory;
1947     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1948         unless $self->dynamic or $self->quiet;
1949
1950     my $schema_text =
1951           qq|use utf8;\n|
1952         . qq|package $schema_class;\n\n|
1953         . qq|# Created by DBIx::Class::Schema::Loader\n|
1954         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1955
1956     my $autoclean
1957         = $self->only_autoclean
1958         ? 'namespace::autoclean'
1959         : 'MooseX::MarkAsMethods autoclean => 1'
1960         ;
1961
1962     if ($self->use_moose) {
1963
1964         $schema_text.= qq|use Moose;\nuse $autoclean;\nextends '$schema_base_class';\n\n|;
1965     }
1966     else {
1967         $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1968     }
1969
1970     my @schema_components = @{ $self->schema_components || [] };
1971
1972     if (@schema_components) {
1973         my $schema_components = dump @schema_components;
1974         $schema_components = "($schema_components)" if @schema_components == 1;
1975
1976         $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1977     }
1978
1979     if ($self->use_namespaces) {
1980         $schema_text .= qq|__PACKAGE__->load_namespaces|;
1981         my $namespace_options;
1982
1983         my @attr = qw/resultset_namespace default_resultset_class/;
1984
1985         unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1986
1987         for my $attr (@attr) {
1988             if ($self->$attr) {
1989                 my $code = dumper_squashed $self->$attr;
1990                 $namespace_options .= qq|    $attr => $code,\n|
1991             }
1992         }
1993         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1994         $schema_text .= qq|;\n|;
1995     }
1996     else {
1997         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1998     }
1999
2000     {
2001         local $self->{version_to_dump} = $self->schema_version_to_dump;
2002         $self->_write_classfile($schema_class, $schema_text, 1);
2003     }
2004
2005     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
2006
2007     foreach my $src_class (@classes) {
2008         my $src_text =
2009               qq|use utf8;\n|
2010             . qq|package $src_class;\n\n|
2011             . qq|# Created by DBIx::Class::Schema::Loader\n|
2012             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
2013
2014         $src_text .= $self->_make_pod_heading($src_class);
2015
2016         $src_text .= qq|use strict;\nuse warnings;\n\n|;
2017
2018         $src_text .= $self->_base_class_pod($result_base_class)
2019             unless $result_base_class eq 'DBIx::Class::Core';
2020
2021         if ($self->use_moose) {
2022             $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse $autoclean;|;
2023
2024             # these options 'use base' which is compile time
2025             if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
2026                 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
2027             }
2028             else {
2029                 $src_text .= qq|\nextends '$result_base_class';\n|;
2030             }
2031         }
2032         else {
2033             $src_text .= qq|use base '$result_base_class';\n|;
2034         }
2035
2036         $self->_write_classfile($src_class, $src_text);
2037     }
2038
2039     # remove Result dir if downgrading from use_namespaces, and there are no
2040     # files left.
2041     if (my $result_ns = $self->_downgrading_to_load_classes
2042                         || $self->_rewriting_result_namespace) {
2043         my $result_namespace = $self->_result_namespace(
2044             $schema_class,
2045             $result_ns,
2046         );
2047
2048         (my $result_dir = $result_namespace) =~ s{::}{/}g;
2049         $result_dir = $self->dump_directory . '/' . $result_dir;
2050
2051         unless (my @files = glob "$result_dir/*") {
2052             rmdir $result_dir;
2053         }
2054     }
2055
2056     warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
2057 }
2058
2059 sub _sig_comment {
2060     my ($self, $version, $ts) = @_;
2061     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
2062          . (defined($version) ? q| v| . $version : '')
2063          . (defined($ts) ? q| @ | . $ts : '')
2064          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
2065 }
2066
2067 sub _write_classfile {
2068     my ($self, $class, $text, $is_schema) = @_;
2069
2070     my $filename = $self->_get_dump_filename($class);
2071     $self->_ensure_dump_subdirs($class);
2072
2073     if (-f $filename && $self->really_erase_my_files && !$self->dry_run) {
2074         warn "Deleting existing file '$filename' due to "
2075             . "'really_erase_my_files' setting\n" unless $self->quiet;
2076         unlink($filename);
2077     }
2078
2079     my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
2080         = $self->_parse_generated_file($filename);
2081
2082     if (! $old_gen && -f $filename) {
2083         croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
2084             . " it does not appear to have been generated by Loader"
2085     }
2086
2087     my $custom_content = $old_custom || '';
2088
2089     # Use custom content from a renamed class, the class names in it are
2090     # rewritten below.
2091     if (my $renamed_class = $self->_upgrading_classes->{$class}) {
2092         my $old_filename = $self->_get_dump_filename($renamed_class);
2093
2094         if (-f $old_filename) {
2095             $custom_content = ($self->_parse_generated_file ($old_filename))[4];
2096
2097             unlink $old_filename unless $self->dry_run;
2098         }
2099     }
2100
2101     $custom_content ||= $self->_default_custom_content($is_schema);
2102
2103     # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
2104     # If there is already custom content, which does not have the Moose content, add it.
2105     if ($self->use_moose) {
2106
2107         my $non_moose_custom_content = do {
2108             local $self->{use_moose} = 0;
2109             $self->_default_custom_content;
2110         };
2111
2112         if ($custom_content eq $non_moose_custom_content) {
2113             $custom_content = $self->_default_custom_content($is_schema);
2114         }
2115         elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
2116             $custom_content .= $self->_default_custom_content($is_schema);
2117         }
2118     }
2119     elsif (defined $self->use_moose && $old_gen) {
2120         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'
2121             if $old_gen =~ /use \s+ MooseX?\b/x;
2122     }
2123
2124     $custom_content = $self->_rewrite_old_classnames($custom_content);
2125
2126     $text .= qq|$_\n|
2127         for @{$self->{_dump_storage}->{$class} || []};
2128
2129     if ($self->filter_generated_code) {
2130         my $filter = $self->filter_generated_code;
2131
2132         if (ref $filter eq 'CODE') {
2133             $text = $filter->(
2134                 ($is_schema ? 'schema' : 'result'),
2135                 $class,
2136                 $text
2137             );
2138         }
2139         else {
2140             my ($fh, $temp_file) = tempfile();
2141
2142             binmode $fh, ':encoding(UTF-8)';
2143             print $fh $text;
2144             close $fh;
2145
2146             open my $out, qq{$filter < "$temp_file"|}
2147                 or croak "Could not open pipe to $filter: $!";
2148
2149             $text = decode('UTF-8', do { local $/; <$out> });
2150
2151             $text =~ s/$CR?$LF/\n/g;
2152
2153             close $out;
2154
2155             my $exit_code = $? >> 8;
2156
2157             unlink $temp_file
2158                 or croak "Could not remove temporary file '$temp_file': $!";
2159
2160             if ($exit_code != 0) {
2161                 croak "filter '$filter' exited non-zero: $exit_code";
2162             }
2163         }
2164         if (not $text or not $text =~ /\bpackage\b/) {
2165             warn("$class skipped due to filter") if $self->debug;
2166             return;
2167         }
2168     }
2169
2170     # Check and see if the dump is in fact different
2171
2172     my $compare_to;
2173     if ($old_md5) {
2174         $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
2175         if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
2176             return unless $self->_upgrading_from && $is_schema;
2177         }
2178     }
2179
2180     push @{$self->generated_classes}, $class;
2181
2182     return if $self->dry_run;
2183
2184     $text .= $self->_sig_comment(
2185         $self->omit_version ? undef : $self->version_to_dump,
2186         $self->omit_timestamp ? undef : POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
2187     );
2188
2189     open(my $fh, '>:raw:encoding(UTF-8)', $filename)
2190         or croak "Cannot open '$filename' for writing: $!";
2191
2192     # Write the top half and its MD5 sum
2193     print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
2194
2195     # Write out anything loaded via external partial class file in @INC
2196     print $fh qq|$_\n|
2197         for @{$self->{_ext_storage}->{$class} || []};
2198
2199     # Write out any custom content the user has added
2200     print $fh $custom_content;
2201
2202     close($fh)
2203         or croak "Error closing '$filename': $!";
2204 }
2205
2206 sub _default_moose_custom_content {
2207     my ($self, $is_schema) = @_;
2208
2209     if (not $is_schema) {
2210         return qq|\n__PACKAGE__->meta->make_immutable;|;
2211     }
2212
2213     return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
2214 }
2215
2216 sub _default_custom_content {
2217     my ($self, $is_schema) = @_;
2218     my $default = qq|\n\n# You can replace this text with custom|
2219          . qq| code or comments, and it will be preserved on regeneration|;
2220     if ($self->use_moose) {
2221         $default .= $self->_default_moose_custom_content($is_schema);
2222     }
2223     $default .= qq|\n1;\n|;
2224     return $default;
2225 }
2226
2227 sub _parse_generated_file {
2228     my ($self, $fn) = @_;
2229
2230     return unless -f $fn;
2231
2232     open(my $fh, '<:encoding(UTF-8)', $fn)
2233         or croak "Cannot open '$fn' for reading: $!";
2234
2235     my $mark_re =
2236         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
2237
2238     my ($real_md5, $ts, $ver, $gen);
2239     local $_;
2240     while(<$fh>) {
2241         if(/$mark_re/) {
2242             my $pre_md5 = $1;
2243             my $mark_md5 = $2;
2244
2245             # Pull out the version and timestamp from the line above
2246             ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader( v[\d.]+)?( @ [\d-]+ [\d:]+)?\r?\Z/m;
2247             $ver =~ s/^ v// if $ver;
2248             $ts =~ s/^ @ // if $ts;
2249
2250             $gen .= $pre_md5;
2251             $real_md5 = Digest::MD5::md5_base64(encode 'UTF-8', $gen);
2252             croak "Checksum mismatch in '$fn', the auto-generated part of the file has been modified outside of this loader.  Aborting.\nIf you want to overwrite these modifications, set the 'overwrite_modifications' loader option.\n"
2253                 if !$self->overwrite_modifications && $real_md5 ne $mark_md5;
2254
2255             last;
2256         }
2257         else {
2258             $gen .= $_;
2259         }
2260     }
2261
2262     my $custom = do { local $/; <$fh> }
2263         if $real_md5;
2264
2265     $custom ||= '';
2266     $custom =~ s/$CRLF|$LF/\n/g;
2267
2268     close $fh;
2269
2270     return ($gen, $real_md5, $ver, $ts, $custom);
2271 }
2272
2273 sub _use {
2274     my $self = shift;
2275     my $target = shift;
2276
2277     foreach (@_) {
2278         warn "$target: use $_;" if $self->debug;
2279         $self->_raw_stmt($target, "use $_;");
2280     }
2281 }
2282
2283 sub _inject {
2284     my $self = shift;
2285     my $target = shift;
2286
2287     my $blist = join(q{ }, @_);
2288
2289     return unless $blist;
2290
2291     warn "$target: use base qw/$blist/;" if $self->debug;
2292     $self->_raw_stmt($target, "use base qw/$blist/;");
2293 }
2294
2295 sub _with {
2296     my $self = shift;
2297     my $target = shift;
2298
2299     my $rlist = join(q{, }, map { qq{'$_'} } @_);
2300
2301     return unless $rlist;
2302
2303     warn "$target: with $rlist;" if $self->debug;
2304     $self->_raw_stmt($target, "\nwith $rlist;");
2305 }
2306
2307 sub _result_namespace {
2308     my ($self, $schema_class, $ns) = @_;
2309     my @result_namespace;
2310
2311     $ns = $ns->[0] if ref $ns;
2312
2313     if ($ns =~ /^\+(.*)/) {
2314         # Fully qualified namespace
2315         @result_namespace = ($1)
2316     }
2317     else {
2318         # Relative namespace
2319         @result_namespace = ($schema_class, $ns);
2320     }
2321
2322     return wantarray ? @result_namespace : join '::', @result_namespace;
2323 }
2324
2325 # Create class with applicable bases, setup monikers, etc
2326 sub _make_src_class {
2327     my ($self, $table) = @_;
2328
2329     my $schema       = $self->schema;
2330     my $schema_class = $self->schema_class;
2331
2332     my $table_moniker = $self->monikers->{$table->sql_name};
2333     my @result_namespace = ($schema_class);
2334     if ($self->use_namespaces) {
2335         my $result_namespace = $self->result_namespace || 'Result';
2336         @result_namespace = $self->_result_namespace(
2337             $schema_class,
2338             $result_namespace,
2339         );
2340     }
2341     my $table_class = join(q{::}, @result_namespace, $table_moniker);
2342
2343     if ((my $upgrading_v = $self->_upgrading_from)
2344             || $self->_rewriting) {
2345         local $self->naming->{monikers} = $upgrading_v
2346             if $upgrading_v;
2347
2348         my @result_namespace = @result_namespace;
2349         if ($self->_upgrading_from_load_classes) {
2350             @result_namespace = ($schema_class);
2351         }
2352         elsif (my $ns = $self->_downgrading_to_load_classes) {
2353             @result_namespace = $self->_result_namespace(
2354                 $schema_class,
2355                 $ns,
2356             );
2357         }
2358         elsif ($ns = $self->_rewriting_result_namespace) {
2359             @result_namespace = $self->_result_namespace(
2360                 $schema_class,
2361                 $ns,
2362             );
2363         }
2364
2365         my $old_table_moniker = do {
2366             local $self->naming->{monikers} = $upgrading_v;
2367             $self->_table2moniker($table);
2368         };
2369
2370         my $old_class = join(q{::}, @result_namespace, $old_table_moniker);
2371
2372         $self->_upgrading_classes->{$table_class} = $old_class
2373             unless $table_class eq $old_class;
2374     }
2375
2376     $self->classes->{$table->sql_name}  = $table_class;
2377     $self->moniker_to_table->{$table_moniker} = $table;
2378     $self->class_to_table->{$table_class} = $table;
2379
2380     $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
2381
2382     $self->_use   ($table_class, @{$self->additional_classes});
2383
2384     $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
2385
2386     $self->_inject($table_class, @{$self->left_base_classes});
2387
2388     my @components = @{ $self->components || [] };
2389
2390     push @components, @{ $self->result_components_map->{$table_moniker} }
2391         if exists $self->result_components_map->{$table_moniker};
2392
2393     my @fq_components = @components;
2394     foreach my $component (@fq_components) {
2395         if ($component !~ s/^\+//) {
2396             $component = "DBIx::Class::$component";
2397         }
2398     }
2399
2400     $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
2401
2402     $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
2403
2404     $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
2405
2406     $self->_inject($table_class, @{$self->additional_base_classes});
2407 }
2408
2409 sub _is_result_class_method {
2410     my ($self, $name, $table) = @_;
2411
2412     my $table_moniker = $table ? $self->monikers->{$table->sql_name} : '';
2413
2414     $self->_result_class_methods({})
2415         if not defined $self->_result_class_methods;
2416
2417     if (not exists $self->_result_class_methods->{$table_moniker}) {
2418         my (@methods, %methods);
2419         my $base       = $self->result_base_class || 'DBIx::Class::Core';
2420
2421         my @components = @{ $self->components || [] };
2422
2423         push @components, @{ $self->result_components_map->{$table_moniker} }
2424             if exists $self->result_components_map->{$table_moniker};
2425
2426         for my $c (@components) {
2427             $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
2428         }
2429
2430         my @roles = @{ $self->result_roles || [] };
2431
2432         push @roles, @{ $self->result_roles_map->{$table_moniker} }
2433             if exists $self->result_roles_map->{$table_moniker};
2434
2435         for my $class (
2436             $base, @components, @roles,
2437             ($self->use_moose ? 'Moose::Object' : ()),
2438         ) {
2439             $self->ensure_class_loaded($class);
2440
2441             push @methods, @{ Class::Inspector->methods($class) || [] };
2442         }
2443
2444         push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
2445
2446         @methods{@methods} = ();
2447
2448         $self->_result_class_methods->{$table_moniker} = \%methods;
2449     }
2450     my $result_methods = $self->_result_class_methods->{$table_moniker};
2451
2452     return exists $result_methods->{$name};
2453 }
2454
2455 sub _resolve_col_accessor_collisions {
2456     my ($self, $table, $col_info) = @_;
2457
2458     while (my ($col, $info) = each %$col_info) {
2459         my $accessor = $info->{accessor} || $col;
2460
2461         next if $accessor eq 'id'; # special case (very common column)
2462
2463         if ($self->_is_result_class_method($accessor, $table)) {
2464             my $mapped = 0;
2465
2466             if (my $map = $self->col_collision_map) {
2467                 for my $re (keys %$map) {
2468                     if (my @matches = $col =~ /$re/) {
2469                         $info->{accessor} = sprintf $map->{$re}, @matches;
2470                         $mapped = 1;
2471                     }
2472                 }
2473             }
2474
2475             if (not $mapped) {
2476                 warn <<"EOF";
2477 Column '$col' in table '$table' collides with an inherited method.
2478 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
2479 EOF
2480                 $info->{accessor} = undef;
2481             }
2482         }
2483     }
2484 }
2485
2486 # use the same logic to run moniker_map, col_accessor_map
2487 sub _run_user_map {
2488     my ( $self, $map, $default_code, $ident, @extra ) = @_;
2489
2490     my $default_ident = $default_code->( $ident, @extra );
2491     my $new_ident;
2492     if( $map && ref $map eq 'HASH' ) {
2493         if (my @parts = try{ @{ $ident } }) {
2494             my $part_map = $map;
2495             while (@parts) {
2496                 my $part = shift @parts;
2497                 last unless exists $part_map->{ $part };
2498                 if ( !ref $part_map->{ $part } && !@parts ) {
2499                     $new_ident = $part_map->{ $part };
2500                     last;
2501                 }
2502                 elsif ( ref $part_map->{ $part } eq 'HASH' ) {
2503                     $part_map = $part_map->{ $part };
2504                 }
2505             }
2506         }
2507         if( !$new_ident && !ref $map->{ $ident } ) {
2508             $new_ident = $map->{ $ident };
2509         }
2510     }
2511     elsif( $map && ref $map eq 'CODE' ) {
2512         my $cb = sub {
2513             my ($cb_map) = @_;
2514             croak "reentered map must be a hashref"
2515                 unless 'HASH' eq ref($cb_map);
2516             return $self->_run_user_map($cb_map, $default_code, $ident, @extra);
2517         };
2518         $new_ident = $map->( $ident, $default_ident, @extra, $cb );
2519     }
2520
2521     $new_ident ||= $default_ident;
2522
2523     return $new_ident;
2524 }
2525
2526 sub _default_column_accessor_name {
2527     my ( $self, $column_name ) = @_;
2528
2529     my $preserve = ($self->naming->{column_accessors}||'') eq 'preserve';
2530
2531     my $v = $self->_get_naming_v('column_accessors');
2532
2533     my $accessor_name = $preserve ?
2534         $self->_to_identifier('column_accessors', $column_name) # assume CamelCase
2535         :
2536         $self->_to_identifier('column_accessors', $column_name, '_');
2537
2538     $accessor_name =~ s/\W+/_/g; # only if naming < v8, otherwise to_identifier
2539                                  # takes care of it
2540
2541     if ($preserve) {
2542         return $accessor_name;
2543     }
2544     elsif ($v < 7 || (not $self->preserve_case)) {
2545         # older naming just lc'd the col accessor and that's all.
2546         return lc $accessor_name;
2547     }
2548
2549     return join '_', map lc, split_name $column_name, $v;
2550 }
2551
2552 sub _make_column_accessor_name {
2553     my ($self, $column_name, $column_context_info ) = @_;
2554
2555     my $accessor = $self->_run_user_map(
2556         $self->col_accessor_map,
2557         sub { $self->_default_column_accessor_name( shift ) },
2558         $column_name,
2559         $column_context_info,
2560     );
2561
2562     return $accessor;
2563 }
2564
2565 sub _table_is_view {
2566     #my ($self, $table) = @_;
2567     return 0;
2568 }
2569
2570 # Set up metadata (cols, pks, etc)
2571 sub _setup_src_meta {
2572     my ($self, $table) = @_;
2573
2574     my $schema       = $self->schema;
2575     my $schema_class = $self->schema_class;
2576
2577     my $table_class   = $self->classes->{$table->sql_name};
2578     my $table_moniker = $self->monikers->{$table->sql_name};
2579
2580     $self->_dbic_stmt($table_class, 'table_class', 'DBIx::Class::ResultSource::View')
2581         if $self->_table_is_view($table);
2582
2583     $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
2584
2585     my $cols     = $self->_table_columns($table);
2586     my $col_info = $self->__columns_info_for($table);
2587
2588     ### generate all the column accessor names
2589     while (my ($col, $info) = each %$col_info) {
2590         # hashref of other info that could be used by
2591         # user-defined accessor map functions
2592         my $context = {
2593             table_class     => $table_class,
2594             table_moniker   => $table_moniker,
2595             table_name      => $table, # bugwards compatibility, RT#84050
2596             table           => $table,
2597             full_table_name => $table->dbic_name,
2598             schema_class    => $schema_class,
2599             column_info     => $info,
2600         };
2601
2602         $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2603     }
2604
2605     $self->_resolve_col_accessor_collisions($table, $col_info);
2606
2607     # prune any redundant accessor names
2608     while (my ($col, $info) = each %$col_info) {
2609         no warnings 'uninitialized';
2610         delete $info->{accessor} if $info->{accessor} eq $col;
2611     }
2612
2613     my $fks = $self->_table_fk_info($table);
2614
2615     foreach my $fkdef (@$fks) {
2616         for my $col (@{ $fkdef->{local_columns} }) {
2617             $col_info->{$col}{is_foreign_key} = 1;
2618         }
2619     }
2620
2621     my $pks = $self->_table_pk_info($table) || [];
2622
2623     my %uniq_tag; # used to eliminate duplicate uniqs
2624
2625     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2626
2627     my $uniqs = $self->_table_uniq_info($table) || [];
2628     my @uniqs;
2629
2630     foreach my $uniq (@$uniqs) {
2631         my ($name, $cols) = @$uniq;
2632         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2633         push @uniqs, [$name, $cols];
2634     }
2635
2636     my @non_nullable_uniqs = grep {
2637         all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2638     } @uniqs;
2639
2640     if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2641         my @by_colnum = sort { $b->[0] <=> $a->[0] }
2642             map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2643
2644         if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2645             my @keys = map $_->[1], @by_colnum;
2646
2647             my $pk = $keys[0];
2648
2649             # remove the uniq from list
2650             @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2651
2652             $pks = $pk->[1];
2653         }
2654     }
2655
2656     foreach my $pkcol (@$pks) {
2657         $col_info->{$pkcol}{is_nullable} = 0;
2658     }
2659
2660     $self->_dbic_stmt(
2661         $table_class,
2662         'add_columns',
2663         map { $_, ($col_info->{$_}||{}) } @$cols
2664     );
2665
2666     $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2667         if @$pks;
2668
2669     # Sort unique constraints by constraint name for repeatable results (rels
2670     # are sorted as well elsewhere.)
2671     @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs;
2672
2673     foreach my $uniq (@uniqs) {
2674         my ($name, $cols) = @$uniq;
2675         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2676     }
2677 }
2678
2679 sub __columns_info_for {
2680     my ($self, $table) = @_;
2681
2682     my $result = $self->_columns_info_for($table);
2683
2684     while (my ($col, $info) = each %$result) {
2685         $info = { %$info, %{ $self->_custom_column_info  ($table, $col, $info) } };
2686         $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2687
2688         $result->{$col} = $info;
2689     }
2690
2691     return $result;
2692 }
2693
2694 =head2 tables
2695
2696 Returns a sorted list of loaded tables, using the original database table
2697 names.
2698
2699 =cut
2700
2701 sub tables {
2702     my $self = shift;
2703
2704     return values %{$self->_tables};
2705 }
2706
2707 sub _get_naming_v {
2708     my ($self, $naming_key) = @_;
2709
2710     my $v;
2711
2712     if (($self->naming->{$naming_key}||'') =~ /^v(\d+)\z/) {
2713         $v = $1;
2714     }
2715     else {
2716         ($v) = $CURRENT_V =~ /^v(\d+)\z/;
2717     }
2718
2719     return $v;
2720 }
2721
2722 sub _to_identifier {
2723     my ($self, $naming_key, $name, $sep_char, $force) = @_;
2724
2725     my $v = $self->_get_naming_v($naming_key);
2726
2727     my $to_identifier = $self->naming->{force_ascii} ?
2728         \&String::ToIdentifier::EN::to_identifier
2729         : \&String::ToIdentifier::EN::Unicode::to_identifier;
2730
2731     return $v >= 8 || $force ? $to_identifier->($name, $sep_char) : $name;
2732 }
2733
2734 # Make a moniker from a table
2735 sub _default_table2moniker {
2736     my ($self, $table) = @_;
2737
2738     my $v = $self->_get_naming_v('monikers');
2739
2740     my @moniker_parts = @{ $self->moniker_parts };
2741     my @name_parts = map $table->$_, @moniker_parts;
2742
2743     my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
2744
2745     my @all_parts;
2746
2747     foreach my $i (0 .. $#name_parts) {
2748         my $part = $name_parts[$i];
2749
2750         my $moniker_part = $self->_run_user_map(
2751             $self->moniker_part_map->{$moniker_parts[$i]},
2752             sub { '' },
2753             $part, $moniker_parts[$i],
2754         );
2755         if (length $moniker_part) {
2756             push @all_parts, $moniker_part;
2757             next;
2758         }
2759
2760         if ($i != $name_idx || $v >= 8) {
2761             $part = $self->_to_identifier('monikers', $part, '_', 1);
2762         }
2763
2764         if ($i == $name_idx && $v == 5) {
2765             $part = Lingua::EN::Inflect::Number::to_S($part);
2766         }
2767
2768         my @part_parts = map lc, $v > 6 ?
2769             # use v8 semantics for all moniker parts except name
2770             ($i == $name_idx ? split_name $part, $v : split_name $part)
2771             : split /[\W_]+/, $part;
2772
2773         if ($i == $name_idx && $v >= 6) {
2774             my $as_phrase = join ' ', @part_parts;
2775
2776             my $inflected = ($self->naming->{monikers}||'') eq 'plural' ?
2777                 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2778                 :
2779                 ($self->naming->{monikers}||'') eq 'preserve' ?
2780                     $as_phrase
2781                     :
2782                     Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2783
2784             @part_parts = split /\s+/, $inflected;
2785         }
2786
2787         push @all_parts, join '', map ucfirst, @part_parts;
2788     }
2789
2790     return join $self->moniker_part_separator, @all_parts;
2791 }
2792
2793 sub _table2moniker {
2794     my ( $self, $table ) = @_;
2795
2796     $self->_run_user_map(
2797         $self->moniker_map,
2798         sub { $self->_default_table2moniker( shift ) },
2799         $table
2800     );
2801 }
2802
2803 sub _load_relationships {
2804     my ($self, $tables) = @_;
2805
2806     my @tables;
2807
2808     foreach my $table (@$tables) {
2809         my $local_moniker = $self->monikers->{$table->sql_name};
2810
2811         my $tbl_fk_info = $self->_table_fk_info($table);
2812
2813         foreach my $fkdef (@$tbl_fk_info) {
2814             $fkdef->{local_table}   = $table;
2815             $fkdef->{local_moniker} = $local_moniker;
2816             $fkdef->{remote_source} =
2817                 $self->monikers->{$fkdef->{remote_table}->sql_name};
2818         }
2819         my $tbl_uniq_info = $self->_table_uniq_info($table);
2820
2821         push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2822     }
2823
2824     my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2825
2826     foreach my $src_class (sort keys %$rel_stmts) {
2827         # sort by rel name
2828         my @src_stmts = map $_->[2],
2829             sort {
2830                 $a->[0] <=> $b->[0]
2831                 ||
2832                 $a->[1] cmp $b->[1]
2833             } map [
2834                 ($_->{method} eq 'many_to_many' ? 1 : 0),
2835                 $_->{args}[0],
2836                 $_,
2837             ], @{ $rel_stmts->{$src_class} };
2838
2839         foreach my $stmt (@src_stmts) {
2840             $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2841         }
2842     }
2843 }
2844
2845 sub _load_roles {
2846     my ($self, $table) = @_;
2847
2848     my $table_moniker = $self->monikers->{$table->sql_name};
2849     my $table_class   = $self->classes->{$table->sql_name};
2850
2851     my @roles = @{ $self->result_roles || [] };
2852     push @roles, @{ $self->result_roles_map->{$table_moniker} }
2853         if exists $self->result_roles_map->{$table_moniker};
2854
2855     if (@roles) {
2856         $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2857
2858         $self->_with($table_class, @roles);
2859     }
2860 }
2861
2862 # Overload these in driver class:
2863
2864 # Returns an arrayref of column names
2865 sub _table_columns { croak "ABSTRACT METHOD" }
2866
2867 # Returns arrayref of pk col names
2868 sub _table_pk_info { croak "ABSTRACT METHOD" }
2869
2870 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2871 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2872
2873 # Returns an arrayref of foreign key constraints, each
2874 #   being a hashref with 3 keys:
2875 #   local_columns (arrayref), remote_columns (arrayref), remote_table
2876 sub _table_fk_info { croak "ABSTRACT METHOD" }
2877
2878 # Returns an array of lower case table names
2879 sub _tables_list { croak "ABSTRACT METHOD" }
2880
2881 sub __tables_list {
2882     my ($self) = @_;
2883     return @{$self->{_cache}{_tables_list} ||= [ $self->_tables_list ]};
2884 }
2885
2886 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2887 sub _dbic_stmt {
2888     my $self   = shift;
2889     my $class  = shift;
2890     my $method = shift;
2891
2892     # generate the pod for this statement, storing it with $self->_pod
2893     $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2894
2895     my $args = dump(@_);
2896     $args = '(' . $args . ')' if @_ < 2;
2897     my $stmt = $method . $args . q{;};
2898
2899     warn qq|$class\->$stmt\n| if $self->debug;
2900     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2901     return;
2902 }
2903
2904 sub _make_pod_heading {
2905     my ($self, $class) = @_;
2906
2907     return '' if not $self->generate_pod;
2908
2909     my $table = $self->class_to_table->{$class};
2910     my $pod;
2911
2912     my $pcm = $self->pod_comment_mode;
2913     my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2914     $comment = $self->__table_comment($table);
2915     $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2916     $comment_in_name   = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2917     $comment_in_desc   = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2918
2919     $pod .= "=head1 NAME\n\n";
2920
2921     my $table_descr = $class;
2922     $table_descr .= " - " . $comment if $comment and $comment_in_name;
2923
2924     $pod .= "$table_descr\n\n";
2925
2926     if ($comment and $comment_in_desc) {
2927         $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2928     }
2929     $pod .= "=cut\n\n";
2930
2931     return $pod;
2932 }
2933
2934 # generates the accompanying pod for a DBIC class method statement,
2935 # storing it with $self->_pod
2936 sub _make_pod {
2937     my $self   = shift;
2938     my $class  = shift;
2939     my $method = shift;
2940
2941     if ($method eq 'table') {
2942         my $table = $_[0];
2943         $table = $$table if ref $table eq 'SCALAR';
2944         $self->_pod($class, "=head1 TABLE: C<$table>");
2945         $self->_pod_cut($class);
2946     }
2947     elsif ( $method eq 'add_columns' ) {
2948         $self->_pod( $class, "=head1 ACCESSORS" );
2949         my $col_counter = 0;
2950         my @cols = @_;
2951         while( my ($name,$attrs) = splice @cols,0,2 ) {
2952             $col_counter++;
2953             $self->_pod( $class, '=head2 ' . $name  );
2954             $self->_pod( $class,
2955                 join "\n", map {
2956                     my $s = $attrs->{$_};
2957                     $s = !defined $s          ? 'undef'             :
2958                         length($s) == 0       ? '(empty string)'    :
2959                         ref($s) eq 'SCALAR'   ? $$s                 :
2960                         ref($s)               ? dumper_squashed $s  :
2961                         looks_like_number($s) ? $s                  : qq{'$s'};
2962
2963                     "  $_: $s"
2964                 } sort keys %$attrs,
2965             );
2966             if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2967                 $self->_pod( $class, $comment );
2968             }
2969         }
2970         $self->_pod_cut( $class );
2971     } elsif ( $method =~ /^(?:belongs_to|has_many|might_have)\z/ ) {
2972         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2973         my ( $accessor, $rel_class ) = @_;
2974         $self->_pod( $class, "=head2 $accessor" );
2975         $self->_pod( $class, 'Type: ' . $method );
2976         $self->_pod( $class, "Related object: L<$rel_class>" );
2977         $self->_pod_cut( $class );
2978         $self->{_relations_started} { $class } = 1;
2979     } elsif ( $method eq 'many_to_many' ) {
2980         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2981         my ( $accessor, $rel1, $rel2 ) = @_;
2982         $self->_pod( $class, "=head2 $accessor" );
2983         $self->_pod( $class, 'Type: many_to_many' );
2984         $self->_pod( $class, "Composing rels: L</$rel1> -> $rel2" );
2985         $self->_pod_cut( $class );
2986         $self->{_relations_started} { $class } = 1;
2987     }
2988     elsif ($method eq 'add_unique_constraint') {
2989         $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2990             unless $self->{_uniqs_started}{$class};
2991
2992         my ($name, $cols) = @_;
2993
2994         $self->_pod($class, "=head2 C<$name>");
2995         $self->_pod($class, '=over 4');
2996
2997         foreach my $col (@$cols) {
2998             $self->_pod($class, "=item \* L</$col>");
2999         }
3000
3001         $self->_pod($class, '=back');
3002         $self->_pod_cut($class);
3003
3004         $self->{_uniqs_started}{$class} = 1;
3005     }
3006     elsif ($method eq 'set_primary_key') {
3007         $self->_pod($class, "=head1 PRIMARY KEY");
3008         $self->_pod($class, '=over 4');
3009
3010         foreach my $col (@_) {
3011             $self->_pod($class, "=item \* L</$col>");
3012         }
3013
3014         $self->_pod($class, '=back');
3015         $self->_pod_cut($class);
3016     }
3017 }
3018
3019 sub _pod_class_list {
3020     my ($self, $class, $title, @classes) = @_;
3021
3022     return unless @classes && $self->generate_pod;
3023
3024     $self->_pod($class, "=head1 $title");
3025     $self->_pod($class, '=over 4');
3026
3027     foreach my $link (@classes) {
3028         $self->_pod($class, "=item * L<$link>");
3029     }
3030
3031     $self->_pod($class, '=back');
3032     $self->_pod_cut($class);
3033 }
3034
3035 sub _base_class_pod {
3036     my ($self, $base_class) = @_;
3037
3038     return '' unless $self->generate_pod;
3039
3040     return "\n=head1 BASE CLASS: L<$base_class>\n\n=cut\n\n";
3041 }
3042
3043 sub _filter_comment {
3044     my ($self, $txt) = @_;
3045
3046     $txt = '' if not defined $txt;
3047
3048     $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
3049
3050     return $txt;
3051 }
3052
3053 sub __table_comment {
3054     my $self = shift;
3055
3056     if (my $code = $self->can('_table_comment')) {
3057         return $self->_filter_comment($self->$code(@_));
3058     }
3059
3060     return '';
3061 }
3062
3063 sub __column_comment {
3064     my $self = shift;
3065
3066     if (my $code = $self->can('_column_comment')) {
3067         return $self->_filter_comment($self->$code(@_));
3068     }
3069
3070     return '';
3071 }
3072
3073 # Stores a POD documentation
3074 sub _pod {
3075     my ($self, $class, $stmt) = @_;
3076     $self->_raw_stmt( $class, "\n" . $stmt  );
3077 }
3078
3079 sub _pod_cut {
3080     my ($self, $class ) = @_;
3081     $self->_raw_stmt( $class, "\n=cut\n" );
3082 }
3083
3084 # Store a raw source line for a class (for dumping purposes)
3085 sub _raw_stmt {
3086     my ($self, $class, $stmt) = @_;
3087     push(@{$self->{_dump_storage}->{$class}}, $stmt);
3088 }
3089
3090 # Like above, but separately for the externally loaded stuff
3091 sub _ext_stmt {
3092     my ($self, $class, $stmt) = @_;
3093     push(@{$self->{_ext_storage}->{$class}}, $stmt);
3094 }
3095
3096 sub _custom_column_info {
3097     my ( $self, $table_name, $column_name, $column_info ) = @_;
3098
3099     if (my $code = $self->custom_column_info) {
3100         return $code->($table_name, $column_name, $column_info) || {};
3101     }
3102     return {};
3103 }
3104
3105 sub _datetime_column_info {
3106     my ( $self, $table_name, $column_name, $column_info ) = @_;
3107     my $result = {};
3108     my $type = $column_info->{data_type} || '';
3109     if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
3110             or ($type =~ /date|timestamp/i)) {
3111         $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
3112         $result->{locale}   = $self->datetime_locale   if $self->datetime_locale;
3113     }
3114     return $result;
3115 }
3116
3117 sub _lc {
3118     my ($self, $name) = @_;
3119
3120     return $self->preserve_case ? $name : lc($name);
3121 }
3122
3123 sub _uc {
3124     my ($self, $name) = @_;
3125
3126     return $self->preserve_case ? $name : uc($name);
3127 }
3128
3129 sub _remove_table {
3130     my ($self, $table) = @_;
3131
3132     try {
3133         my $schema = $self->schema;
3134         # in older DBIC it's a private method
3135         my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
3136         $schema->$unregister(delete $self->monikers->{$table->sql_name});
3137         delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}};
3138         delete $self->_tables->{$table->sql_name};
3139     };
3140 }
3141
3142 # remove the dump dir from @INC on destruction
3143 sub DESTROY {
3144     my $self = shift;
3145
3146     @INC = grep $_ ne $self->dump_directory, @INC;
3147 }
3148
3149 =head2 monikers
3150
3151 Returns a hashref of loaded table to moniker mappings.  There will
3152 be two entries for each table, the original name and the "normalized"
3153 name, in the case that the two are different (such as databases
3154 that like uppercase table names, or preserve your original mixed-case
3155 definitions, or what-have-you).
3156
3157 =head2 classes
3158
3159 Returns a hashref of table to class mappings.  In some cases it will
3160 contain multiple entries per table for the original and normalized table
3161 names, as above in L</monikers>.
3162
3163 =head2 generated_classes
3164
3165 Returns an arrayref of classes that were actually generated (i.e. not
3166 skipped because there were no changes).
3167
3168 =head1 NON-ENGLISH DATABASES
3169
3170 If you use the loader on a database with table and column names in a language
3171 other than English, you will want to turn off the English language specific
3172 heuristics.
3173
3174 To do so, use something like this in your loader options:
3175
3176     naming           => { monikers => 'v4' },
3177     inflect_singular => sub { "$_[0]_rel" },
3178     inflect_plural   => sub { "$_[0]_rel" },
3179
3180 =head1 COLUMN ACCESSOR COLLISIONS
3181
3182 Occasionally you may have a column name that collides with a perl method, such
3183 as C<can>. In such cases, the default action is to set the C<accessor> of the
3184 column spec to C<undef>.
3185
3186 You can then name the accessor yourself by placing code such as the following
3187 below the md5:
3188
3189     __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
3190
3191 Another option is to use the L</col_collision_map> option.
3192
3193 =head1 RELATIONSHIP NAME COLLISIONS
3194
3195 In very rare cases, you may get a collision between a generated relationship
3196 name and a method in your Result class, for example if you have a foreign key
3197 called C<belongs_to>.
3198
3199 This is a problem because relationship names are also relationship accessor
3200 methods in L<DBIx::Class>.
3201
3202 The default behavior is to append C<_rel> to the relationship name and print
3203 out a warning that refers to this text.
3204
3205 You can also control the renaming with the L</rel_collision_map> option.
3206
3207 =head1 SEE ALSO
3208
3209 L<DBIx::Class::Schema::Loader>, L<dbicdump>
3210
3211 =head1 AUTHORS
3212
3213 See L<DBIx::Class::Schema::Loader/AUTHORS>.
3214
3215 =head1 LICENSE
3216
3217 This library is free software; you can redistribute it and/or modify it under
3218 the same terms as Perl itself.
3219
3220 =cut
3221
3222 1;
3223 # vim:et sts=4 sw=4 tw=0: