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