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

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