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