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