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