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