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