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