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