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