lib/DBIx/Class/Schema/Loader/Base.pm

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