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|use utf8;\n|
1598         . qq|package $schema_class;\n\n|
1599         . qq|# Created by DBIx::Class::Schema::Loader\n|
1600         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1601
1602     if ($self->use_moose) {
1603         $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1604     }
1605     else {
1606         $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1607     }
1608
1609     my @schema_components = @{ $self->schema_components || [] };
1610
1611     if (@schema_components) {
1612         my $schema_components = dump @schema_components;
1613         $schema_components = "($schema_components)" if @schema_components == 1;
1614
1615         $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1616     }
1617
1618     if ($self->use_namespaces) {
1619         $schema_text .= qq|__PACKAGE__->load_namespaces|;
1620         my $namespace_options;
1621
1622         my @attr = qw/resultset_namespace default_resultset_class/;
1623
1624         unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1625
1626         for my $attr (@attr) {
1627             if ($self->$attr) {
1628                 my $code = dumper_squashed $self->$attr;
1629                 $namespace_options .= qq|    $attr => $code,\n|
1630             }
1631         }
1632         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1633         $schema_text .= qq|;\n|;
1634     }
1635     else {
1636         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1637     }
1638
1639     {
1640         local $self->{version_to_dump} = $self->schema_version_to_dump;
1641         $self->_write_classfile($schema_class, $schema_text, 1);
1642     }
1643
1644     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1645
1646     foreach my $src_class (@classes) {
1647         my $src_text =
1648               qq|use utf8;\n|
1649             . qq|package $src_class;\n\n|
1650             . qq|# Created by DBIx::Class::Schema::Loader\n|
1651             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1652
1653         $src_text .= $self->_make_pod_heading($src_class);
1654
1655         $src_text .= qq|use strict;\nuse warnings;\n\n|;
1656
1657         $src_text .= $self->_base_class_pod($result_base_class)
1658             unless $result_base_class eq 'DBIx::Class::Core';
1659
1660         if ($self->use_moose) {
1661             $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1662
1663             # these options 'use base' which is compile time
1664             if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1665                 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1666             }
1667             else {
1668                 $src_text .= qq|\nextends '$result_base_class';\n|;
1669             }
1670         }
1671         else {
1672              $src_text .= qq|use base '$result_base_class';\n|;
1673         }
1674
1675         $self->_write_classfile($src_class, $src_text);
1676     }
1677
1678     # remove Result dir if downgrading from use_namespaces, and there are no
1679     # files left.
1680     if (my $result_ns = $self->_downgrading_to_load_classes
1681                         || $self->_rewriting_result_namespace) {
1682         my $result_namespace = $self->_result_namespace(
1683             $schema_class,
1684             $result_ns,
1685         );
1686
1687         (my $result_dir = $result_namespace) =~ s{::}{/}g;
1688         $result_dir = $self->dump_directory . '/' . $result_dir;
1689
1690         unless (my @files = glob "$result_dir/*") {
1691             rmdir $result_dir;
1692         }
1693     }
1694
1695     warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
1696 }
1697
1698 sub _sig_comment {
1699     my ($self, $version, $ts) = @_;
1700     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1701          . qq| v| . $version
1702          . q| @ | . $ts
1703          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1704 }
1705
1706 sub _write_classfile {
1707     my ($self, $class, $text, $is_schema) = @_;
1708
1709     my $filename = $self->_get_dump_filename($class);
1710     $self->_ensure_dump_subdirs($class);
1711
1712     if (-f $filename && $self->really_erase_my_files) {
1713         warn "Deleting existing file '$filename' due to "
1714             . "'really_erase_my_files' setting\n" unless $self->quiet;
1715         unlink($filename);
1716     }
1717
1718     my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1719         = $self->_parse_generated_file($filename);
1720
1721     if (! $old_gen && -f $filename) {
1722         croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1723             . " it does not appear to have been generated by Loader"
1724     }
1725
1726     my $custom_content = $old_custom || '';
1727
1728     # prepend extra custom content from a *renamed* class (singularization effect)
1729     if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1730         my $old_filename = $self->_get_dump_filename($renamed_class);
1731
1732         if (-f $old_filename) {
1733             my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1734
1735             $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1736
1737             $custom_content = join ("\n", '', $extra_custom, $custom_content)
1738                 if $extra_custom;
1739
1740             unlink $old_filename;
1741         }
1742     }
1743
1744     $custom_content ||= $self->_default_custom_content($is_schema);
1745
1746     # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1747     # If there is already custom content, which does not have the Moose content, add it.
1748     if ($self->use_moose) {
1749
1750         my $non_moose_custom_content = do {
1751             local $self->{use_moose} = 0;
1752             $self->_default_custom_content;
1753         };
1754
1755         if ($custom_content eq $non_moose_custom_content) {
1756             $custom_content = $self->_default_custom_content($is_schema);
1757         }
1758         elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1759             $custom_content .= $self->_default_custom_content($is_schema);
1760         }
1761     }
1762     elsif (defined $self->use_moose && $old_gen) {
1763         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'
1764             if $old_gen =~ /use \s+ MooseX?\b/x;
1765     }
1766
1767     $custom_content = $self->_rewrite_old_classnames($custom_content);
1768
1769     $text .= qq|$_\n|
1770         for @{$self->{_dump_storage}->{$class} || []};
1771
1772     if ($self->filter_generated_code) {
1773         my $filter = $self->filter_generated_code;
1774
1775         if (ref $filter eq 'CODE') {
1776             $text = $filter->(
1777                 ($is_schema ? 'schema' : 'result'),
1778                 $class,
1779                 $text
1780             );
1781         }
1782         else {
1783             my ($out, $in) = (gensym, gensym);
1784
1785             my $pid = open2($out, $in, $filter)
1786                 or croak "Could not open pipe to $filter: $!";
1787
1788             print $in $text;
1789
1790             close $in;
1791
1792             $text = decode('UTF-8', do { local $/; <$out> });
1793
1794             $text =~ s/$CR?$LF/\n/g;
1795
1796             waitpid $pid, 0;
1797
1798             my $exit_code = $? >> 8;
1799
1800             if ($exit_code != 0) {
1801                 croak "filter '$filter' exited non-zero: $exit_code";
1802             }
1803         }
1804         if (not $text or not $text =~ /\bpackage\b/) {
1805             warn("$class skipped due to filter") if $self->debug;
1806             return;
1807         }
1808     }
1809
1810     # Check and see if the dump is in fact different
1811
1812     my $compare_to;
1813     if ($old_md5) {
1814       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1815       if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1816         return unless $self->_upgrading_from && $is_schema;
1817       }
1818     }
1819
1820     $text .= $self->_sig_comment(
1821       $self->version_to_dump,
1822       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1823     );
1824
1825     open(my $fh, '>:encoding(UTF-8)', $filename)
1826         or croak "Cannot open '$filename' for writing: $!";
1827
1828     # Write the top half and its MD5 sum
1829     print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1830
1831     # Write out anything loaded via external partial class file in @INC
1832     print $fh qq|$_\n|
1833         for @{$self->{_ext_storage}->{$class} || []};
1834
1835     # Write out any custom content the user has added
1836     print $fh $custom_content;
1837
1838     close($fh)
1839         or croak "Error closing '$filename': $!";
1840 }
1841
1842 sub _default_moose_custom_content {
1843     my ($self, $is_schema) = @_;
1844
1845     if (not $is_schema) {
1846         return qq|\n__PACKAGE__->meta->make_immutable;|;
1847     }
1848
1849     return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1850 }
1851
1852 sub _default_custom_content {
1853     my ($self, $is_schema) = @_;
1854     my $default = qq|\n\n# You can replace this text with custom|
1855          . qq| code or comments, and it will be preserved on regeneration|;
1856     if ($self->use_moose) {
1857         $default .= $self->_default_moose_custom_content($is_schema);
1858     }
1859     $default .= qq|\n1;\n|;
1860     return $default;
1861 }
1862
1863 sub _parse_generated_file {
1864     my ($self, $fn) = @_;
1865
1866     return unless -f $fn;
1867
1868     open(my $fh, '<:encoding(UTF-8)', $fn)
1869         or croak "Cannot open '$fn' for reading: $!";
1870
1871     my $mark_re =
1872         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
1873
1874     my ($md5, $ts, $ver, $gen);
1875     while(<$fh>) {
1876         if(/$mark_re/) {
1877             my $pre_md5 = $1;
1878             $md5 = $2;
1879
1880             # Pull out the version and timestamp from the line above
1881             ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m;
1882
1883             $gen .= $pre_md5;
1884             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"
1885                 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
1886
1887             last;
1888         }
1889         else {
1890             $gen .= $_;
1891         }
1892     }
1893
1894     my $custom = do { local $/; <$fh> }
1895         if $md5;
1896
1897     $custom ||= '';
1898     $custom =~ s/$CRLF|$LF/\n/g;
1899
1900     close $fh;
1901
1902     return ($gen, $md5, $ver, $ts, $custom);
1903 }
1904
1905 sub _use {
1906     my $self = shift;
1907     my $target = shift;
1908
1909     foreach (@_) {
1910         warn "$target: use $_;" if $self->debug;
1911         $self->_raw_stmt($target, "use $_;");
1912     }
1913 }
1914
1915 sub _inject {
1916     my $self = shift;
1917     my $target = shift;
1918
1919     my $blist = join(q{ }, @_);
1920
1921     return unless $blist;
1922
1923     warn "$target: use base qw/$blist/;" if $self->debug;
1924     $self->_raw_stmt($target, "use base qw/$blist/;");
1925 }
1926
1927 sub _with {
1928     my $self = shift;
1929     my $target = shift;
1930
1931     my $rlist = join(q{, }, map { qq{'$_'} } @_);
1932
1933     return unless $rlist;
1934
1935     warn "$target: with $rlist;" if $self->debug;
1936     $self->_raw_stmt($target, "\nwith $rlist;");
1937 }
1938
1939 sub _result_namespace {
1940     my ($self, $schema_class, $ns) = @_;
1941     my @result_namespace;
1942
1943     $ns = $ns->[0] if ref $ns;
1944
1945     if ($ns =~ /^\+(.*)/) {
1946         # Fully qualified namespace
1947         @result_namespace = ($1)
1948     }
1949     else {
1950         # Relative namespace
1951         @result_namespace = ($schema_class, $ns);
1952     }
1953
1954     return wantarray ? @result_namespace : join '::', @result_namespace;
1955 }
1956
1957 # Create class with applicable bases, setup monikers, etc
1958 sub _make_src_class {
1959     my ($self, $table) = @_;
1960
1961     my $schema       = $self->schema;
1962     my $schema_class = $self->schema_class;
1963
1964     my $table_moniker = $self->_table2moniker($table);
1965     my @result_namespace = ($schema_class);
1966     if ($self->use_namespaces) {
1967         my $result_namespace = $self->result_namespace || 'Result';
1968         @result_namespace = $self->_result_namespace(
1969             $schema_class,
1970             $result_namespace,
1971         );
1972     }
1973     my $table_class = join(q{::}, @result_namespace, $table_moniker);
1974
1975     if ((my $upgrading_v = $self->_upgrading_from)
1976             || $self->_rewriting) {
1977         local $self->naming->{monikers} = $upgrading_v
1978             if $upgrading_v;
1979
1980         my @result_namespace = @result_namespace;
1981         if ($self->_upgrading_from_load_classes) {
1982             @result_namespace = ($schema_class);
1983         }
1984         elsif (my $ns = $self->_downgrading_to_load_classes) {
1985             @result_namespace = $self->_result_namespace(
1986                 $schema_class,
1987                 $ns,
1988             );
1989         }
1990         elsif ($ns = $self->_rewriting_result_namespace) {
1991             @result_namespace = $self->_result_namespace(
1992                 $schema_class,
1993                 $ns,
1994             );
1995         }
1996
1997         my $old_table_moniker = do {
1998             local $self->naming->{monikers} = $upgrading_v;
1999             $self->_table2moniker($table);
2000         };
2001
2002         my $old_class = join(q{::}, @result_namespace, $old_table_moniker);
2003
2004         $self->_upgrading_classes->{$table_class} = $old_class
2005             unless $table_class eq $old_class;
2006     }
2007
2008     $self->classes->{$table->sql_name}  = $table_class;
2009     $self->monikers->{$table->sql_name} = $table_moniker;
2010     $self->moniker_to_table->{$table_moniker} = $table;
2011     $self->class_to_table->{$table_class} = $table;
2012
2013     $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
2014
2015     $self->_use   ($table_class, @{$self->additional_classes});
2016
2017     $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
2018
2019     $self->_inject($table_class, @{$self->left_base_classes});
2020
2021     my @components = @{ $self->components || [] };
2022
2023     push @components, @{ $self->result_components_map->{$table_moniker} }
2024         if exists $self->result_components_map->{$table_moniker};
2025
2026     my @fq_components = @components;
2027     foreach my $component (@fq_components) {
2028         if ($component !~ s/^\+//) {
2029             $component = "DBIx::Class::$component";
2030         }
2031     }
2032
2033     $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
2034
2035     $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
2036
2037     $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
2038
2039     $self->_inject($table_class, @{$self->additional_base_classes});
2040 }
2041
2042 sub _is_result_class_method {
2043     my ($self, $name, $table) = @_;
2044
2045     my $table_moniker = $table ? $self->monikers->{$table->sql_name} : '';
2046
2047     $self->_result_class_methods({})
2048         if not defined $self->_result_class_methods;
2049
2050     if (not exists $self->_result_class_methods->{$table_moniker}) {
2051         my (@methods, %methods);
2052         my $base       = $self->result_base_class || 'DBIx::Class::Core';
2053
2054         my @components = @{ $self->components || [] };
2055
2056         push @components, @{ $self->result_components_map->{$table_moniker} }
2057             if exists $self->result_components_map->{$table_moniker};
2058
2059         for my $c (@components) {
2060             $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
2061         }
2062
2063         my @roles = @{ $self->result_roles || [] };
2064
2065         push @roles, @{ $self->result_roles_map->{$table_moniker} }
2066             if exists $self->result_roles_map->{$table_moniker};
2067
2068         for my $class ($base, @components,
2069                        ($self->use_moose ? 'Moose::Object' : ()), @roles) {
2070             $self->ensure_class_loaded($class);
2071
2072             push @methods, @{ Class::Inspector->methods($class) || [] };
2073         }
2074
2075         push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
2076
2077         @methods{@methods} = ();
2078
2079         $self->_result_class_methods->{$table_moniker} = \%methods;
2080     }
2081     my $result_methods = $self->_result_class_methods->{$table_moniker};
2082
2083     return exists $result_methods->{$name};
2084 }
2085
2086 sub _resolve_col_accessor_collisions {
2087     my ($self, $table, $col_info) = @_;
2088
2089     while (my ($col, $info) = each %$col_info) {
2090         my $accessor = $info->{accessor} || $col;
2091
2092         next if $accessor eq 'id'; # special case (very common column)
2093
2094         if ($self->_is_result_class_method($accessor, $table)) {
2095             my $mapped = 0;
2096
2097             if (my $map = $self->col_collision_map) {
2098                 for my $re (keys %$map) {
2099                     if (my @matches = $col =~ /$re/) {
2100                         $info->{accessor} = sprintf $map->{$re}, @matches;
2101                         $mapped = 1;
2102                     }
2103                 }
2104             }
2105
2106             if (not $mapped) {
2107                 warn <<"EOF";
2108 Column '$col' in table '$table' collides with an inherited method.
2109 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
2110 EOF
2111                 $info->{accessor} = undef;
2112             }
2113         }
2114     }
2115 }
2116
2117 # use the same logic to run moniker_map, col_accessor_map
2118 sub _run_user_map {
2119     my ( $self, $map, $default_code, $ident, @extra ) = @_;
2120
2121     my $default_ident = $default_code->( $ident, @extra );
2122     my $new_ident;
2123     if( $map && ref $map eq 'HASH' ) {
2124         $new_ident = $map->{ $ident };
2125     }
2126     elsif( $map && ref $map eq 'CODE' ) {
2127         $new_ident = $map->( $ident, $default_ident, @extra );
2128     }
2129
2130     $new_ident ||= $default_ident;
2131
2132     return $new_ident;
2133 }
2134
2135 sub _default_column_accessor_name {
2136     my ( $self, $column_name ) = @_;
2137
2138     my $accessor_name = $column_name;
2139     $accessor_name =~ s/\W+/_/g;
2140
2141     if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
2142         # older naming just lc'd the col accessor and that's all.
2143         return lc $accessor_name;
2144     }
2145     elsif (($self->naming->{column_accessors}||'') eq 'preserve') {
2146         return $accessor_name;
2147     }
2148
2149     return join '_', map lc, split_name $column_name;
2150 }
2151
2152 sub _make_column_accessor_name {
2153     my ($self, $column_name, $column_context_info ) = @_;
2154
2155     my $accessor = $self->_run_user_map(
2156         $self->col_accessor_map,
2157         sub { $self->_default_column_accessor_name( shift ) },
2158         $column_name,
2159         $column_context_info,
2160        );
2161
2162     return $accessor;
2163 }
2164
2165 # Set up metadata (cols, pks, etc)
2166 sub _setup_src_meta {
2167     my ($self, $table) = @_;
2168
2169     my $schema       = $self->schema;
2170     my $schema_class = $self->schema_class;
2171
2172     my $table_class   = $self->classes->{$table->sql_name};
2173     my $table_moniker = $self->monikers->{$table->sql_name};
2174
2175     $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
2176
2177     my $cols     = $self->_table_columns($table);
2178     my $col_info = $self->__columns_info_for($table);
2179
2180     ### generate all the column accessor names
2181     while (my ($col, $info) = each %$col_info) {
2182         # hashref of other info that could be used by
2183         # user-defined accessor map functions
2184         my $context = {
2185             table_class     => $table_class,
2186             table_moniker   => $table_moniker,
2187             table_name      => $table,
2188             full_table_name => $table->dbic_name,
2189             schema_class    => $schema_class,
2190             column_info     => $info,
2191         };
2192
2193         $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2194     }
2195
2196     $self->_resolve_col_accessor_collisions($table, $col_info);
2197
2198     # prune any redundant accessor names
2199     while (my ($col, $info) = each %$col_info) {
2200         no warnings 'uninitialized';
2201         delete $info->{accessor} if $info->{accessor} eq $col;
2202     }
2203
2204     my $fks = $self->_table_fk_info($table);
2205
2206     foreach my $fkdef (@$fks) {
2207         for my $col (@{ $fkdef->{local_columns} }) {
2208             $col_info->{$col}{is_foreign_key} = 1;
2209         }
2210     }
2211
2212     my $pks = $self->_table_pk_info($table) || [];
2213
2214     my %uniq_tag; # used to eliminate duplicate uniqs
2215
2216     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2217
2218     my $uniqs = $self->_table_uniq_info($table) || [];
2219     my @uniqs;
2220
2221     foreach my $uniq (@$uniqs) {
2222         my ($name, $cols) = @$uniq;
2223         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2224         push @uniqs, [$name, $cols];
2225     }
2226
2227     my @non_nullable_uniqs = grep {
2228         all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2229     } @uniqs;
2230
2231     if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2232         my @by_colnum = sort { $b->[0] <=> $a->[0] }
2233             map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2234
2235         if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2236             my @keys = map $_->[1], @by_colnum;
2237
2238             my $pk = $keys[0];
2239
2240             # remove the uniq from list
2241             @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2242
2243             $pks = $pk->[1];
2244         }
2245     }
2246
2247     foreach my $pkcol (@$pks) {
2248         $col_info->{$pkcol}{is_nullable} = 0;
2249     }
2250
2251     $self->_dbic_stmt(
2252         $table_class,
2253         'add_columns',
2254         map { $_, ($col_info->{$_}||{}) } @$cols
2255     );
2256
2257     $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2258         if @$pks;
2259
2260     # Sort unique constraints by constraint name for repeatable results (rels
2261     # are sorted as well elsewhere.)
2262     @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs;
2263
2264     foreach my $uniq (@uniqs) {
2265         my ($name, $cols) = @$uniq;
2266         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2267     }
2268 }
2269
2270 sub __columns_info_for {
2271     my ($self, $table) = @_;
2272
2273     my $result = $self->_columns_info_for($table);
2274
2275     while (my ($col, $info) = each %$result) {
2276         $info = { %$info, %{ $self->_custom_column_info  ($table, $col, $info) } };
2277         $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2278
2279         $result->{$col} = $info;
2280     }
2281
2282     return $result;
2283 }
2284
2285 =head2 tables
2286
2287 Returns a sorted list of loaded tables, using the original database table
2288 names.
2289
2290 =cut
2291
2292 sub tables {
2293     my $self = shift;
2294
2295     return values %{$self->_tables};
2296 }
2297
2298 # Make a moniker from a table
2299 sub _default_table2moniker {
2300     no warnings 'uninitialized';
2301     my ($self, $table) = @_;
2302
2303     my @name_parts = map $table->$_, @{ $self->moniker_parts };
2304
2305     my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
2306
2307     if ($self->naming->{monikers} eq 'v4') {
2308         return join '', map ucfirst, map split(/[\W_]+/, lc $_), @name_parts;
2309     }
2310     elsif ($self->naming->{monikers} eq 'v5') {
2311         my @parts = map lc, @name_parts;
2312         $parts[$name_idx] = Lingua::EN::Inflect::Number::to_S($parts[$name_idx]);
2313
2314         return join '', map ucfirst, map split(/[\W_]+/, $_), @parts;
2315     }
2316     elsif ($self->naming->{monikers} eq 'v6') {
2317         (my $as_phrase = join '', map lc, @name_parts) =~ s/_+/ /g;
2318         my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2319
2320         return join '', map ucfirst, split /\W+/, $inflected;
2321     }
2322
2323     my @words = map lc, map split_name $_, @name_parts;
2324     my $as_phrase = join ' ', @words;
2325
2326     my $inflected = $self->naming->{monikers} eq 'plural' ?
2327         Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2328         :
2329         $self->naming->{monikers} eq 'preserve' ?
2330             $as_phrase
2331             :
2332             Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2333
2334     return join '', map ucfirst, split /\W+/, $inflected;
2335 }
2336
2337 sub _table2moniker {
2338     my ( $self, $table ) = @_;
2339
2340     $self->_run_user_map(
2341         $self->moniker_map,
2342         sub { $self->_default_table2moniker( shift ) },
2343         $table
2344        );
2345 }
2346
2347 sub _load_relationships {
2348     my ($self, $tables) = @_;
2349
2350     my @tables;
2351
2352     foreach my $table (@$tables) {
2353         my $local_moniker = $self->monikers->{$table->sql_name};
2354
2355         my $tbl_fk_info = $self->_table_fk_info($table);
2356
2357         foreach my $fkdef (@$tbl_fk_info) {
2358             $fkdef->{local_table}   = $table;
2359             $fkdef->{local_moniker} = $local_moniker;
2360             $fkdef->{remote_source} =
2361                 $self->monikers->{$fkdef->{remote_table}->sql_name};
2362         }
2363         my $tbl_uniq_info = $self->_table_uniq_info($table);
2364
2365         push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2366     }
2367
2368     my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2369
2370     foreach my $src_class (sort keys %$rel_stmts) {
2371         # sort by rel name
2372         my @src_stmts = map $_->[1],
2373             sort { $a->[0] cmp $b->[0] }
2374             map [ $_->{args}[0], $_ ], @{ $rel_stmts->{$src_class} };
2375
2376         foreach my $stmt (@src_stmts) {
2377             $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2378         }
2379     }
2380 }
2381
2382 sub _load_roles {
2383     my ($self, $table) = @_;
2384
2385     my $table_moniker = $self->monikers->{$table->sql_name};
2386     my $table_class   = $self->classes->{$table->sql_name};
2387
2388     my @roles = @{ $self->result_roles || [] };
2389     push @roles, @{ $self->result_roles_map->{$table_moniker} }
2390         if exists $self->result_roles_map->{$table_moniker};
2391
2392     if (@roles) {
2393         $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2394
2395         $self->_with($table_class, @roles);
2396     }
2397 }
2398
2399 # Overload these in driver class:
2400
2401 # Returns an arrayref of column names
2402 sub _table_columns { croak "ABSTRACT METHOD" }
2403
2404 # Returns arrayref of pk col names
2405 sub _table_pk_info { croak "ABSTRACT METHOD" }
2406
2407 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2408 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2409
2410 # Returns an arrayref of foreign key constraints, each
2411 #   being a hashref with 3 keys:
2412 #   local_columns (arrayref), remote_columns (arrayref), remote_table
2413 sub _table_fk_info { croak "ABSTRACT METHOD" }
2414
2415 # Returns an array of lower case table names
2416 sub _tables_list { croak "ABSTRACT METHOD" }
2417
2418 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2419 sub _dbic_stmt {
2420     my $self   = shift;
2421     my $class  = shift;
2422     my $method = shift;
2423
2424     # generate the pod for this statement, storing it with $self->_pod
2425     $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2426
2427     my $args = dump(@_);
2428     $args = '(' . $args . ')' if @_ < 2;
2429     my $stmt = $method . $args . q{;};
2430
2431     warn qq|$class\->$stmt\n| if $self->debug;
2432     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2433     return;
2434 }
2435
2436 sub _make_pod_heading {
2437     my ($self, $class) = @_;
2438
2439     return '' if not $self->generate_pod;
2440
2441     my $table = $self->class_to_table->{$class};
2442     my $pod;
2443
2444     my $pcm = $self->pod_comment_mode;
2445     my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2446     $comment = $self->__table_comment($table);
2447     $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2448     $comment_in_name   = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2449     $comment_in_desc   = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2450
2451     $pod .= "=head1 NAME\n\n";
2452
2453     my $table_descr = $class;
2454     $table_descr .= " - " . $comment if $comment and $comment_in_name;
2455
2456     $pod .= "$table_descr\n\n";
2457
2458     if ($comment and $comment_in_desc) {
2459         $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2460     }
2461     $pod .= "=cut\n\n";
2462
2463     return $pod;
2464 }
2465
2466 # generates the accompanying pod for a DBIC class method statement,
2467 # storing it with $self->_pod
2468 sub _make_pod {
2469     my $self   = shift;
2470     my $class  = shift;
2471     my $method = shift;
2472
2473     if ($method eq 'table') {
2474         my $table = $_[0];
2475         $table = $$table if ref $table eq 'SCALAR';
2476         $self->_pod($class, "=head1 TABLE: C<$table>");
2477         $self->_pod_cut($class);
2478     }
2479     elsif ( $method eq 'add_columns' ) {
2480         $self->_pod( $class, "=head1 ACCESSORS" );
2481         my $col_counter = 0;
2482         my @cols = @_;
2483         while( my ($name,$attrs) = splice @cols,0,2 ) {
2484             $col_counter++;
2485             $self->_pod( $class, '=head2 ' . $name  );
2486             $self->_pod( $class,
2487                 join "\n", map {
2488                     my $s = $attrs->{$_};
2489                     $s = !defined $s          ? 'undef'             :
2490                         length($s) == 0       ? '(empty string)'    :
2491                         ref($s) eq 'SCALAR'   ? $$s                 :
2492                         ref($s)               ? dumper_squashed $s  :
2493                         looks_like_number($s) ? $s                  : qq{'$s'};
2494
2495                     "  $_: $s"
2496                  } sort keys %$attrs,
2497             );
2498             if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2499                 $self->_pod( $class, $comment );
2500             }
2501         }
2502         $self->_pod_cut( $class );
2503     } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2504         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2505         my ( $accessor, $rel_class ) = @_;
2506         $self->_pod( $class, "=head2 $accessor" );
2507         $self->_pod( $class, 'Type: ' . $method );
2508         $self->_pod( $class, "Related object: L<$rel_class>" );
2509         $self->_pod_cut( $class );
2510         $self->{_relations_started} { $class } = 1;
2511     }
2512     elsif ($method eq 'add_unique_constraint') {
2513         $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2514             unless $self->{_uniqs_started}{$class};
2515
2516         my ($name, $cols) = @_;
2517
2518         $self->_pod($class, "=head2 C<$name>");
2519         $self->_pod($class, '=over 4');
2520
2521         foreach my $col (@$cols) {
2522             $self->_pod($class, "=item \* L</$col>");
2523         }
2524
2525         $self->_pod($class, '=back');
2526         $self->_pod_cut($class);
2527
2528         $self->{_uniqs_started}{$class} = 1;
2529     }
2530     elsif ($method eq 'set_primary_key') {
2531         $self->_pod($class, "=head1 PRIMARY KEY");
2532         $self->_pod($class, '=over 4');
2533
2534         foreach my $col (@_) {
2535             $self->_pod($class, "=item \* L</$col>");
2536         }
2537
2538         $self->_pod($class, '=back');
2539         $self->_pod_cut($class);
2540     }
2541 }
2542
2543 sub _pod_class_list {
2544     my ($self, $class, $title, @classes) = @_;
2545
2546     return unless @classes && $self->generate_pod;
2547
2548     $self->_pod($class, "=head1 $title");
2549     $self->_pod($class, '=over 4');
2550
2551     foreach my $link (@classes) {
2552         $self->_pod($class, "=item * L<$link>");
2553     }
2554
2555     $self->_pod($class, '=back');
2556     $self->_pod_cut($class);
2557 }
2558
2559 sub _base_class_pod {
2560     my ($self, $base_class) = @_;
2561
2562     return '' unless $self->generate_pod;
2563
2564     return <<"EOF"
2565 =head1 BASE CLASS: L<$base_class>
2566
2567 =cut
2568
2569 EOF
2570 }
2571
2572 sub _filter_comment {
2573     my ($self, $txt) = @_;
2574
2575     $txt = '' if not defined $txt;
2576
2577     $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2578
2579     return $txt;
2580 }
2581
2582 sub __table_comment {
2583     my $self = shift;
2584
2585     if (my $code = $self->can('_table_comment')) {
2586         return $self->_filter_comment($self->$code(@_));
2587     }
2588
2589     return '';
2590 }
2591
2592 sub __column_comment {
2593     my $self = shift;
2594
2595     if (my $code = $self->can('_column_comment')) {
2596         return $self->_filter_comment($self->$code(@_));
2597     }
2598
2599     return '';
2600 }
2601
2602 # Stores a POD documentation
2603 sub _pod {
2604     my ($self, $class, $stmt) = @_;
2605     $self->_raw_stmt( $class, "\n" . $stmt  );
2606 }
2607
2608 sub _pod_cut {
2609     my ($self, $class ) = @_;
2610     $self->_raw_stmt( $class, "\n=cut\n" );
2611 }
2612
2613 # Store a raw source line for a class (for dumping purposes)
2614 sub _raw_stmt {
2615     my ($self, $class, $stmt) = @_;
2616     push(@{$self->{_dump_storage}->{$class}}, $stmt);
2617 }
2618
2619 # Like above, but separately for the externally loaded stuff
2620 sub _ext_stmt {
2621     my ($self, $class, $stmt) = @_;
2622     push(@{$self->{_ext_storage}->{$class}}, $stmt);
2623 }
2624
2625 sub _custom_column_info {
2626     my ( $self, $table_name, $column_name, $column_info ) = @_;
2627
2628     if (my $code = $self->custom_column_info) {
2629         return $code->($table_name, $column_name, $column_info) || {};
2630     }
2631     return {};
2632 }
2633
2634 sub _datetime_column_info {
2635     my ( $self, $table_name, $column_name, $column_info ) = @_;
2636     my $result = {};
2637     my $type = $column_info->{data_type} || '';
2638     if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2639             or ($type =~ /date|timestamp/i)) {
2640         $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2641         $result->{locale}   = $self->datetime_locale   if $self->datetime_locale;
2642     }
2643     return $result;
2644 }
2645
2646 sub _lc {
2647     my ($self, $name) = @_;
2648
2649     return $self->preserve_case ? $name : lc($name);
2650 }
2651
2652 sub _uc {
2653     my ($self, $name) = @_;
2654
2655     return $self->preserve_case ? $name : uc($name);
2656 }
2657
2658 sub _remove_table {
2659     my ($self, $table) = @_;
2660
2661     try {
2662         my $schema = $self->schema;
2663         # in older DBIC it's a private method
2664         my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2665         $schema->$unregister(delete $self->monikers->{$table->sql_name});
2666         delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}};
2667         delete $self->_tables->{$table->sql_name};
2668     };
2669 }
2670
2671 # remove the dump dir from @INC on destruction
2672 sub DESTROY {
2673     my $self = shift;
2674
2675     @INC = grep $_ ne $self->dump_directory, @INC;
2676 }
2677
2678 =head2 monikers
2679
2680 Returns a hashref of loaded table to moniker mappings.  There will
2681 be two entries for each table, the original name and the "normalized"
2682 name, in the case that the two are different (such as databases
2683 that like uppercase table names, or preserve your original mixed-case
2684 definitions, or what-have-you).
2685
2686 =head2 classes
2687
2688 Returns a hashref of table to class mappings.  In some cases it will
2689 contain multiple entries per table for the original and normalized table
2690 names, as above in L</monikers>.
2691
2692 =head1 NON-ENGLISH DATABASES
2693
2694 If you use the loader on a database with table and column names in a language
2695 other than English, you will want to turn off the English language specific
2696 heuristics.
2697
2698 To do so, use something like this in your laoder options:
2699
2700     naming           => { monikers => 'v4' },
2701     inflect_singular => sub { "$_[0]_rel" },
2702     inflect_plural   => sub { "$_[0]_rel" },
2703
2704 =head1 COLUMN ACCESSOR COLLISIONS
2705
2706 Occasionally you may have a column name that collides with a perl method, such
2707 as C<can>. In such cases, the default action is to set the C<accessor> of the
2708 column spec to C<undef>.
2709
2710 You can then name the accessor yourself by placing code such as the following
2711 below the md5:
2712
2713     __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2714
2715 Another option is to use the L</col_collision_map> option.
2716
2717 =head1 RELATIONSHIP NAME COLLISIONS
2718
2719 In very rare cases, you may get a collision between a generated relationship
2720 name and a method in your Result class, for example if you have a foreign key
2721 called C<belongs_to>.
2722
2723 This is a problem because relationship names are also relationship accessor
2724 methods in L<DBIx::Class>.
2725
2726 The default behavior is to append C<_rel> to the relationship name and print
2727 out a warning that refers to this text.
2728
2729 You can also control the renaming with the L</rel_collision_map> option.
2730
2731 =head1 SEE ALSO
2732
2733 L<DBIx::Class::Schema::Loader>
2734
2735 =head1 AUTHOR
2736
2737 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2738
2739 =head1 LICENSE
2740
2741 This library is free software; you can redistribute it and/or modify it under
2742 the same terms as Perl itself.
2743
2744 =cut
2745
2746 1;
2747 # vim:et sts=4 sw=4 tw=0: