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

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