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.07049';
  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 (or if you know your Moose is at at
 994 least version 2.1400, where MooseX::MarkAsMethods is no longer necessary),
 995 enabling this option falls back to just using L<namespace::autoclean> itself.
 996
 997 If none of the above made any sense, or you don't have some pressing need to
 998 only use L<namespace::autoclean>, leaving this set to the default is
 999 just fine.
1000
1001 =head2 col_collision_map
1002
1003 This option controls how accessors for column names which collide with perl
1004 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
1005
1006 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
1007 strings which are compiled to regular expressions that map to
1008 L<sprintf|perlfunc/sprintf> formats.
1009
1010 Examples:
1011
1012     col_collision_map => 'column_%s'
1013
1014     col_collision_map => { '(.*)' => 'column_%s' }
1015
1016     col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
1017
1018 =head2 rel_collision_map
1019
1020 Works just like L</col_collision_map>, but for relationship names/accessors
1021 rather than column names/accessors.
1022
1023 The default is to just append C<_rel> to the relationship name, see
1024 L</RELATIONSHIP NAME COLLISIONS>.
1025
1026 =head2 uniq_to_primary
1027
1028 Automatically promotes the largest unique constraints with non-nullable columns
1029 on tables to primary keys, assuming there is only one largest unique
1030 constraint.
1031
1032 =head2 allow_extra_m2m_cols
1033
1034 Generate C<many_to_many> relationship bridges even if the link table has
1035 extra columns other than the foreign keys.  The primary key must still
1036 equal the union of the foreign keys.
1037
1038
1039 =head2 filter_generated_code
1040
1041 An optional hook that lets you filter the generated text for various classes
1042 through a function that change it in any way that you want.  The function will
1043 receive the type of file, C<schema> or C<result>, class and code; and returns
1044 the new code to use instead.  For instance you could add custom comments, or do
1045 anything else that you want.
1046
1047 The option can also be set to a string, which is then used as a filter program,
1048 e.g. C<perltidy>.
1049
1050 If this exists but fails to return text matching C</\bpackage\b/>, no file will
1051 be generated.
1052
1053     filter_generated_code => sub {
1054         my ($type, $class, $text) = @_;
1055         ...
1056         return $new_code;
1057     }
1058
1059 You can also use this option to set L<perltidy markers|perltidy/Skipping
1060 Selected Sections of Code> in your generated classes.  This will leave
1061 the generated code in the default format, but will allow you to tidy
1062 your classes at any point in future, without worrying about changing the
1063 portions of the file which are checksummed, since C<perltidy> will just
1064 ignore all text between the markers.
1065
1066     filter_generated_code => sub {
1067         return "#<<<\n$_[2]\n#>>>";
1068     }
1069
1070 =head1 METHODS
1071
1072 None of these methods are intended for direct invocation by regular
1073 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
1074 L<DBIx::Class::Schema::Loader>.
1075
1076 =cut
1077
1078 # ensure that a piece of object data is a valid arrayref, creating
1079 # an empty one or encapsulating whatever's there.
1080 sub _ensure_arrayref {
1081     my $self = shift;
1082
1083     foreach (@_) {
1084         $self->{$_} ||= [];
1085         $self->{$_} = [ $self->{$_} ]
1086             unless ref $self->{$_} eq 'ARRAY';
1087     }
1088 }
1089
1090 =head2 new
1091
1092 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
1093 by L<DBIx::Class::Schema::Loader>.
1094
1095 =cut
1096
1097 sub new {
1098     my ( $class, %args ) = @_;
1099
1100     if (exists $args{column_accessor_map}) {
1101         $args{col_accessor_map} = delete $args{column_accessor_map};
1102     }
1103
1104     my $self = { %args };
1105
1106     # don't lose undef options
1107     for (values %$self) {
1108         $_ = 0 unless defined $_;
1109     }
1110
1111     bless $self => $class;
1112
1113     if (my $config_file = $self->config_file) {
1114         my $config_opts = do $config_file;
1115
1116         croak "Error reading config from $config_file: $@" if $@;
1117
1118         croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
1119
1120         while (my ($k, $v) = each %$config_opts) {
1121             $self->{$k} = $v unless exists $self->{$k};
1122         }
1123     }
1124
1125     if (defined $self->{result_component_map}) {
1126         if (defined $self->result_components_map) {
1127             croak "Specify only one of result_components_map or result_component_map";
1128         }
1129         $self->result_components_map($self->{result_component_map})
1130     }
1131
1132     if (defined $self->{result_role_map}) {
1133         if (defined $self->result_roles_map) {
1134             croak "Specify only one of result_roles_map or result_role_map";
1135         }
1136         $self->result_roles_map($self->{result_role_map})
1137     }
1138
1139     croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
1140         if ((not defined $self->use_moose) || (not $self->use_moose))
1141             && ((defined $self->result_roles) || (defined $self->result_roles_map));
1142
1143     $self->_ensure_arrayref(qw/schema_components
1144                                additional_classes
1145                                additional_base_classes
1146                                left_base_classes
1147                                components
1148                                result_roles
1149                               /);
1150
1151     $self->_validate_class_args;
1152
1153     croak "result_components_map must be a hash"
1154         if defined $self->result_components_map
1155             && ref $self->result_components_map ne 'HASH';
1156
1157     if ($self->result_components_map) {
1158         my %rc_map = %{ $self->result_components_map };
1159         foreach my $moniker (keys %rc_map) {
1160             $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
1161         }
1162         $self->result_components_map(\%rc_map);
1163     }
1164     else {
1165         $self->result_components_map({});
1166     }
1167     $self->_validate_result_components_map;
1168
1169     croak "result_roles_map must be a hash"
1170         if defined $self->result_roles_map
1171             && ref $self->result_roles_map ne 'HASH';
1172
1173     if ($self->result_roles_map) {
1174         my %rr_map = %{ $self->result_roles_map };
1175         foreach my $moniker (keys %rr_map) {
1176             $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
1177         }
1178         $self->result_roles_map(\%rr_map);
1179     } else {
1180         $self->result_roles_map({});
1181     }
1182     $self->_validate_result_roles_map;
1183
1184     if ($self->use_moose) {
1185         if ($self->only_autoclean) {
1186             if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose_only_autoclean')) {
1187                 die sprintf "You must install the following CPAN modules to enable the use_moose and only_autoclean options: %s.\n",
1188                     DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose_only_autoclean');
1189             }
1190         }
1191         else {
1192             if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
1193                 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
1194                     DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
1195             }
1196         }
1197     }
1198
1199     $self->{_tables} = {};
1200     $self->{monikers} = {};
1201     $self->{moniker_to_table} = {};
1202     $self->{class_to_table} = {};
1203     $self->{classes}  = {};
1204     $self->{_upgrading_classes} = {};
1205     $self->{generated_classes} = [];
1206
1207     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
1208     $self->{schema} ||= $self->{schema_class};
1209     $self->{table_comments_table} ||= 'table_comments';
1210     $self->{column_comments_table} ||= 'column_comments';
1211
1212     croak "dump_overwrite is deprecated.  Please read the"
1213         . " DBIx::Class::Schema::Loader::Base documentation"
1214             if $self->{dump_overwrite};
1215
1216     $self->{dynamic} = ! $self->{dump_directory};
1217
1218     croak "dry_run can only be used with static schema generation"
1219         if $self->dynamic and $self->dry_run;
1220
1221     $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
1222                                                      TMPDIR  => 1,
1223                                                      CLEANUP => 1,
1224                                                    );
1225
1226     $self->{dump_directory} ||= $self->{temp_directory};
1227
1228     $self->real_dump_directory($self->{dump_directory});
1229
1230     $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
1231     $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
1232
1233     if (not defined $self->naming) {
1234         $self->naming_set(0);
1235     }
1236     else {
1237         $self->naming_set(1);
1238     }
1239
1240     if ((not ref $self->naming) && defined $self->naming) {
1241         my $naming_ver = $self->naming;
1242         $self->{naming} = {
1243             relationships => $naming_ver,
1244             monikers => $naming_ver,
1245             column_accessors => $naming_ver,
1246         };
1247     }
1248     elsif (ref $self->naming eq 'HASH' && exists $self->naming->{ALL}) {
1249         my $val = delete $self->naming->{ALL};
1250
1251         $self->naming->{$_} = $val
1252             foreach qw/relationships monikers column_accessors/;
1253     }
1254
1255     if ($self->naming) {
1256         foreach my $key (qw/relationships monikers column_accessors/) {
1257             $self->naming->{$key} = $CURRENT_V if ($self->naming->{$key}||'') eq 'current';
1258         }
1259     }
1260     $self->{naming} ||= {};
1261
1262     if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
1263         croak 'custom_column_info must be a CODE ref';
1264     }
1265
1266     $self->_check_back_compat;
1267
1268     $self->use_namespaces(1) unless defined $self->use_namespaces;
1269     $self->generate_pod(1)   unless defined $self->generate_pod;
1270     $self->pod_comment_mode('auto')         unless defined $self->pod_comment_mode;
1271     $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
1272
1273     if (my $col_collision_map = $self->col_collision_map) {
1274         if (my $reftype = ref $col_collision_map) {
1275             if ($reftype ne 'HASH') {
1276                 croak "Invalid type $reftype for option 'col_collision_map'";
1277             }
1278         }
1279         else {
1280             $self->col_collision_map({ '(.*)' => $col_collision_map });
1281         }
1282     }
1283
1284     if (my $rel_collision_map = $self->rel_collision_map) {
1285         if (my $reftype = ref $rel_collision_map) {
1286             if ($reftype ne 'HASH') {
1287                 croak "Invalid type $reftype for option 'rel_collision_map'";
1288             }
1289         }
1290         else {
1291             $self->rel_collision_map({ '(.*)' => $rel_collision_map });
1292         }
1293     }
1294
1295     if (defined(my $rel_name_map = $self->rel_name_map)) {
1296         my $reftype = ref $rel_name_map;
1297         if ($reftype ne 'HASH' && $reftype ne 'CODE') {
1298             croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
1299         }
1300     }
1301
1302     if (defined(my $filter = $self->filter_generated_code)) {
1303         my $reftype = ref $filter;
1304         if ($reftype && $reftype ne 'CODE') {
1305             croak "Invalid type $reftype for option 'filter_generated_code, must be a scalar or a CODE reference";
1306         }
1307     }
1308
1309     if (defined $self->db_schema) {
1310         if (ref $self->db_schema eq 'ARRAY') {
1311             if (@{ $self->db_schema } > 1 && not defined $self->{qualify_objects}) {
1312                 $self->{qualify_objects} = 1;
1313             }
1314             elsif (@{ $self->db_schema } == 0) {
1315                 $self->{db_schema} = undef;
1316             }
1317         }
1318         elsif (not ref $self->db_schema) {
1319             if ($self->db_schema eq '%' && not defined $self->{qualify_objects}) {
1320                 $self->{qualify_objects} = 1;
1321             }
1322
1323             $self->{db_schema} = [ $self->db_schema ];
1324         }
1325     }
1326
1327     if (not $self->moniker_parts) {
1328         $self->moniker_parts(['name']);
1329     }
1330     else {
1331         if (not ref $self->moniker_parts) {
1332             $self->moniker_parts([ $self->moniker_parts ]);
1333         }
1334         if (ref $self->moniker_parts ne 'ARRAY') {
1335             croak 'moniker_parts must be an arrayref';
1336         }
1337         if (none { $_ eq 'name' } @{ $self->moniker_parts }) {
1338             croak "moniker_parts option *must* contain 'name'";
1339         }
1340     }
1341
1342     if (not defined $self->moniker_part_separator) {
1343         $self->moniker_part_separator('');
1344     }
1345     if (not defined $self->moniker_part_map) {
1346         $self->moniker_part_map({}),
1347     }
1348
1349     return $self;
1350 }
1351
1352 sub _check_back_compat {
1353     my ($self) = @_;
1354
1355 # dynamic schemas will always be in 0.04006 mode, unless overridden
1356     if ($self->dynamic) {
1357 # just in case, though no one is likely to dump a dynamic schema
1358         $self->schema_version_to_dump('0.04006');
1359
1360         if (not $self->naming_set) {
1361             warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1362
1363 Dynamic schema detected, will run in 0.04006 mode.
1364
1365 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1366 to disable this warning.
1367
1368 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1369 details.
1370 EOF
1371         }
1372         else {
1373             $self->_upgrading_from('v4');
1374         }
1375
1376         if ((not defined $self->use_namespaces) && ($self->naming_set)) {
1377             $self->use_namespaces(1);
1378         }
1379
1380         $self->naming->{relationships} ||= 'v4';
1381         $self->naming->{monikers}      ||= 'v4';
1382
1383         if ($self->use_namespaces) {
1384             $self->_upgrading_from_load_classes(1);
1385         }
1386         else {
1387             $self->use_namespaces(0);
1388         }
1389
1390         return;
1391     }
1392
1393 # otherwise check if we need backcompat mode for a static schema
1394     my $filename = $self->get_dump_filename($self->schema_class);
1395     return unless -e $filename;
1396
1397     my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
1398         $self->_parse_generated_file($filename);
1399
1400     return unless $old_ver;
1401
1402     # determine if the existing schema was dumped with use_moose => 1
1403     if (! defined $self->use_moose) {
1404         $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
1405     }
1406
1407     my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
1408
1409     my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
1410     my $ds = eval $result_namespace;
1411     die <<"EOF" if $@;
1412 Could not eval expression '$result_namespace' for result_namespace from
1413 $filename: $@
1414 EOF
1415     $result_namespace = $ds || '';
1416
1417     if ($load_classes && (not defined $self->use_namespaces)) {
1418         warn <<"EOF"  unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1419
1420 'load_classes;' static schema detected, turning off 'use_namespaces'.
1421
1422 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
1423 variable to disable this warning.
1424
1425 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1426 details.
1427 EOF
1428         $self->use_namespaces(0);
1429     }
1430     elsif ($load_classes && $self->use_namespaces) {
1431         $self->_upgrading_from_load_classes(1);
1432     }
1433     elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
1434         $self->_downgrading_to_load_classes(
1435             $result_namespace || 'Result'
1436         );
1437     }
1438     elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
1439         if (not $self->result_namespace) {
1440             $self->result_namespace($result_namespace || 'Result');
1441         }
1442         elsif ($result_namespace ne $self->result_namespace) {
1443             $self->_rewriting_result_namespace(
1444                 $result_namespace || 'Result'
1445             );
1446         }
1447     }
1448
1449     # XXX when we go past .0 this will need fixing
1450     my ($v) = $old_ver =~ /([1-9])/;
1451     $v = "v$v";
1452
1453     return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
1454
1455     if (not %{ $self->naming }) {
1456         warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1457
1458 Version $old_ver static schema detected, turning on backcompat mode.
1459
1460 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1461 to disable this warning.
1462
1463 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
1464
1465 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
1466 from version 0.04006.
1467 EOF
1468
1469         $self->naming->{relationships}    ||= $v;
1470         $self->naming->{monikers}         ||= $v;
1471         $self->naming->{column_accessors} ||= $v;
1472
1473         $self->schema_version_to_dump($old_ver);
1474     }
1475     else {
1476         $self->_upgrading_from($v);
1477     }
1478 }
1479
1480 sub _validate_class_args {
1481     my $self = shift;
1482
1483     foreach my $k (@CLASS_ARGS) {
1484         next unless $self->$k;
1485
1486         my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
1487         $self->_validate_classes($k, \@classes);
1488     }
1489 }
1490
1491 sub _validate_result_components_map {
1492     my $self = shift;
1493
1494     foreach my $classes (values %{ $self->result_components_map }) {
1495         $self->_validate_classes('result_components_map', $classes);
1496     }
1497 }
1498
1499 sub _validate_result_roles_map {
1500     my $self = shift;
1501
1502     foreach my $classes (values %{ $self->result_roles_map }) {
1503         $self->_validate_classes('result_roles_map', $classes);
1504     }
1505 }
1506
1507 sub _validate_classes {
1508     my $self = shift;
1509     my $key  = shift;
1510     my $classes = shift;
1511
1512     # make a copy to not destroy original
1513     my @classes = @$classes;
1514
1515     foreach my $c (@classes) {
1516         # components default to being under the DBIx::Class namespace unless they
1517         # are preceded with a '+'
1518         if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1519             $c = 'DBIx::Class::' . $c;
1520         }
1521
1522         # 1 == installed, 0 == not installed, undef == invalid classname
1523         my $installed = Class::Inspector->installed($c);
1524         if ( defined($installed) ) {
1525             if ( $installed == 0 ) {
1526                 croak qq/$c, as specified in the loader option "$key", is not installed/;
1527             }
1528         } else {
1529             croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1530         }
1531     }
1532 }
1533
1534
1535 sub _find_file_in_inc {
1536     my ($self, $file) = @_;
1537
1538     foreach my $prefix (@INC) {
1539         my $fullpath = File::Spec->catfile($prefix, $file);
1540         # abs_path pure-perl fallback warns for non-existent files
1541         local $SIG{__WARN__} = sigwarn_silencer(qr/^stat\(.*\Q$file\E\)/);
1542         return $fullpath if -f $fullpath
1543             # abs_path throws on Windows for nonexistent files
1544             and (try { Cwd::abs_path($fullpath) }) ne
1545                ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1546     }
1547
1548     return;
1549 }
1550
1551 sub _find_class_in_inc {
1552     my ($self, $class) = @_;
1553
1554     return $self->_find_file_in_inc(class_path($class));
1555 }
1556
1557 sub _rewriting {
1558     my $self = shift;
1559
1560     return $self->_upgrading_from
1561         || $self->_upgrading_from_load_classes
1562         || $self->_downgrading_to_load_classes
1563         || $self->_rewriting_result_namespace
1564     ;
1565 }
1566
1567 sub _rewrite_old_classnames {
1568     my ($self, $code) = @_;
1569
1570     return $code unless $self->_rewriting;
1571
1572     my %old_classes = reverse %{ $self->_upgrading_classes };
1573
1574     my $re = join '|', keys %old_classes;
1575     $re = qr/\b($re)\b/;
1576
1577     $code =~ s/$re/$old_classes{$1} || $1/eg;
1578
1579     return $code;
1580 }
1581
1582 sub _load_external {
1583     my ($self, $class) = @_;
1584
1585     return if $self->{skip_load_external};
1586
1587     # so that we don't load our own classes, under any circumstances
1588     local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1589
1590     my $real_inc_path = $self->_find_class_in_inc($class);
1591
1592     my $old_class = $self->_upgrading_classes->{$class}
1593         if $self->_rewriting;
1594
1595     my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1596         if $old_class && $old_class ne $class;
1597
1598     return unless $real_inc_path || $old_real_inc_path;
1599
1600     if ($real_inc_path) {
1601         # If we make it to here, we loaded an external definition
1602         warn qq/# Loaded external class definition for '$class'\n/
1603             if $self->debug;
1604
1605         my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path);
1606
1607         if ($self->dynamic) { # load the class too
1608             eval_package_without_redefine_warnings($class, $code);
1609         }
1610
1611         $self->_ext_stmt($class,
1612             qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1613            .qq|# They are now part of the custom portion of this file\n|
1614            .qq|# for you to hand-edit.  If you do not either delete\n|
1615            .qq|# this section or remove that file from \@INC, this section\n|
1616            .qq|# will be repeated redundantly when you re-create this\n|
1617            .qq|# file again via Loader!  See skip_load_external to disable\n|
1618            .qq|# this feature.\n|
1619         );
1620         chomp $code;
1621         $self->_ext_stmt($class, $code);
1622         $self->_ext_stmt($class,
1623             qq|# End of lines loaded from '$real_inc_path'|
1624         );
1625     }
1626
1627     if ($old_real_inc_path) {
1628         my $code = slurp_file $old_real_inc_path;
1629
1630         $self->_ext_stmt($class, <<"EOF");
1631
1632 # These lines were loaded from '$old_real_inc_path',
1633 # based on the Result class name that would have been created by an older
1634 # version of the Loader. For a static schema, this happens only once during
1635 # upgrade. See skip_load_external to disable this feature.
1636 EOF
1637
1638         $code = $self->_rewrite_old_classnames($code);
1639
1640         if ($self->dynamic) {
1641             warn <<"EOF";
1642
1643 Detected external content in '$old_real_inc_path', a class name that would have
1644 been used by an older version of the Loader.
1645
1646 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1647 new name of the Result.
1648 EOF
1649             eval_package_without_redefine_warnings($class, $code);
1650         }
1651
1652         chomp $code;
1653         $self->_ext_stmt($class, $code);
1654         $self->_ext_stmt($class,
1655             qq|# End of lines loaded from '$old_real_inc_path'|
1656         );
1657     }
1658 }
1659
1660 =head2 load
1661
1662 Does the actual schema-construction work.
1663
1664 =cut
1665
1666 sub load {
1667     my $self = shift;
1668
1669     $self->_load_tables($self->_tables_list);
1670 }
1671
1672 =head2 rescan
1673
1674 Arguments: schema
1675
1676 Rescan the database for changes. Returns a list of the newly added table
1677 monikers.
1678
1679 The schema argument should be the schema class or object to be affected.  It
1680 should probably be derived from the original schema_class used during L</load>.
1681
1682 =cut
1683
1684 sub rescan {
1685     my ($self, $schema) = @_;
1686
1687     $self->{schema} = $schema;
1688     $self->_relbuilder->{schema} = $schema;
1689
1690     my @created;
1691     my @current = $self->_tables_list;
1692
1693     foreach my $table (@current) {
1694         if(!exists $self->_tables->{$table->sql_name}) {
1695             push(@created, $table);
1696         }
1697     }
1698
1699     my %current;
1700     @current{map $_->sql_name, @current} = ();
1701     foreach my $table (values %{ $self->_tables }) {
1702         if (not exists $current{$table->sql_name}) {
1703             $self->_remove_table($table);
1704         }
1705     }
1706
1707     delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1708
1709     my $loaded = $self->_load_tables(@current);
1710
1711     foreach my $table (@created) {
1712         $self->monikers->{$table->sql_name} = $self->_table2moniker($table);
1713     }
1714
1715     return map { $self->monikers->{$_->sql_name} } @created;
1716 }
1717
1718 sub _relbuilder {
1719     my ($self) = @_;
1720
1721     return if $self->{skip_relationships};
1722
1723     return $self->{relbuilder} ||= do {
1724         my $relbuilder_suff =
1725             {qw{
1726                 v4  ::Compat::v0_040
1727                 v5  ::Compat::v0_05
1728                 v6  ::Compat::v0_06
1729                 v7  ::Compat::v0_07
1730             }}
1731             ->{$self->naming->{relationships}||$CURRENT_V} || '';
1732
1733         my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1734         $self->ensure_class_loaded($relbuilder_class);
1735         $relbuilder_class->new($self);
1736     };
1737 }
1738
1739 sub _load_tables {
1740     my ($self, @tables) = @_;
1741
1742     # Save the new tables to the tables list and compute monikers
1743     foreach (@tables) {
1744         $self->_tables->{$_->sql_name}  = $_;
1745         $self->monikers->{$_->sql_name} = $self->_table2moniker($_);
1746     }
1747
1748     # check for moniker clashes
1749     my $inverse_moniker_idx;
1750     foreach my $imtable (values %{ $self->_tables }) {
1751         push @{ $inverse_moniker_idx->{$self->monikers->{$imtable->sql_name}} }, $imtable;
1752     }
1753
1754     my @clashes;
1755     foreach my $moniker (keys %$inverse_moniker_idx) {
1756         my $imtables = $inverse_moniker_idx->{$moniker};
1757         if (@$imtables > 1) {
1758             my $different_databases =
1759                 $imtables->[0]->can('database') && (uniq map $_->database||'', @$imtables) > 1;
1760
1761             my $different_schemas =
1762                 (uniq map $_->schema||'', @$imtables) > 1;
1763
1764             if ($different_databases || $different_schemas) {
1765                 my ($use_schema, $use_database) = (1, 0);
1766
1767                 if ($different_databases) {
1768                     $use_database = 1;
1769
1770                     # If any monikers are in the same database, we have to distinguish by
1771                     # both schema and database.
1772                     my %db_counts;
1773                     $db_counts{$_}++ for map $_->database, @$imtables;
1774                     $use_schema = any { $_ > 1 } values %db_counts;
1775                 }
1776
1777                 foreach my $tbl (@$imtables) { delete $self->monikers->{$tbl->sql_name}; }
1778
1779                 my $moniker_parts = [ @{ $self->moniker_parts } ];
1780
1781                 my $have_schema   = any { $_ eq 'schema'   } @{ $self->moniker_parts };
1782                 my $have_database = any { $_ eq 'database' } @{ $self->moniker_parts };
1783
1784                 unshift @$moniker_parts, 'schema'   if $use_schema   && !$have_schema;
1785                 unshift @$moniker_parts, 'database' if $use_database && !$have_database;
1786
1787                 local $self->{moniker_parts} = $moniker_parts;
1788
1789                 my %new_monikers;
1790
1791                 foreach my $tbl  (@$imtables)                   { $new_monikers{$tbl->sql_name} = $self->_table2moniker($tbl); }
1792                 foreach my $name (map $_->sql_name, @$imtables) { $self->monikers->{$name} = $new_monikers{$name}; }
1793
1794                 # check if there are still clashes
1795                 my %by_moniker;
1796
1797                 while (my ($t, $m) = each %new_monikers) {
1798                     push @{ $by_moniker{$m} }, $t;
1799                 }
1800
1801                 foreach my $m (grep @{ $by_moniker{$_} } > 1, keys %by_moniker) {
1802                     push @clashes, sprintf ("tried disambiguating by moniker_parts, but tables %s still reduced to the same source moniker '%s'",
1803                         join (', ', @{ $by_moniker{$m} }),
1804                         $m,
1805                     );
1806                 }
1807             }
1808             else {
1809                 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1810                     join (', ', map $_->sql_name, @$imtables),
1811                     $moniker,
1812                 );
1813             }
1814         }
1815     }
1816
1817     if (@clashes) {
1818         die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1819         . 'Change the naming style, or supply an explicit moniker_map: '
1820         . join ('; ', @clashes)
1821         . "\n"
1822         ;
1823     }
1824
1825     foreach my $tbl (@tables) { $self->_make_src_class($tbl); }
1826     foreach my $tbl (@tables) { $self->_setup_src_meta($tbl); }
1827
1828     if(!$self->skip_relationships) {
1829         # The relationship loader needs a working schema
1830         local $self->{quiet} = 1;
1831         local $self->{dump_directory} = $self->{temp_directory};
1832         local $self->{generated_classes} = [];
1833         local $self->{dry_run} = 0;
1834         $self->_reload_classes(\@tables);
1835         $self->_load_relationships(\@tables);
1836
1837         # Remove that temp dir from INC so it doesn't get reloaded
1838         @INC = grep $_ ne $self->dump_directory, @INC;
1839     }
1840
1841     foreach my $tbl                                        (@tables) { $self->_load_roles($tbl); }
1842     foreach my $tbl (map { $self->classes->{$_->sql_name} } @tables) { $self->_load_external($tbl); }
1843
1844     # Reload without unloading first to preserve any symbols from external
1845     # packages.
1846     $self->_reload_classes(\@tables, { unload => 0 });
1847
1848     # Drop temporary cache
1849     delete $self->{_cache};
1850
1851     return \@tables;
1852 }
1853
1854 sub _reload_classes {
1855     my ($self, $tables, $opts) = @_;
1856
1857     my @tables = @$tables;
1858
1859     my $unload = $opts->{unload};
1860     $unload = 1 unless defined $unload;
1861
1862     # so that we don't repeat custom sections
1863     @INC = grep $_ ne $self->dump_directory, @INC;
1864
1865     $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables);
1866
1867     unshift @INC, $self->dump_directory;
1868
1869     return if $self->dry_run;
1870
1871     my @to_register;
1872     my %have_source = map { $_ => $self->schema->source($_) }
1873         $self->schema->sources;
1874
1875     for my $table (@tables) {
1876         my $moniker = $self->monikers->{$table->sql_name};
1877         my $class = $self->classes->{$table->sql_name};
1878
1879         {
1880             no warnings 'redefine';
1881             local *Class::C3::reinitialize = sub {};  # to speed things up, reinitialized below
1882             use warnings;
1883
1884             if (my $mc = $self->_moose_metaclass($class)) {
1885                 $mc->make_mutable;
1886             }
1887             Class::Unload->unload($class) if $unload;
1888             my ($source, $resultset_class);
1889             if (
1890                 ($source = $have_source{$moniker})
1891                 && ($resultset_class = $source->resultset_class)
1892                 && ($resultset_class ne 'DBIx::Class::ResultSet')
1893             ) {
1894                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1895                 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1896                     $mc->make_mutable;
1897                 }
1898                 Class::Unload->unload($resultset_class) if $unload;
1899                 $self->_reload_class($resultset_class) if $has_file;
1900             }
1901             $self->_reload_class($class);
1902         }
1903         push @to_register, [$moniker, $class];
1904     }
1905
1906     Class::C3->reinitialize;
1907     for (@to_register) {
1908         $self->schema->register_class(@$_);
1909     }
1910 }
1911
1912 sub _moose_metaclass {
1913     return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1914
1915     my $class = $_[1];
1916
1917     my $mc = try { Class::MOP::class_of($class) }
1918         or return undef;
1919
1920     return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1921 }
1922
1923 # We use this instead of ensure_class_loaded when there are package symbols we
1924 # want to preserve.
1925 sub _reload_class {
1926     my ($self, $class) = @_;
1927
1928     delete $INC{ +class_path($class) };
1929
1930     try {
1931         eval_package_without_redefine_warnings ($class, "require $class");
1932     }
1933     catch {
1934         my $source = slurp_file $self->_get_dump_filename($class);
1935         die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1936     };
1937 }
1938
1939 sub _get_dump_filename {
1940     my ($self, $class) = (@_);
1941
1942     $class =~ s{::}{/}g;
1943     return $self->dump_directory . q{/} . $class . q{.pm};
1944 }
1945
1946 =head2 get_dump_filename
1947
1948 Arguments: class
1949
1950 Returns the full path to the file for a class that the class has been or will
1951 be dumped to. This is a file in a temp dir for a dynamic schema.
1952
1953 =cut
1954
1955 sub get_dump_filename {
1956     my ($self, $class) = (@_);
1957
1958     local $self->{dump_directory} = $self->real_dump_directory;
1959
1960     return $self->_get_dump_filename($class);
1961 }
1962
1963 sub _ensure_dump_subdirs {
1964     my ($self, $class) = (@_);
1965
1966     return if $self->dry_run;
1967
1968     my @name_parts = split(/::/, $class);
1969     pop @name_parts; # we don't care about the very last element,
1970                      # which is a filename
1971
1972     my $dir = $self->dump_directory;
1973     while (1) {
1974         if(!-d $dir) {
1975             mkdir($dir) or croak "mkdir('$dir') failed: $!";
1976         }
1977         last if !@name_parts;
1978         $dir = File::Spec->catdir($dir, shift @name_parts);
1979     }
1980 }
1981
1982 sub _dump_to_dir {
1983     my ($self, @classes) = @_;
1984
1985     my $schema_class = $self->schema_class;
1986     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1987
1988     my $target_dir = $self->dump_directory;
1989     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1990         unless $self->dynamic or $self->quiet;
1991
1992     my $schema_text =
1993           qq|use utf8;\n|
1994         . qq|package $schema_class;\n\n|
1995         . qq|# Created by DBIx::Class::Schema::Loader\n|
1996         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1997
1998     my $autoclean
1999         = $self->only_autoclean
2000         ? 'namespace::autoclean'
2001         : 'MooseX::MarkAsMethods autoclean => 1'
2002         ;
2003
2004     if ($self->use_moose) {
2005
2006         $schema_text.= qq|use Moose;\nuse $autoclean;\nextends '$schema_base_class';\n\n|;
2007     }
2008     else {
2009         $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
2010     }
2011
2012     my @schema_components = @{ $self->schema_components || [] };
2013
2014     if (@schema_components) {
2015         my $schema_components = dump @schema_components;
2016         $schema_components = "($schema_components)" if @schema_components == 1;
2017
2018         $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
2019     }
2020
2021     if ($self->use_namespaces) {
2022         $schema_text .= qq|__PACKAGE__->load_namespaces|;
2023         my $namespace_options;
2024
2025         my @attr = qw/resultset_namespace default_resultset_class/;
2026
2027         unshift @attr, 'result_namespace'
2028             if $self->result_namespace && $self->result_namespace ne 'Result';
2029
2030         for my $attr (@attr) {
2031             if ($self->$attr) {
2032                 my $code = dumper_squashed $self->$attr;
2033                 $namespace_options .= qq|    $attr => $code,\n|
2034             }
2035         }
2036         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
2037         $schema_text .= qq|;\n|;
2038     }
2039     else {
2040         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
2041     }
2042
2043     {
2044         local $self->{version_to_dump} = $self->schema_version_to_dump;
2045         $self->_write_classfile($schema_class, $schema_text, 1);
2046     }
2047
2048     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
2049
2050     foreach my $src_class (@classes) {
2051         my $src_text =
2052               qq|use utf8;\n|
2053             . qq|package $src_class;\n\n|
2054             . qq|# Created by DBIx::Class::Schema::Loader\n|
2055             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
2056
2057         $src_text .= $self->_make_pod_heading($src_class);
2058
2059         $src_text .= qq|use strict;\nuse warnings;\n\n|;
2060
2061         $src_text .= $self->_base_class_pod($result_base_class)
2062             unless $result_base_class eq 'DBIx::Class::Core';
2063
2064         if ($self->use_moose) {
2065             $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse $autoclean;|;
2066
2067             # these options 'use base' which is compile time
2068             if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
2069                 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
2070             }
2071             else {
2072                 $src_text .= qq|\nextends '$result_base_class';\n|;
2073             }
2074         }
2075         else {
2076             $src_text .= qq|use base '$result_base_class';\n|;
2077         }
2078
2079         $self->_write_classfile($src_class, $src_text);
2080     }
2081
2082     # remove Result dir if downgrading from use_namespaces, and there are no
2083     # files left.
2084     if (my $result_ns = $self->_downgrading_to_load_classes
2085                         || $self->_rewriting_result_namespace) {
2086         my $result_namespace = $self->_result_namespace(
2087             $schema_class,
2088             $result_ns,
2089         );
2090
2091         (my $result_dir = $result_namespace) =~ s{::}{/}g;
2092         $result_dir = $self->dump_directory . '/' . $result_dir;
2093
2094         unless (my @files = glob "$result_dir/*") {
2095             rmdir $result_dir;
2096         }
2097     }
2098
2099     warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
2100 }
2101
2102 sub _sig_comment {
2103     my ($self, $version, $ts) = @_;
2104     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
2105          . (defined($version) ? q| v| . $version : '')
2106          . (defined($ts) ? q| @ | . $ts : '')
2107          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
2108 }
2109
2110 sub _write_classfile {
2111     my ($self, $class, $text, $is_schema) = @_;
2112
2113     my $filename = $self->_get_dump_filename($class);
2114     $self->_ensure_dump_subdirs($class);
2115
2116     if (-f $filename && $self->really_erase_my_files && !$self->dry_run) {
2117         warn "Deleting existing file '$filename' due to "
2118             . "'really_erase_my_files' setting\n" unless $self->quiet;
2119         unlink($filename);
2120     }
2121
2122     my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
2123         = $self->_parse_generated_file($filename);
2124
2125     if (! $old_gen && -f $filename) {
2126         croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
2127             . " it does not appear to have been generated by Loader"
2128     }
2129
2130     my $custom_content = $old_custom || '';
2131
2132     # Use custom content from a renamed class, the class names in it are
2133     # rewritten below.
2134     if (my $renamed_class = $self->_upgrading_classes->{$class}) {
2135         my $old_filename = $self->_get_dump_filename($renamed_class);
2136
2137         if (-f $old_filename) {
2138             $custom_content = ($self->_parse_generated_file ($old_filename))[4];
2139
2140             unlink $old_filename unless $self->dry_run;
2141         }
2142     }
2143
2144     $custom_content ||= $self->_default_custom_content($is_schema);
2145
2146     # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
2147     # If there is already custom content, which does not have the Moose content, add it.
2148     if ($self->use_moose) {
2149
2150         my $non_moose_custom_content = do {
2151             local $self->{use_moose} = 0;
2152             $self->_default_custom_content;
2153         };
2154
2155         if ($custom_content eq $non_moose_custom_content) {
2156             $custom_content = $self->_default_custom_content($is_schema);
2157         }
2158         elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
2159             $custom_content .= $self->_default_custom_content($is_schema);
2160         }
2161     }
2162     elsif (defined $self->use_moose && $old_gen) {
2163         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'
2164             if $old_gen =~ /use \s+ MooseX?\b/x;
2165     }
2166
2167     $custom_content = $self->_rewrite_old_classnames($custom_content);
2168
2169     $text .= qq|$_\n|
2170         for @{$self->{_dump_storage}->{$class} || []};
2171
2172     if ($self->filter_generated_code) {
2173         my $filter = $self->filter_generated_code;
2174
2175         if (ref $filter eq 'CODE') {
2176             $text = $filter->(
2177                 ($is_schema ? 'schema' : 'result'),
2178                 $class,
2179                 $text
2180             );
2181         }
2182         else {
2183             my ($fh, $temp_file) = tempfile();
2184
2185             binmode $fh, ':encoding(UTF-8)';
2186             print $fh $text;
2187             close $fh;
2188
2189             open my $out, qq{$filter < "$temp_file"|}
2190                 or croak "Could not open pipe to $filter: $!";
2191
2192             $text = decode('UTF-8', do { local $/; <$out> });
2193
2194             $text =~ s/$CR?$LF/\n/g;
2195
2196             close $out;
2197
2198             my $exit_code = $? >> 8;
2199
2200             unlink $temp_file
2201                 or croak "Could not remove temporary file '$temp_file': $!";
2202
2203             if ($exit_code != 0) {
2204                 croak "filter '$filter' exited non-zero: $exit_code";
2205             }
2206         }
2207         if (not $text or not $text =~ /\bpackage\b/) {
2208             warn("$class skipped due to filter") if $self->debug;
2209             return;
2210         }
2211     }
2212
2213     # Check and see if the dump is in fact different
2214
2215     my $compare_to;
2216     if ($old_md5) {
2217         $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
2218         if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
2219             return unless $self->_upgrading_from && $is_schema;
2220         }
2221     }
2222
2223     push @{$self->generated_classes}, $class;
2224
2225     return if $self->dry_run;
2226
2227     $text .= $self->_sig_comment(
2228         $self->omit_version ? undef : $self->version_to_dump,
2229         $self->omit_timestamp ? undef : POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
2230     );
2231
2232     open(my $fh, '>:raw:encoding(UTF-8)', $filename)
2233         or croak "Cannot open '$filename' for writing: $!";
2234
2235     # Write the top half and its MD5 sum
2236     print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
2237
2238     # Write out anything loaded via external partial class file in @INC
2239     print $fh qq|$_\n|
2240         for @{$self->{_ext_storage}->{$class} || []};
2241
2242     # Write out any custom content the user has added
2243     print $fh $custom_content;
2244
2245     close($fh)
2246         or croak "Error closing '$filename': $!";
2247 }
2248
2249 sub _default_moose_custom_content {
2250     my ($self, $is_schema) = @_;
2251
2252     if (not $is_schema) {
2253         return qq|\n__PACKAGE__->meta->make_immutable;|;
2254     }
2255
2256     return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
2257 }
2258
2259 sub _default_custom_content {
2260     my ($self, $is_schema) = @_;
2261     my $default = qq|\n\n# You can replace this text with custom|
2262          . qq| code or comments, and it will be preserved on regeneration|;
2263     if ($self->use_moose) {
2264         $default .= $self->_default_moose_custom_content($is_schema);
2265     }
2266     $default .= qq|\n1;\n|;
2267     return $default;
2268 }
2269
2270 sub _parse_generated_file {
2271     my ($self, $fn) = @_;
2272
2273     return unless -f $fn;
2274
2275     open(my $fh, '<:encoding(UTF-8)', $fn)
2276         or croak "Cannot open '$fn' for reading: $!";
2277
2278     my $mark_re =
2279         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
2280
2281     my ($real_md5, $ts, $ver, $gen);
2282     local $_;
2283     while(<$fh>) {
2284         if(/$mark_re/) {
2285             my $pre_md5 = $1;
2286             my $mark_md5 = $2;
2287
2288             # Pull out the version and timestamp from the line above
2289             ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader( v[\d._]+)?( @ [\d-]+ [\d:]+)?\r?\Z/m;
2290             $ver =~ s/^ v// if $ver;
2291             $ts =~ s/^ @ // if $ts;
2292
2293             $gen .= $pre_md5;
2294             $real_md5 = Digest::MD5::md5_base64(encode 'UTF-8', $gen);
2295             if ($real_md5 ne $mark_md5) {
2296                 if ($self->overwrite_modifications) {
2297                     # Setting this to something that is not a valid MD5 forces
2298                     # the file to be rewritten.
2299                     $real_md5 = 'not an MD5';
2300                 }
2301                 else {
2302                     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";
2303                 }
2304             }
2305             last;
2306         }
2307         else {
2308             $gen .= $_;
2309         }
2310     }
2311
2312     my $custom = do { local $/; <$fh> }
2313         if $real_md5;
2314
2315     $custom ||= '';
2316     $custom =~ s/$CRLF|$LF/\n/g;
2317
2318     close $fh;
2319
2320     return ($gen, $real_md5, $ver, $ts, $custom);
2321 }
2322
2323 sub _use {
2324     my $self = shift;
2325     my $target = shift;
2326
2327     foreach (@_) {
2328         warn "$target: use $_;" if $self->debug;
2329         $self->_raw_stmt($target, "use $_;");
2330     }
2331 }
2332
2333 sub _inject {
2334     my $self = shift;
2335     my $target = shift;
2336
2337     my $blist = join(q{ }, @_);
2338
2339     return unless $blist;
2340
2341     warn "$target: use base qw/$blist/;" if $self->debug;
2342     $self->_raw_stmt($target, "use base qw/$blist/;");
2343 }
2344
2345 sub _with {
2346     my $self = shift;
2347     my $target = shift;
2348
2349     my $rlist = join(q{, }, map { qq{'$_'} } @_);
2350
2351     return unless $rlist;
2352
2353     warn "$target: with $rlist;" if $self->debug;
2354     $self->_raw_stmt($target, "\nwith $rlist;");
2355 }
2356
2357 sub _result_namespace {
2358     my ($self, $schema_class, $ns) = @_;
2359     my @result_namespace;
2360
2361     $ns = $ns->[0] if ref $ns;
2362
2363     if ($ns =~ /^\+(.*)/) {
2364         # Fully qualified namespace
2365         @result_namespace = ($1)
2366     }
2367     else {
2368         # Relative namespace
2369         @result_namespace = ($schema_class, $ns);
2370     }
2371
2372     return wantarray ? @result_namespace : join '::', @result_namespace;
2373 }
2374
2375 # Create class with applicable bases, setup monikers, etc
2376 sub _make_src_class {
2377     my ($self, $table) = @_;
2378
2379     my $schema       = $self->schema;
2380     my $schema_class = $self->schema_class;
2381
2382     my $table_moniker = $self->monikers->{$table->sql_name};
2383     my @result_namespace = ($schema_class);
2384     if ($self->use_namespaces) {
2385         my $result_namespace = $self->result_namespace || 'Result';
2386         @result_namespace = $self->_result_namespace(
2387             $schema_class,
2388             $result_namespace,
2389         );
2390     }
2391     my $table_class = join(q{::}, @result_namespace, $table_moniker);
2392
2393     if ((my $upgrading_v = $self->_upgrading_from)
2394             || $self->_rewriting) {
2395         local $self->naming->{monikers} = $upgrading_v
2396             if $upgrading_v;
2397
2398         my @result_namespace = @result_namespace;
2399         if ($self->_upgrading_from_load_classes) {
2400             @result_namespace = ($schema_class);
2401         }
2402         elsif (my $ns = $self->_downgrading_to_load_classes) {
2403             @result_namespace = $self->_result_namespace(
2404                 $schema_class,
2405                 $ns,
2406             );
2407         }
2408         elsif ($ns = $self->_rewriting_result_namespace) {
2409             @result_namespace = $self->_result_namespace(
2410                 $schema_class,
2411                 $ns,
2412             );
2413         }
2414
2415         my $old_table_moniker = do {
2416             local $self->naming->{monikers} = $upgrading_v;
2417             $self->_table2moniker($table);
2418         };
2419
2420         my $old_class = join(q{::}, @result_namespace, $old_table_moniker);
2421
2422         $self->_upgrading_classes->{$table_class} = $old_class
2423             unless $table_class eq $old_class;
2424     }
2425
2426     $self->classes->{$table->sql_name}  = $table_class;
2427     $self->moniker_to_table->{$table_moniker} = $table;
2428     $self->class_to_table->{$table_class} = $table;
2429
2430     $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
2431
2432     $self->_use   ($table_class, @{$self->additional_classes});
2433
2434     $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
2435
2436     $self->_inject($table_class, @{$self->left_base_classes});
2437
2438     my @components = @{ $self->components || [] };
2439
2440     push @components, @{ $self->result_components_map->{$table_moniker} }
2441         if exists $self->result_components_map->{$table_moniker};
2442
2443     my @fq_components = @components;
2444     foreach my $component (@fq_components) {
2445         if ($component !~ s/^\+//) {
2446             $component = "DBIx::Class::$component";
2447         }
2448     }
2449
2450     $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
2451
2452     $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
2453
2454     $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
2455
2456     $self->_inject($table_class, @{$self->additional_base_classes});
2457 }
2458
2459 sub _is_result_class_method {
2460     my ($self, $name, $table) = @_;
2461
2462     my $table_moniker = $table ? $self->monikers->{$table->sql_name} : '';
2463
2464     $self->_result_class_methods({})
2465         if not defined $self->_result_class_methods;
2466
2467     if (not exists $self->_result_class_methods->{$table_moniker}) {
2468         my (@methods, %methods);
2469         my $base       = $self->result_base_class || 'DBIx::Class::Core';
2470
2471         my @components = @{ $self->components || [] };
2472
2473         push @components, @{ $self->result_components_map->{$table_moniker} }
2474             if exists $self->result_components_map->{$table_moniker};
2475
2476         for my $c (@components) {
2477             $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
2478         }
2479
2480         my @roles = @{ $self->result_roles || [] };
2481
2482         push @roles, @{ $self->result_roles_map->{$table_moniker} }
2483             if exists $self->result_roles_map->{$table_moniker};
2484
2485         for my $class (
2486             $base, @components, @roles,
2487             ($self->use_moose ? 'Moose::Object' : ()),
2488         ) {
2489             $self->ensure_class_loaded($class);
2490
2491             push @methods, @{ Class::Inspector->methods($class) || [] };
2492         }
2493
2494         push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
2495
2496         @methods{@methods} = ();
2497
2498         $self->_result_class_methods->{$table_moniker} = \%methods;
2499     }
2500     my $result_methods = $self->_result_class_methods->{$table_moniker};
2501
2502     return exists $result_methods->{$name};
2503 }
2504
2505 sub _resolve_col_accessor_collisions {
2506     my ($self, $table, $col_info) = @_;
2507
2508     while (my ($col, $info) = each %$col_info) {
2509         my $accessor = $info->{accessor} || $col;
2510
2511         next if $accessor eq 'id'; # special case (very common column)
2512
2513         if ($self->_is_result_class_method($accessor, $table)) {
2514             my $mapped = 0;
2515
2516             if (my $map = $self->col_collision_map) {
2517                 for my $re (keys %$map) {
2518                     if (my @matches = $col =~ /$re/) {
2519                         $info->{accessor} = sprintf $map->{$re}, @matches;
2520                         $mapped = 1;
2521                     }
2522                 }
2523             }
2524
2525             if (not $mapped) {
2526                 warn <<"EOF";
2527 Column '$col' in table '$table' collides with an inherited method.
2528 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
2529 EOF
2530                 $info->{accessor} = undef;
2531             }
2532         }
2533     }
2534 }
2535
2536 # use the same logic to run moniker_map, col_accessor_map
2537 sub _run_user_map {
2538     my ( $self, $map, $default_code, $ident, @extra ) = @_;
2539
2540     my $default_ident = $default_code->( $ident, @extra );
2541     my $new_ident;
2542     if( $map && ref $map eq 'HASH' ) {
2543         if (my @parts = try { @{ $ident } }) {
2544             my $part_map = $map;
2545             while (@parts) {
2546                 my $part = shift @parts;
2547                 last unless exists $part_map->{ $part };
2548                 if ( !ref $part_map->{ $part } && !@parts ) {
2549                     $new_ident = $part_map->{ $part };
2550                     last;
2551                 }
2552                 elsif ( ref $part_map->{ $part } eq 'HASH' ) {
2553                     $part_map = $part_map->{ $part };
2554                 }
2555             }
2556         }
2557         if( !$new_ident && !ref $map->{ $ident } ) {
2558             $new_ident = $map->{ $ident };
2559         }
2560     }
2561     elsif( $map && ref $map eq 'CODE' ) {
2562         my $cb = sub {
2563             my ($cb_map) = @_;
2564             croak "reentered map must be a hashref"
2565                 unless 'HASH' eq ref($cb_map);
2566             return $self->_run_user_map($cb_map, $default_code, $ident, @extra);
2567         };
2568         $new_ident = $map->( $ident, $default_ident, @extra, $cb );
2569     }
2570
2571     $new_ident ||= $default_ident;
2572
2573     return $new_ident;
2574 }
2575
2576 sub _default_column_accessor_name {
2577     my ( $self, $column_name ) = @_;
2578
2579     my $preserve = ($self->naming->{column_accessors}||'') eq 'preserve';
2580
2581     my $v = $self->_get_naming_v('column_accessors');
2582
2583     my $accessor_name = $preserve ?
2584         $self->_to_identifier('column_accessors', $column_name) # assume CamelCase
2585         :
2586         $self->_to_identifier('column_accessors', $column_name, '_');
2587
2588     $accessor_name =~ s/\W+/_/g; # only if naming < v8, otherwise to_identifier
2589                                  # takes care of it
2590
2591     if ($preserve) {
2592         return $accessor_name;
2593     }
2594     elsif ($v < 7 || (not $self->preserve_case)) {
2595         # older naming just lc'd the col accessor and that's all.
2596         return lc $accessor_name;
2597     }
2598
2599     return join '_', map lc, split_name $column_name, $v;
2600 }
2601
2602 sub _make_column_accessor_name {
2603     my ($self, $column_name, $column_context_info ) = @_;
2604
2605     my $accessor = $self->_run_user_map(
2606         $self->col_accessor_map,
2607         $self->curry::_default_column_accessor_name,
2608         $column_name,
2609         $column_context_info,
2610     );
2611
2612     return $accessor;
2613 }
2614
2615 sub _table_is_view {
2616     #my ($self, $table) = @_;
2617     return 0;
2618 }
2619
2620 sub _view_definition { undef }
2621
2622 # Set up metadata (cols, pks, etc)
2623 sub _setup_src_meta {
2624     my ($self, $table) = @_;
2625
2626     my $schema       = $self->schema;
2627     my $schema_class = $self->schema_class;
2628
2629     my $table_class   = $self->classes->{$table->sql_name};
2630     my $table_moniker = $self->monikers->{$table->sql_name};
2631
2632     # Must come before ->table
2633     $self->_dbic_stmt($table_class, 'table_class', 'DBIx::Class::ResultSource::View')
2634         if my $is_view = $self->_table_is_view($table);
2635
2636     $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
2637
2638     # Must come after ->table
2639     if ($is_view and my $view_def = $self->_view_definition($table)) {
2640         $self->_dbic_stmt($table_class, 'result_source_instance->view_definition', $view_def);
2641     }
2642
2643     my $cols     = $self->_table_columns($table);
2644     my $col_info = $self->__columns_info_for($table);
2645
2646     ### generate all the column accessor names
2647     while (my ($col, $info) = each %$col_info) {
2648         # hashref of other info that could be used by
2649         # user-defined accessor map functions
2650         my $context = {
2651             table_class     => $table_class,
2652             table_moniker   => $table_moniker,
2653             table_name      => $table, # bugwards compatibility, RT#84050
2654             table           => $table,
2655             full_table_name => $table->dbic_name,
2656             schema_class    => $schema_class,
2657             column_info     => $info,
2658         };
2659         my $col_obj = DBIx::Class::Schema::Loader::Column->new(
2660             table => $table,
2661             name  => $col,
2662         );
2663
2664         $info->{accessor} = $self->_make_column_accessor_name( $col_obj, $context );
2665     }
2666
2667     $self->_resolve_col_accessor_collisions($table, $col_info);
2668
2669     # prune any redundant accessor names
2670     while (my ($col, $info) = each %$col_info) {
2671         no warnings 'uninitialized';
2672         delete $info->{accessor} if $info->{accessor} eq $col;
2673     }
2674
2675     my $fks = $self->_table_fk_info($table);
2676
2677     foreach my $fkdef (@$fks) {
2678         for my $col (@{ $fkdef->{local_columns} }) {
2679             $col_info->{$col}{is_foreign_key} = 1;
2680         }
2681     }
2682
2683     my $pks = $self->_table_pk_info($table) || [];
2684
2685     my %uniq_tag; # used to eliminate duplicate uniqs
2686
2687     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2688
2689     my $uniqs = $self->_table_uniq_info($table) || [];
2690     my @uniqs;
2691
2692     foreach my $uniq (@$uniqs) {
2693         my ($name, $cols) = @$uniq;
2694         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2695         push @uniqs, [$name, $cols];
2696     }
2697
2698     my @non_nullable_uniqs = grep {
2699         all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2700     } @uniqs;
2701
2702     if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2703         my @by_colnum = sort { $b->[0] <=> $a->[0] }
2704             map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2705
2706         if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2707             my @keys = map $_->[1], @by_colnum;
2708
2709             my $pk = $keys[0];
2710
2711             # remove the uniq from list
2712             @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2713
2714             $pks = $pk->[1];
2715         }
2716     }
2717
2718     foreach my $pkcol (@$pks) {
2719         $col_info->{$pkcol}{is_nullable} = 0;
2720     }
2721
2722     $self->_dbic_stmt(
2723         $table_class,
2724         'add_columns',
2725         map { $_, ($col_info->{$_}||{}) } @$cols
2726     );
2727
2728     $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2729         if @$pks;
2730
2731     # Sort unique constraints by constraint name for repeatable results (rels
2732     # are sorted as well elsewhere.)
2733     @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs;
2734
2735     foreach my $uniq (@uniqs) {
2736         my ($name, $cols) = @$uniq;
2737         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2738     }
2739 }
2740
2741 sub __columns_info_for {
2742     my ($self, $table) = @_;
2743
2744     my $result = $self->_columns_info_for($table);
2745
2746     while (my ($col, $info) = each %$result) {
2747         $info = { %$info, %{ $self->_custom_column_info  ($table, $col, $info) } };
2748         $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2749
2750         $result->{$col} = $info;
2751     }
2752
2753     return $result;
2754 }
2755
2756 =head2 tables
2757
2758 Returns a sorted list of loaded tables, using the original database table
2759 names.
2760
2761 =cut
2762
2763 sub tables {
2764     my $self = shift;
2765
2766     return values %{$self->_tables};
2767 }
2768
2769 sub _get_naming_v {
2770     my ($self, $naming_key) = @_;
2771
2772     my $v;
2773
2774     if (($self->naming->{$naming_key}||'') =~ /^v(\d+)\z/) {
2775         $v = $1;
2776     }
2777     else {
2778         ($v) = $CURRENT_V =~ /^v(\d+)\z/;
2779     }
2780
2781     return $v;
2782 }
2783
2784 sub _to_identifier {
2785     my ($self, $naming_key, $name, $sep_char, $force) = @_;
2786
2787     my $v = $self->_get_naming_v($naming_key);
2788
2789     my $to_identifier = $self->naming->{force_ascii} ?
2790         \&String::ToIdentifier::EN::to_identifier
2791         : \&String::ToIdentifier::EN::Unicode::to_identifier;
2792
2793     return $v >= 8 || $force ? $to_identifier->($name, $sep_char) : $name;
2794 }
2795
2796 # Make a moniker from a table
2797 sub _default_table2moniker {
2798     my ($self, $table) = @_;
2799
2800     my $v = $self->_get_naming_v('monikers');
2801
2802     my @moniker_parts = @{ $self->moniker_parts };
2803     my @name_parts = map $table->$_, @moniker_parts;
2804
2805     my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
2806
2807     my @all_parts;
2808
2809     foreach my $i (0 .. $#name_parts) {
2810         my $part = $name_parts[$i];
2811
2812         my $moniker_part = $self->_run_user_map(
2813             $self->moniker_part_map->{$moniker_parts[$i]},
2814             sub { '' },
2815             $part, $moniker_parts[$i],
2816         );
2817         if (length $moniker_part) {
2818             push @all_parts, $moniker_part;
2819             next;
2820         }
2821
2822         if ($i != $name_idx || $v >= 8) {
2823             $part = $self->_to_identifier('monikers', $part, '_', 1);
2824         }
2825
2826         if ($i == $name_idx && $v == 5) {
2827             $part = Lingua::EN::Inflect::Number::to_S($part);
2828         }
2829
2830         my @part_parts = map lc, $v > 6 ?
2831             # use v8 semantics for all moniker parts except name
2832             ($i == $name_idx ? split_name $part, $v : split_name $part)
2833             : split /[\W_]+/, $part;
2834
2835         if ($i == $name_idx && $v >= 6) {
2836             my $as_phrase = join ' ', @part_parts;
2837
2838             my $inflected = ($self->naming->{monikers}||'') eq 'plural' ?
2839                 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2840                 :
2841                 ($self->naming->{monikers}||'') eq 'preserve' ?
2842                     $as_phrase
2843                     :
2844                     Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2845
2846             @part_parts = split /\s+/, $inflected;
2847         }
2848
2849         push @all_parts, join '', map ucfirst, @part_parts;
2850     }
2851
2852     return join $self->moniker_part_separator, @all_parts;
2853 }
2854
2855 sub _table2moniker {
2856     my ( $self, $table ) = @_;
2857
2858     $self->_run_user_map(
2859         $self->moniker_map,
2860         $self->curry::_default_table2moniker,
2861         $table
2862     );
2863 }
2864
2865 sub _load_relationships {
2866     my ($self, $tables) = @_;
2867
2868     my @tables;
2869
2870     foreach my $table (@$tables) {
2871         my $local_moniker = $self->monikers->{$table->sql_name};
2872
2873         my $tbl_fk_info = $self->_table_fk_info($table);
2874
2875         foreach my $fkdef (@$tbl_fk_info) {
2876             $fkdef->{local_table}   = $table;
2877             $fkdef->{local_moniker} = $local_moniker;
2878             $fkdef->{remote_source} =
2879                 $self->monikers->{$fkdef->{remote_table}->sql_name};
2880         }
2881         my $tbl_uniq_info = $self->_table_uniq_info($table);
2882
2883         push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2884     }
2885
2886     my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2887
2888     foreach my $src_class (sort keys %$rel_stmts) {
2889         # sort by rel name
2890         my @src_stmts = map $_->[2],
2891             sort {
2892                 $a->[0] <=> $b->[0]
2893                 ||
2894                 $a->[1] cmp $b->[1]
2895             } map [
2896                 ($_->{method} eq 'many_to_many' ? 1 : 0),
2897                 $_->{args}[0],
2898                 $_,
2899             ], @{ $rel_stmts->{$src_class} };
2900
2901         foreach my $stmt (@src_stmts) {
2902             $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2903         }
2904     }
2905 }
2906
2907 sub _load_roles {
2908     my ($self, $table) = @_;
2909
2910     my $table_moniker = $self->monikers->{$table->sql_name};
2911     my $table_class   = $self->classes->{$table->sql_name};
2912
2913     my @roles = @{ $self->result_roles || [] };
2914     push @roles, @{ $self->result_roles_map->{$table_moniker} }
2915         if exists $self->result_roles_map->{$table_moniker};
2916
2917     if (@roles) {
2918         $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2919
2920         $self->_with($table_class, @roles);
2921     }
2922 }
2923
2924 # Overload these in driver class:
2925
2926 # Returns an arrayref of column names
2927 sub _table_columns { croak "ABSTRACT METHOD" }
2928
2929 # Returns arrayref of pk col names
2930 sub _table_pk_info { croak "ABSTRACT METHOD" }
2931
2932 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2933 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2934
2935 # Returns an arrayref of foreign key constraints, each
2936 #   being a hashref with 3 keys:
2937 #   local_columns (arrayref), remote_columns (arrayref), remote_table
2938 sub _table_fk_info { croak "ABSTRACT METHOD" }
2939
2940 # Returns an array of lower case table names
2941 sub _tables_list { croak "ABSTRACT METHOD" }
2942
2943 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2944 sub _dbic_stmt {
2945     my $self   = shift;
2946     my $class  = shift;
2947     my $method = shift;
2948
2949     # generate the pod for this statement, storing it with $self->_pod
2950     $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2951
2952     my $args = dump(@_);
2953     $args = '(' . $args . ')' if @_ < 2;
2954     my $stmt = $method . $args . q{;};
2955
2956     warn qq|$class\->$stmt\n| if $self->debug;
2957     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2958     return;
2959 }
2960
2961 sub _make_pod_heading {
2962     my ($self, $class) = @_;
2963
2964     return '' if not $self->generate_pod;
2965
2966     my $table = $self->class_to_table->{$class};
2967     my $pod;
2968
2969     my $pcm = $self->pod_comment_mode;
2970     my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2971     $comment = $self->__table_comment($table);
2972     $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2973     $comment_in_name   = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2974     $comment_in_desc   = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2975
2976     $pod .= "=head1 NAME\n\n";
2977
2978     my $table_descr = $class;
2979     $table_descr .= " - " . $comment if $comment and $comment_in_name;
2980
2981     $pod .= "$table_descr\n\n";
2982
2983     if ($comment and $comment_in_desc) {
2984         $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2985     }
2986     $pod .= "=cut\n\n";
2987
2988     return $pod;
2989 }
2990
2991 # generates the accompanying pod for a DBIC class method statement,
2992 # storing it with $self->_pod
2993 sub _make_pod {
2994     my $self   = shift;
2995     my $class  = shift;
2996     my $method = shift;
2997
2998     if ($method eq 'table') {
2999         my $table = $_[0];
3000         $table = $$table if ref $table eq 'SCALAR';
3001         $self->_pod($class, "=head1 TABLE: C<$table>");
3002         $self->_pod_cut($class);
3003     }
3004     elsif ( $method eq 'add_columns' ) {
3005         $self->_pod( $class, "=head1 ACCESSORS" );
3006         my $col_counter = 0;
3007         my @cols = @_;
3008         while( my ($name,$attrs) = splice @cols,0,2 ) {
3009             $col_counter++;
3010             $self->_pod( $class, '=head2 ' . $name  );
3011             $self->_pod( $class,
3012                 join "\n", map {
3013                     my $s = $attrs->{$_};
3014                     $s = !defined $s          ? 'undef'             :
3015                         length($s) == 0       ? '(empty string)'    :
3016                         ref($s) eq 'SCALAR'   ? $$s                 :
3017                         ref($s)               ? dumper_squashed $s  :
3018                         looks_like_number($s) ? $s                  : qq{'$s'};
3019
3020                     "  $_: $s"
3021                 } sort keys %$attrs,
3022             );
3023             if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
3024                 $self->_pod( $class, $comment );
3025             }
3026         }
3027         $self->_pod_cut( $class );
3028     } elsif ( $method =~ /^(?:belongs_to|has_many|might_have)\z/ ) {
3029         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
3030         my ( $accessor, $rel_class ) = @_;
3031         $self->_pod( $class, "=head2 $accessor" );
3032         $self->_pod( $class, 'Type: ' . $method );
3033         $self->_pod( $class, "Related object: L<$rel_class>" );
3034         $self->_pod_cut( $class );
3035         $self->{_relations_started} { $class } = 1;
3036     } elsif ( $method eq 'many_to_many' ) {
3037         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
3038         my ( $accessor, $rel1, $rel2 ) = @_;
3039         $self->_pod( $class, "=head2 $accessor" );
3040         $self->_pod( $class, 'Type: many_to_many' );
3041         $self->_pod( $class, "Composing rels: L</$rel1> -> $rel2" );
3042         $self->_pod_cut( $class );
3043         $self->{_relations_started} { $class } = 1;
3044     }
3045     elsif ($method eq 'add_unique_constraint') {
3046         $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
3047             unless $self->{_uniqs_started}{$class};
3048
3049         my ($name, $cols) = @_;
3050
3051         $self->_pod($class, "=head2 C<$name>");
3052         $self->_pod($class, '=over 4');
3053
3054         foreach my $col (@$cols) {
3055             $self->_pod($class, "=item \* L</$col>");
3056         }
3057
3058         $self->_pod($class, '=back');
3059         $self->_pod_cut($class);
3060
3061         $self->{_uniqs_started}{$class} = 1;
3062     }
3063     elsif ($method eq 'set_primary_key') {
3064         $self->_pod($class, "=head1 PRIMARY KEY");
3065         $self->_pod($class, '=over 4');
3066
3067         foreach my $col (@_) {
3068             $self->_pod($class, "=item \* L</$col>");
3069         }
3070
3071         $self->_pod($class, '=back');
3072         $self->_pod_cut($class);
3073     }
3074 }
3075
3076 sub _pod_class_list {
3077     my ($self, $class, $title, @classes) = @_;
3078
3079     return unless @classes && $self->generate_pod;
3080
3081     $self->_pod($class, "=head1 $title");
3082     $self->_pod($class, '=over 4');
3083
3084     foreach my $link (@classes) {
3085         $self->_pod($class, "=item * L<$link>");
3086     }
3087
3088     $self->_pod($class, '=back');
3089     $self->_pod_cut($class);
3090 }
3091
3092 sub _base_class_pod {
3093     my ($self, $base_class) = @_;
3094
3095     return '' unless $self->generate_pod;
3096
3097     return "\n=head1 BASE CLASS: L<$base_class>\n\n=cut\n\n";
3098 }
3099
3100 sub _filter_comment {
3101     my ($self, $txt) = @_;
3102
3103     $txt = '' if not defined $txt;
3104
3105     $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
3106
3107     return $txt;
3108 }
3109
3110 sub __table_comment {
3111     my $self = shift;
3112
3113     if (my $code = $self->can('_table_comment')) {
3114         return $self->_filter_comment($self->$code(@_));
3115     }
3116
3117     return '';
3118 }
3119
3120 sub __column_comment {
3121     my $self = shift;
3122
3123     if (my $code = $self->can('_column_comment')) {
3124         return $self->_filter_comment($self->$code(@_));
3125     }
3126
3127     return '';
3128 }
3129
3130 # Stores a POD documentation
3131 sub _pod {
3132     my ($self, $class, $stmt) = @_;
3133     $self->_raw_stmt( $class, "\n" . $stmt  );
3134 }
3135
3136 sub _pod_cut {
3137     my ($self, $class ) = @_;
3138     $self->_raw_stmt( $class, "\n=cut\n" );
3139 }
3140
3141 # Store a raw source line for a class (for dumping purposes)
3142 sub _raw_stmt {
3143     my ($self, $class, $stmt) = @_;
3144     push(@{$self->{_dump_storage}->{$class}}, $stmt);
3145 }
3146
3147 # Like above, but separately for the externally loaded stuff
3148 sub _ext_stmt {
3149     my ($self, $class, $stmt) = @_;
3150     push(@{$self->{_ext_storage}->{$class}}, $stmt);
3151 }
3152
3153 sub _custom_column_info {
3154     my ( $self, $table_name, $column_name, $column_info ) = @_;
3155
3156     if (my $code = $self->custom_column_info) {
3157         return $code->($table_name, $column_name, $column_info) || {};
3158     }
3159     return {};
3160 }
3161
3162 sub _datetime_column_info {
3163     my ( $self, $table_name, $column_name, $column_info ) = @_;
3164     my $result = {};
3165     my $type = $column_info->{data_type} || '';
3166     if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
3167             or ($type =~ /date|timestamp/i)) {
3168         $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
3169         $result->{locale}   = $self->datetime_locale   if $self->datetime_locale;
3170     }
3171     return $result;
3172 }
3173
3174 sub _lc {
3175     my ($self, $name) = @_;
3176
3177     return $self->preserve_case ? $name : lc($name);
3178 }
3179
3180 sub _uc {
3181     my ($self, $name) = @_;
3182
3183     return $self->preserve_case ? $name : uc($name);
3184 }
3185
3186 sub _remove_table {
3187     my ($self, $table) = @_;
3188
3189     try {
3190         my $schema = $self->schema;
3191         # in older DBIC it's a private method
3192         my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
3193         $schema->$unregister(delete $self->monikers->{$table->sql_name});
3194         delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}};
3195         delete $self->_tables->{$table->sql_name};
3196     };
3197 }
3198
3199 # remove the dump dir from @INC on destruction
3200 sub DESTROY {
3201     my $self = shift;
3202
3203     @INC = grep $_ ne $self->dump_directory, @INC;
3204 }
3205
3206 =head2 monikers
3207
3208 Returns a hashref of loaded table to moniker mappings.  There will
3209 be two entries for each table, the original name and the "normalized"
3210 name, in the case that the two are different (such as databases
3211 that like uppercase table names, or preserve your original mixed-case
3212 definitions, or what-have-you).
3213
3214 =head2 classes
3215
3216 Returns a hashref of table to class mappings.  In some cases it will
3217 contain multiple entries per table for the original and normalized table
3218 names, as above in L</monikers>.
3219
3220 =head2 generated_classes
3221
3222 Returns an arrayref of classes that were actually generated (i.e. not
3223 skipped because there were no changes).
3224
3225 =head1 NON-ENGLISH DATABASES
3226
3227 If you use the loader on a database with table and column names in a language
3228 other than English, you will want to turn off the English language specific
3229 heuristics.
3230
3231 To do so, use something like this in your loader options:
3232
3233     naming           => { monikers => 'v4' },
3234     inflect_singular => sub { "$_[0]_rel" },
3235     inflect_plural   => sub { "$_[0]_rel" },
3236
3237 =head1 COLUMN ACCESSOR COLLISIONS
3238
3239 Occasionally you may have a column name that collides with a perl method, such
3240 as C<can>. In such cases, the default action is to set the C<accessor> of the
3241 column spec to C<undef>.
3242
3243 You can then name the accessor yourself by placing code such as the following
3244 below the md5:
3245
3246     __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
3247
3248 Another option is to use the L</col_collision_map> option.
3249
3250 =head1 RELATIONSHIP NAME COLLISIONS
3251
3252 In very rare cases, you may get a collision between a generated relationship
3253 name and a method in your Result class, for example if you have a foreign key
3254 called C<belongs_to>.
3255
3256 This is a problem because relationship names are also relationship accessor
3257 methods in L<DBIx::Class>.
3258
3259 The default behavior is to append C<_rel> to the relationship name and print
3260 out a warning that refers to this text.
3261
3262 You can also control the renaming with the L</rel_collision_map> option.
3263
3264 =head1 SEE ALSO
3265
3266 L<DBIx::Class::Schema::Loader>, L<dbicdump>
3267
3268 =head1 AUTHORS
3269
3270 See L<DBIx::Class::Schema::Loader/AUTHORS>.
3271
3272 =head1 LICENSE
3273
3274 This library is free software; you can redistribute it and/or modify it under
3275 the same terms as Perl itself.
3276
3277 =cut
3278
3279 1;
3280 # vim:et sts=4 sw=4 tw=0: