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