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