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