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