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