lib/DBIx/Class/Schema/Loader/Base.pm

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