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