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