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