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