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 namespace::autoclean;
   7 use Class::C3;
   8 use Carp::Clan qw/^DBIx::Class/;
   9 use DBIx::Class::Schema::Loader::RelBuilder;
  10 use Data::Dump qw/ dump /;
  11 use POSIX qw//;
  12 use File::Spec qw//;
  13 use Cwd qw//;
  14 use Digest::MD5 qw//;
  15 use Lingua::EN::Inflect::Number qw//;
  16 use Lingua::EN::Inflect::Phrase qw//;
  17 use File::Temp qw//;
  18 use Class::Unload;
  19 use Class::Inspector ();
  20 use Data::Dumper::Concise;
  21 use Scalar::Util 'looks_like_number';
  22 use File::Slurp 'slurp';
  23 require DBIx::Class;
  24
  25 our $VERSION = '0.07000';
  26
  27 __PACKAGE__->mk_group_ro_accessors('simple', qw/
  28                                 schema
  29                                 schema_class
  30
  31                                 exclude
  32                                 constraint
  33                                 additional_classes
  34                                 additional_base_classes
  35                                 left_base_classes
  36                                 components
  37                                 resultset_components
  38                                 skip_relationships
  39                                 skip_load_external
  40                                 moniker_map
  41                                 custom_column_info
  42                                 inflect_singular
  43                                 inflect_plural
  44                                 debug
  45                                 dump_directory
  46                                 dump_overwrite
  47                                 really_erase_my_files
  48                                 resultset_namespace
  49                                 default_resultset_class
  50                                 schema_base_class
  51                                 result_base_class
  52                                 overwrite_modifications
  53
  54                                 relationship_attrs
  55
  56                                 db_schema
  57                                 _tables
  58                                 classes
  59                                 _upgrading_classes
  60                                 monikers
  61                                 dynamic
  62                                 naming
  63                                 datetime_timezone
  64                                 datetime_locale
  65                                 config_file
  66                                 loader_class
  67 /);
  68
  69
  70 __PACKAGE__->mk_group_accessors('simple', qw/
  71                                 version_to_dump
  72                                 schema_version_to_dump
  73                                 _upgrading_from
  74                                 _upgrading_from_load_classes
  75                                 _downgrading_to_load_classes
  76                                 _rewriting_result_namespace
  77                                 use_namespaces
  78                                 result_namespace
  79                                 generate_pod
  80                                 pod_comment_mode
  81                                 pod_comment_spillover_length
  82                                 preserve_case
  83 /);
  84
  85 =head1 NAME
  86
  87 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
  88
  89 =head1 SYNOPSIS
  90
  91 See L<DBIx::Class::Schema::Loader>
  92
  93 =head1 DESCRIPTION
  94
  95 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
  96 classes, and implements the common functionality between them.
  97
  98 =head1 CONSTRUCTOR OPTIONS
  99
 100 These constructor options are the base options for
 101 L<DBIx::Class::Schema::Loader/loader_options>.  Available constructor options are:
 102
 103 =head2 skip_relationships
 104
 105 Skip setting up relationships.  The default is to attempt the loading
 106 of relationships.
 107
 108 =head2 skip_load_external
 109
 110 Skip loading of other classes in @INC. The default is to merge all other classes
 111 with the same name found in @INC into the schema file we are creating.
 112
 113 =head2 naming
 114
 115 Static schemas (ones dumped to disk) will, by default, use the new-style
 116 relationship names and singularized Results, unless you're overwriting an
 117 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
 118 which case the backward compatible RelBuilder will be activated, and the
 119 appropriate monikerization used.
 120
 121 Specifying
 122
 123     naming => 'current'
 124
 125 will disable the backward-compatible RelBuilder and use
 126 the new-style relationship names along with singularized Results, even when
 127 overwriting a dump made with an earlier version.
 128
 129 The option also takes a hashref:
 130
 131     naming => { relationships => 'v6', monikers => 'v6' }
 132
 133 The keys are:
 134
 135 =over 4
 136
 137 =item relationships
 138
 139 How to name relationship accessors.
 140
 141 =item monikers
 142
 143 How to name Result classes.
 144
 145 =back
 146
 147 The values can be:
 148
 149 =over 4
 150
 151 =item current
 152
 153 Latest style, whatever that happens to be.
 154
 155 =item v4
 156
 157 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
 158
 159 =item v5
 160
 161 Monikers singularized as whole words, C<might_have> relationships for FKs on
 162 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
 163
 164 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
 165 the v5 RelBuilder.
 166
 167 =item v6
 168
 169 All monikers and relationships are inflected using
 170 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
 171 from relationship names.
 172
 173 In general, there is very little difference between v5 and v6 schemas.
 174
 175 =item v7
 176
 177 This mode is identical to C<v6> mode, except that monikerization of CamelCase
 178 table names is also done correctly.
 179
 180 CamelCase column names in case-preserving mode will also be handled correctly
 181 for relationship name inflection. See L</preserve_case>.
 182
 183 If you don't have any CamelCase table or column names, you can upgrade without
 184 breaking any of your code.
 185
 186 =back
 187
 188 Dynamic schemas will always default to the 0.04XXX relationship names and won't
 189 singularize Results for backward compatibility, to activate the new RelBuilder
 190 and singularization put this in your C<Schema.pm> file:
 191
 192     __PACKAGE__->naming('current');
 193
 194 Or if you prefer to use 0.05XXX features but insure that nothing breaks in the
 195 next major version upgrade:
 196
 197     __PACKAGE__->naming('v5');
 198
 199 =head2 generate_pod
 200
 201 By default POD will be generated for columns and relationships, using database
 202 metadata for the text if available and supported.
 203
 204 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
 205 supported for Postgres right now.
 206
 207 Set this to C<0> to turn off all POD generation.
 208
 209 =head2 pod_comment_mode
 210
 211 Controls where table comments appear in the generated POD. Smaller table
 212 comments are appended to the C<NAME> section of the documentation, and larger
 213 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
 214 section to be generated with the comment always, only use C<NAME>, or choose
 215 the length threshold at which the comment is forced into the description.
 216
 217 =over 4
 218
 219 =item name
 220
 221 Use C<NAME> section only.
 222
 223 =item description
 224
 225 Force C<DESCRIPTION> always.
 226
 227 =item auto
 228
 229 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
 230 default.
 231
 232 =back
 233
 234 =head2 pod_comment_spillover_length
 235
 236 When pod_comment_mode is set to C<auto>, this is the length of the comment at
 237 which it will be forced into a separate description section.
 238
 239 The default is C<60>
 240
 241 =head2 relationship_attrs
 242
 243 Hashref of attributes to pass to each generated relationship, listed
 244 by type.  Also supports relationship type 'all', containing options to
 245 pass to all generated relationships.  Attributes set for more specific
 246 relationship types override those set in 'all'.
 247
 248 For example:
 249
 250   relationship_attrs => {
 251     all      => { cascade_delete => 0 },
 252     has_many => { cascade_delete => 1 },
 253   },
 254
 255 will set the C<cascade_delete> option to 0 for all generated relationships,
 256 except for C<has_many>, which will have cascade_delete as 1.
 257
 258 =head2 debug
 259
 260 If set to true, each constructive L<DBIx::Class> statement the loader
 261 decides to execute will be C<warn>-ed before execution.
 262
 263 =head2 db_schema
 264
 265 Set the name of the schema to load (schema in the sense that your database
 266 vendor means it).  Does not currently support loading more than one schema
 267 name.
 268
 269 =head2 constraint
 270
 271 Only load tables matching regex.  Best specified as a qr// regex.
 272
 273 =head2 exclude
 274
 275 Exclude tables matching regex.  Best specified as a qr// regex.
 276
 277 =head2 moniker_map
 278
 279 Overrides the default table name to moniker translation.  Can be either
 280 a hashref of table keys and moniker values, or a coderef for a translator
 281 function taking a single scalar table name argument and returning
 282 a scalar moniker.  If the hash entry does not exist, or the function
 283 returns a false value, the code falls back to default behavior
 284 for that table name.
 285
 286 The default behavior is to split on case transition and non-alphanumeric
 287 boundaries, singularize the resulting phrase, then join the titlecased words
 288 together. Examples:
 289
 290     Table Name       | Moniker Name
 291     ---------------------------------
 292     luser            | Luser
 293     luser_group      | LuserGroup
 294     luser-opts       | LuserOpt
 295     stations_visited | StationVisited
 296     routeChange      | RouteChange
 297
 298 =head2 inflect_plural
 299
 300 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
 301 if hash key does not exist or coderef returns false), but acts as a map
 302 for pluralizing relationship names.  The default behavior is to utilize
 303 L<Lingua::EN::Inflect::Number/to_PL>.
 304
 305 =head2 inflect_singular
 306
 307 As L</inflect_plural> above, but for singularizing relationship names.
 308 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
 309
 310 =head2 schema_base_class
 311
 312 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
 313
 314 =head2 result_base_class
 315
 316 Base class for your table classes (aka result classes). Defaults to
 317 'DBIx::Class::Core'.
 318
 319 =head2 additional_base_classes
 320
 321 List of additional base classes all of your table classes will use.
 322
 323 =head2 left_base_classes
 324
 325 List of additional base classes all of your table classes will use
 326 that need to be leftmost.
 327
 328 =head2 additional_classes
 329
 330 List of additional classes which all of your table classes will use.
 331
 332 =head2 components
 333
 334 List of additional components to be loaded into all of your table
 335 classes.  A good example would be C<ResultSetManager>.
 336
 337 =head2 resultset_components
 338
 339 List of additional ResultSet components to be loaded into your table
 340 classes.  A good example would be C<AlwaysRS>.  Component
 341 C<ResultSetManager> will be automatically added to the above
 342 C<components> list if this option is set.
 343
 344 =head2 use_namespaces
 345
 346 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
 347 a C<0>.
 348
 349 Generate result class names suitable for
 350 L<DBIx::Class::Schema/load_namespaces> and call that instead of
 351 L<DBIx::Class::Schema/load_classes>. When using this option you can also
 352 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
 353 C<resultset_namespace>, C<default_resultset_class>), and they will be added
 354 to the call (and the generated result class names adjusted appropriately).
 355
 356 =head2 dump_directory
 357
 358 This option is designed to be a tool to help you transition from this
 359 loader to a manually-defined schema when you decide it's time to do so.
 360
 361 The value of this option is a perl libdir pathname.  Within
 362 that directory this module will create a baseline manual
 363 L<DBIx::Class::Schema> module set, based on what it creates at runtime
 364 in memory.
 365
 366 The created schema class will have the same classname as the one on
 367 which you are setting this option (and the ResultSource classes will be
 368 based on this name as well).
 369
 370 Normally you wouldn't hard-code this setting in your schema class, as it
 371 is meant for one-time manual usage.
 372
 373 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
 374 recommended way to access this functionality.
 375
 376 =head2 dump_overwrite
 377
 378 Deprecated.  See L</really_erase_my_files> below, which does *not* mean
 379 the same thing as the old C<dump_overwrite> setting from previous releases.
 380
 381 =head2 really_erase_my_files
 382
 383 Default false.  If true, Loader will unconditionally delete any existing
 384 files before creating the new ones from scratch when dumping a schema to disk.
 385
 386 The default behavior is instead to only replace the top portion of the
 387 file, up to and including the final stanza which contains
 388 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
 389 leaving any customizations you placed after that as they were.
 390
 391 When C<really_erase_my_files> is not set, if the output file already exists,
 392 but the aforementioned final stanza is not found, or the checksum
 393 contained there does not match the generated contents, Loader will
 394 croak and not touch the file.
 395
 396 You should really be using version control on your schema classes (and all
 397 of the rest of your code for that matter).  Don't blame me if a bug in this
 398 code wipes something out when it shouldn't have, you've been warned.
 399
 400 =head2 overwrite_modifications
 401
 402 Default false.  If false, when updating existing files, Loader will
 403 refuse to modify any Loader-generated code that has been modified
 404 since its last run (as determined by the checksum Loader put in its
 405 comment lines).
 406
 407 If true, Loader will discard any manual modifications that have been
 408 made to Loader-generated code.
 409
 410 Again, you should be using version control on your schema classes.  Be
 411 careful with this option.
 412
 413 =head2 custom_column_info
 414
 415 Hook for adding extra attributes to the
 416 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
 417
 418 Must be a coderef that returns a hashref with the extra attributes.
 419
 420 Receives the table name, column name and column_info.
 421
 422 For example:
 423
 424   custom_column_info => sub {
 425       my ($table_name, $column_name, $column_info) = @_;
 426
 427       if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
 428           return { is_snoopy => 1 };
 429       }
 430   },
 431
 432 This attribute can also be used to set C<inflate_datetime> on a non-datetime
 433 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
 434
 435 =head2 datetime_timezone
 436
 437 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
 438 columns with the DATE/DATETIME/TIMESTAMP data_types.
 439
 440 =head2 datetime_locale
 441
 442 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
 443 columns with the DATE/DATETIME/TIMESTAMP data_types.
 444
 445 =head1 config_file
 446
 447 File in Perl format, which should return a HASH reference, from which to read
 448 loader options.
 449
 450 =head1 preserve_case
 451
 452 Usually column names are lowercased, to make them easier to work with in
 453 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
 454 supports it.
 455
 456 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
 457 case-sensitive collation will turn this option on unconditionally.
 458
 459 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
 460 setting this option.
 461
 462 =head1 METHODS
 463
 464 None of these methods are intended for direct invocation by regular
 465 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
 466 L<DBIx::Class::Schema::Loader>.
 467
 468 =cut
 469
 470 my $CURRENT_V = 'v7';
 471
 472 my @CLASS_ARGS = qw(
 473     schema_base_class result_base_class additional_base_classes
 474     left_base_classes additional_classes components resultset_components
 475 );
 476
 477 # ensure that a peice of object data is a valid arrayref, creating
 478 # an empty one or encapsulating whatever's there.
 479 sub _ensure_arrayref {
 480     my $self = shift;
 481
 482     foreach (@_) {
 483         $self->{$_} ||= [];
 484         $self->{$_} = [ $self->{$_} ]
 485             unless ref $self->{$_} eq 'ARRAY';
 486     }
 487 }
 488
 489 =head2 new
 490
 491 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
 492 by L<DBIx::Class::Schema::Loader>.
 493
 494 =cut
 495
 496 sub new {
 497     my ( $class, %args ) = @_;
 498
 499     my $self = { %args };
 500
 501     bless $self => $class;
 502
 503     if (my $config_file = $self->config_file) {
 504         my $config_opts = do $config_file;
 505
 506         croak "Error reading config from $config_file: $@" if $@;
 507
 508         croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
 509
 510         while (my ($k, $v) = each %$config_opts) {
 511             $self->{$k} = $v unless exists $self->{$k};
 512         }
 513     }
 514
 515     $self->_ensure_arrayref(qw/additional_classes
 516                                additional_base_classes
 517                                left_base_classes
 518                                components
 519                                resultset_components
 520                               /);
 521
 522     $self->_validate_class_args;
 523
 524     push(@{$self->{components}}, 'ResultSetManager')
 525         if @{$self->{resultset_components}};
 526
 527     $self->{monikers} = {};
 528     $self->{classes} = {};
 529     $self->{_upgrading_classes} = {};
 530
 531     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
 532     $self->{schema} ||= $self->{schema_class};
 533
 534     croak "dump_overwrite is deprecated.  Please read the"
 535         . " DBIx::Class::Schema::Loader::Base documentation"
 536             if $self->{dump_overwrite};
 537
 538     $self->{dynamic} = ! $self->{dump_directory};
 539     $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
 540                                                      TMPDIR  => 1,
 541                                                      CLEANUP => 1,
 542                                                    );
 543
 544     $self->{dump_directory} ||= $self->{temp_directory};
 545
 546     $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 547     $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 548
 549     if ((not ref $self->naming) && defined $self->naming) {
 550         my $naming_ver = $self->naming;
 551         $self->{naming} = {
 552             relationships => $naming_ver,
 553             monikers => $naming_ver,
 554         };
 555     }
 556
 557     if ($self->naming) {
 558         for (values %{ $self->naming }) {
 559             $_ = $CURRENT_V if $_ eq 'current';
 560         }
 561     }
 562     $self->{naming} ||= {};
 563
 564     if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
 565         croak 'custom_column_info must be a CODE ref';
 566     }
 567
 568     $self->_check_back_compat;
 569
 570     $self->use_namespaces(1) unless defined $self->use_namespaces;
 571     $self->generate_pod(1)   unless defined $self->generate_pod;
 572     $self->pod_comment_mode('auto')         unless defined $self->pod_comment_mode;
 573     $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
 574
 575     $self;
 576 }
 577
 578 sub _check_back_compat {
 579     my ($self) = @_;
 580
 581 # dynamic schemas will always be in 0.04006 mode, unless overridden
 582     if ($self->dynamic) {
 583 # just in case, though no one is likely to dump a dynamic schema
 584         $self->schema_version_to_dump('0.04006');
 585
 586         if (not %{ $self->naming }) {
 587             warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 588
 589 Dynamic schema detected, will run in 0.04006 mode.
 590
 591 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 592 to disable this warning.
 593
 594 Also consider setting 'use_namespaces => 1' if/when upgrading.
 595
 596 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 597 details.
 598 EOF
 599         }
 600         else {
 601             $self->_upgrading_from('v4');
 602         }
 603
 604         $self->naming->{relationships} ||= 'v4';
 605         $self->naming->{monikers}      ||= 'v4';
 606
 607         if ($self->use_namespaces) {
 608             $self->_upgrading_from_load_classes(1);
 609         }
 610         else {
 611             $self->use_namespaces(0);
 612         }
 613
 614         return;
 615     }
 616
 617 # otherwise check if we need backcompat mode for a static schema
 618     my $filename = $self->_get_dump_filename($self->schema_class);
 619     return unless -e $filename;
 620
 621     open(my $fh, '<', $filename)
 622         or croak "Cannot open '$filename' for reading: $!";
 623
 624     my $load_classes     = 0;
 625     my $result_namespace = '';
 626
 627     while (<$fh>) {
 628         if (/^__PACKAGE__->load_classes;/) {
 629             $load_classes = 1;
 630         } elsif (/result_namespace => '([^']+)'/) {
 631             $result_namespace = $1;
 632         } elsif (my ($real_ver) =
 633                 /^# Created by DBIx::Class::Schema::Loader v(\d+\.\d+)/) {
 634
 635             if ($load_classes && (not defined $self->use_namespaces)) {
 636                 warn <<"EOF"  unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 637
 638 'load_classes;' static schema detected, turning off 'use_namespaces'.
 639
 640 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
 641 variable to disable this warning.
 642
 643 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 644 details.
 645 EOF
 646                 $self->use_namespaces(0);
 647             }
 648             elsif ($load_classes && $self->use_namespaces) {
 649                 $self->_upgrading_from_load_classes(1);
 650             }
 651             elsif ((not $load_classes) && defined $self->use_namespaces
 652                                        && (not $self->use_namespaces)) {
 653                 $self->_downgrading_to_load_classes(
 654                     $result_namespace || 'Result'
 655                 );
 656             }
 657             elsif ((not defined $self->use_namespaces)
 658                    || $self->use_namespaces) {
 659                 if (not $self->result_namespace) {
 660                     $self->result_namespace($result_namespace || 'Result');
 661                 }
 662                 elsif ($result_namespace ne $self->result_namespace) {
 663                     $self->_rewriting_result_namespace(
 664                         $result_namespace || 'Result'
 665                     );
 666                 }
 667             }
 668
 669             # XXX when we go past .0 this will need fixing
 670             my ($v) = $real_ver =~ /([1-9])/;
 671             $v = "v$v";
 672
 673             last if $v eq $CURRENT_V || $real_ver =~ /^0\.\d\d999/;
 674
 675             if (not %{ $self->naming }) {
 676                 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 677
 678 Version $real_ver static schema detected, turning on backcompat mode.
 679
 680 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 681 to disable this warning.
 682
 683 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
 684
 685 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
 686 from version 0.04006.
 687 EOF
 688             }
 689             else {
 690                 $self->_upgrading_from($v);
 691                 last;
 692             }
 693
 694             $self->naming->{relationships} ||= $v;
 695             $self->naming->{monikers}      ||= $v;
 696
 697             $self->schema_version_to_dump($real_ver);
 698
 699             last;
 700         }
 701     }
 702     close $fh;
 703 }
 704
 705 sub _validate_class_args {
 706     my $self = shift;
 707     my $args = shift;
 708
 709     foreach my $k (@CLASS_ARGS) {
 710         next unless $self->$k;
 711
 712         my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
 713         foreach my $c (@classes) {
 714             # components default to being under the DBIx::Class namespace unless they
 715             # are preceeded with a '+'
 716             if ( $k =~ m/components$/ && $c !~ s/^\+// ) {
 717                 $c = 'DBIx::Class::' . $c;
 718             }
 719
 720             # 1 == installed, 0 == not installed, undef == invalid classname
 721             my $installed = Class::Inspector->installed($c);
 722             if ( defined($installed) ) {
 723                 if ( $installed == 0 ) {
 724                     croak qq/$c, as specified in the loader option "$k", is not installed/;
 725                 }
 726             } else {
 727                 croak qq/$c, as specified in the loader option "$k", is an invalid class name/;
 728             }
 729         }
 730     }
 731 }
 732
 733 sub _find_file_in_inc {
 734     my ($self, $file) = @_;
 735
 736     foreach my $prefix (@INC) {
 737         my $fullpath = File::Spec->catfile($prefix, $file);
 738         return $fullpath if -f $fullpath
 739             # abs_path throws on Windows for nonexistant files
 740             and eval { Cwd::abs_path($fullpath) } ne
 741                (eval { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) } || '');
 742     }
 743
 744     return;
 745 }
 746
 747 sub _class_path {
 748     my ($self, $class) = @_;
 749
 750     my $class_path = $class;
 751     $class_path =~ s{::}{/}g;
 752     $class_path .= '.pm';
 753
 754     return $class_path;
 755 }
 756
 757 sub _find_class_in_inc {
 758     my ($self, $class) = @_;
 759
 760     return $self->_find_file_in_inc($self->_class_path($class));
 761 }
 762
 763 sub _rewriting {
 764     my $self = shift;
 765
 766     return $self->_upgrading_from
 767         || $self->_upgrading_from_load_classes
 768         || $self->_downgrading_to_load_classes
 769         || $self->_rewriting_result_namespace
 770     ;
 771 }
 772
 773 sub _rewrite_old_classnames {
 774     my ($self, $code) = @_;
 775
 776     return $code unless $self->_rewriting;
 777
 778     my %old_classes = reverse %{ $self->_upgrading_classes };
 779
 780     my $re = join '|', keys %old_classes;
 781     $re = qr/\b($re)\b/;
 782
 783     $code =~ s/$re/$old_classes{$1} || $1/eg;
 784
 785     return $code;
 786 }
 787
 788 sub _load_external {
 789     my ($self, $class) = @_;
 790
 791     return if $self->{skip_load_external};
 792
 793     # so that we don't load our own classes, under any circumstances
 794     local *INC = [ grep $_ ne $self->dump_directory, @INC ];
 795
 796     my $real_inc_path = $self->_find_class_in_inc($class);
 797
 798     my $old_class = $self->_upgrading_classes->{$class}
 799         if $self->_rewriting;
 800
 801     my $old_real_inc_path = $self->_find_class_in_inc($old_class)
 802         if $old_class && $old_class ne $class;
 803
 804     return unless $real_inc_path || $old_real_inc_path;
 805
 806     if ($real_inc_path) {
 807         # If we make it to here, we loaded an external definition
 808         warn qq/# Loaded external class definition for '$class'\n/
 809             if $self->debug;
 810
 811         open(my $fh, '<', $real_inc_path)
 812             or croak "Failed to open '$real_inc_path' for reading: $!";
 813         my $code = do { local $/; <$fh> };
 814         close($fh)
 815             or croak "Failed to close $real_inc_path: $!";
 816         $code = $self->_rewrite_old_classnames($code);
 817
 818         if ($self->dynamic) { # load the class too
 819             # kill redefined warnings
 820             my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 821             local $SIG{__WARN__} = sub {
 822                 $warn_handler->(@_)
 823                     unless $_[0] =~ /^Subroutine \S+ redefined/;
 824             };
 825             eval $code;
 826             die $@ if $@;
 827         }
 828
 829         $self->_ext_stmt($class,
 830           qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
 831          .qq|# They are now part of the custom portion of this file\n|
 832          .qq|# for you to hand-edit.  If you do not either delete\n|
 833          .qq|# this section or remove that file from \@INC, this section\n|
 834          .qq|# will be repeated redundantly when you re-create this\n|
 835          .qq|# file again via Loader!  See skip_load_external to disable\n|
 836          .qq|# this feature.\n|
 837         );
 838         chomp $code;
 839         $self->_ext_stmt($class, $code);
 840         $self->_ext_stmt($class,
 841             qq|# End of lines loaded from '$real_inc_path' |
 842         );
 843     }
 844
 845     if ($old_real_inc_path) {
 846         open(my $fh, '<', $old_real_inc_path)
 847             or croak "Failed to open '$old_real_inc_path' for reading: $!";
 848         $self->_ext_stmt($class, <<"EOF");
 849
 850 # These lines were loaded from '$old_real_inc_path',
 851 # based on the Result class name that would have been created by an older
 852 # version of the Loader. For a static schema, this happens only once during
 853 # upgrade. See skip_load_external to disable this feature.
 854 EOF
 855
 856         my $code = slurp $old_real_inc_path;
 857         $code = $self->_rewrite_old_classnames($code);
 858
 859         if ($self->dynamic) {
 860             warn <<"EOF";
 861
 862 Detected external content in '$old_real_inc_path', a class name that would have
 863 been used by an older version of the Loader.
 864
 865 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
 866 new name of the Result.
 867 EOF
 868             # kill redefined warnings
 869             my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 870             local $SIG{__WARN__} = sub {
 871                 $warn_handler->(@_)
 872                     unless $_[0] =~ /^Subroutine \S+ redefined/;
 873             };
 874             eval $code;
 875             die $@ if $@;
 876         }
 877
 878         chomp $code;
 879         $self->_ext_stmt($class, $code);
 880         $self->_ext_stmt($class,
 881             qq|# End of lines loaded from '$old_real_inc_path' |
 882         );
 883     }
 884 }
 885
 886 =head2 load
 887
 888 Does the actual schema-construction work.
 889
 890 =cut
 891
 892 sub load {
 893     my $self = shift;
 894
 895     $self->_load_tables(
 896         $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
 897     );
 898 }
 899
 900 =head2 rescan
 901
 902 Arguments: schema
 903
 904 Rescan the database for newly added tables.  Does
 905 not process drops or changes.  Returns a list of
 906 the newly added table monikers.
 907
 908 The schema argument should be the schema class
 909 or object to be affected.  It should probably
 910 be derived from the original schema_class used
 911 during L</load>.
 912
 913 =cut
 914
 915 sub rescan {
 916     my ($self, $schema) = @_;
 917
 918     $self->{schema} = $schema;
 919     $self->_relbuilder->{schema} = $schema;
 920
 921     my @created;
 922     my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
 923
 924     foreach my $table (@current) {
 925         if(!exists $self->{_tables}->{$table}) {
 926             push(@created, $table);
 927         }
 928     }
 929
 930     my %current;
 931     @current{@current} = ();
 932     foreach my $table (keys %{ $self->{_tables} }) {
 933         if (not exists $current{$table}) {
 934             $self->_unregister_source_for_table($table);
 935         }
 936     }
 937
 938     my $loaded = $self->_load_tables(@created);
 939
 940     return map { $self->monikers->{$_} } @$loaded;
 941 }
 942
 943 sub _relbuilder {
 944     no warnings 'uninitialized';
 945     my ($self) = @_;
 946
 947     return if $self->{skip_relationships};
 948
 949     if ($self->naming->{relationships} eq 'v4') {
 950         require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
 951         return $self->{relbuilder} ||=
 952             DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
 953                 $self->schema,
 954                 $self->inflect_plural,
 955                 $self->inflect_singular,
 956                 $self->relationship_attrs,
 957             );
 958     }
 959     elsif ($self->naming->{relationships} eq 'v5') {
 960         require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_05;
 961         return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_05->new (
 962              $self->schema,
 963              $self->inflect_plural,
 964              $self->inflect_singular,
 965              $self->relationship_attrs,
 966         );
 967     }
 968     elsif ($self->naming->{relationships} eq 'v6') {
 969         require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_06;
 970         return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_06->new (
 971              $self->schema,
 972              $self->inflect_plural,
 973              $self->inflect_singular,
 974              $self->relationship_attrs,
 975         );
 976     }
 977
 978     return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new (
 979              $self->schema,
 980              $self->inflect_plural,
 981              $self->inflect_singular,
 982              $self->relationship_attrs,
 983     );
 984 }
 985
 986 sub _load_tables {
 987     my ($self, @tables) = @_;
 988
 989     # Save the new tables to the tables list
 990     foreach (@tables) {
 991         $self->{_tables}->{$_} = 1;
 992     }
 993
 994     $self->_make_src_class($_) for @tables;
 995
 996     # sanity-check for moniker clashes
 997     my $inverse_moniker_idx;
 998     for (keys %{$self->monikers}) {
 999       push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1000     }
1001
1002     my @clashes;
1003     for (keys %$inverse_moniker_idx) {
1004       my $tables = $inverse_moniker_idx->{$_};
1005       if (@$tables > 1) {
1006         push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1007           join (', ', map { "'$_'" } @$tables),
1008           $_,
1009         );
1010       }
1011     }
1012
1013     if (@clashes) {
1014       die   'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1015           . 'Either change the naming style, or supply an explicit moniker_map: '
1016           . join ('; ', @clashes)
1017           . "\n"
1018       ;
1019     }
1020
1021
1022     $self->_setup_src_meta($_) for @tables;
1023
1024     if(!$self->skip_relationships) {
1025         # The relationship loader needs a working schema
1026         $self->{quiet} = 1;
1027         local $self->{dump_directory} = $self->{temp_directory};
1028         $self->_reload_classes(\@tables);
1029         $self->_load_relationships($_) for @tables;
1030         $self->{quiet} = 0;
1031
1032         # Remove that temp dir from INC so it doesn't get reloaded
1033         @INC = grep $_ ne $self->dump_directory, @INC;
1034     }
1035
1036     $self->_load_external($_)
1037         for map { $self->classes->{$_} } @tables;
1038
1039     # Reload without unloading first to preserve any symbols from external
1040     # packages.
1041     $self->_reload_classes(\@tables, 0);
1042
1043     # Drop temporary cache
1044     delete $self->{_cache};
1045
1046     return \@tables;
1047 }
1048
1049 sub _reload_classes {
1050     my ($self, $tables, $unload) = @_;
1051
1052     my @tables = @$tables;
1053     $unload = 1 unless defined $unload;
1054
1055     # so that we don't repeat custom sections
1056     @INC = grep $_ ne $self->dump_directory, @INC;
1057
1058     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1059
1060     unshift @INC, $self->dump_directory;
1061
1062     my @to_register;
1063     my %have_source = map { $_ => $self->schema->source($_) }
1064         $self->schema->sources;
1065
1066     for my $table (@tables) {
1067         my $moniker = $self->monikers->{$table};
1068         my $class = $self->classes->{$table};
1069
1070         {
1071             no warnings 'redefine';
1072             local *Class::C3::reinitialize = sub {};
1073             use warnings;
1074
1075             Class::Unload->unload($class) if $unload;
1076             my ($source, $resultset_class);
1077             if (
1078                 ($source = $have_source{$moniker})
1079                 && ($resultset_class = $source->resultset_class)
1080                 && ($resultset_class ne 'DBIx::Class::ResultSet')
1081             ) {
1082                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1083                 Class::Unload->unload($resultset_class) if $unload;
1084                 $self->_reload_class($resultset_class) if $has_file;
1085             }
1086             $self->_reload_class($class);
1087         }
1088         push @to_register, [$moniker, $class];
1089     }
1090
1091     Class::C3->reinitialize;
1092     for (@to_register) {
1093         $self->schema->register_class(@$_);
1094     }
1095 }
1096
1097 # We use this instead of ensure_class_loaded when there are package symbols we
1098 # want to preserve.
1099 sub _reload_class {
1100     my ($self, $class) = @_;
1101
1102     my $class_path = $self->_class_path($class);
1103     delete $INC{ $class_path };
1104
1105 # kill redefined warnings
1106     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
1107     local $SIG{__WARN__} = sub {
1108         $warn_handler->(@_)
1109             unless $_[0] =~ /^Subroutine \S+ redefined/;
1110     };
1111     eval "require $class;";
1112 }
1113
1114 sub _get_dump_filename {
1115     my ($self, $class) = (@_);
1116
1117     $class =~ s{::}{/}g;
1118     return $self->dump_directory . q{/} . $class . q{.pm};
1119 }
1120
1121 sub _ensure_dump_subdirs {
1122     my ($self, $class) = (@_);
1123
1124     my @name_parts = split(/::/, $class);
1125     pop @name_parts; # we don't care about the very last element,
1126                      # which is a filename
1127
1128     my $dir = $self->dump_directory;
1129     while (1) {
1130         if(!-d $dir) {
1131             mkdir($dir) or croak "mkdir('$dir') failed: $!";
1132         }
1133         last if !@name_parts;
1134         $dir = File::Spec->catdir($dir, shift @name_parts);
1135     }
1136 }
1137
1138 sub _dump_to_dir {
1139     my ($self, @classes) = @_;
1140
1141     my $schema_class = $self->schema_class;
1142     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1143
1144     my $target_dir = $self->dump_directory;
1145     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1146         unless $self->{dynamic} or $self->{quiet};
1147
1148     my $schema_text =
1149           qq|package $schema_class;\n\n|
1150         . qq|# Created by DBIx::Class::Schema::Loader\n|
1151         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1152         . qq|use strict;\nuse warnings;\n\n|
1153         . qq|use base '$schema_base_class';\n\n|;
1154
1155     if ($self->use_namespaces) {
1156         $schema_text .= qq|__PACKAGE__->load_namespaces|;
1157         my $namespace_options;
1158
1159         my @attr = qw/resultset_namespace default_resultset_class/;
1160
1161         unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1162
1163         for my $attr (@attr) {
1164             if ($self->$attr) {
1165                 $namespace_options .= qq|    $attr => '| . $self->$attr . qq|',\n|
1166             }
1167         }
1168         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1169         $schema_text .= qq|;\n|;
1170     }
1171     else {
1172         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1173     }
1174
1175     {
1176         local $self->{version_to_dump} = $self->schema_version_to_dump;
1177         $self->_write_classfile($schema_class, $schema_text, 1);
1178     }
1179
1180     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1181
1182     foreach my $src_class (@classes) {
1183         my $src_text =
1184               qq|package $src_class;\n\n|
1185             . qq|# Created by DBIx::Class::Schema::Loader\n|
1186             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1187             . qq|use strict;\nuse warnings;\n\n|
1188             . qq|use base '$result_base_class';\n\n|;
1189
1190         $self->_write_classfile($src_class, $src_text);
1191     }
1192
1193     # remove Result dir if downgrading from use_namespaces, and there are no
1194     # files left.
1195     if (my $result_ns = $self->_downgrading_to_load_classes
1196                         || $self->_rewriting_result_namespace) {
1197         my $result_namespace = $self->_result_namespace(
1198             $schema_class,
1199             $result_ns,
1200         );
1201
1202         (my $result_dir = $result_namespace) =~ s{::}{/}g;
1203         $result_dir = $self->dump_directory . '/' . $result_dir;
1204
1205         unless (my @files = glob "$result_dir/*") {
1206             rmdir $result_dir;
1207         }
1208     }
1209
1210     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1211
1212 }
1213
1214 sub _sig_comment {
1215     my ($self, $version, $ts) = @_;
1216     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1217          . qq| v| . $version
1218          . q| @ | . $ts
1219          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1220 }
1221
1222 sub _write_classfile {
1223     my ($self, $class, $text, $is_schema) = @_;
1224
1225     my $filename = $self->_get_dump_filename($class);
1226     $self->_ensure_dump_subdirs($class);
1227
1228     if (-f $filename && $self->really_erase_my_files) {
1229         warn "Deleting existing file '$filename' due to "
1230             . "'really_erase_my_files' setting\n" unless $self->{quiet};
1231         unlink($filename);
1232     }
1233
1234     my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
1235
1236     if (my $old_class = $self->_upgrading_classes->{$class}) {
1237         my $old_filename = $self->_get_dump_filename($old_class);
1238
1239         my ($old_custom_content) = $self->_get_custom_content(
1240             $old_class, $old_filename, 0 # do not add default comment
1241         );
1242
1243         $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
1244
1245         if ($old_custom_content) {
1246             $custom_content =
1247                 "\n" . $old_custom_content . "\n" . $custom_content;
1248         }
1249
1250         unlink $old_filename;
1251     }
1252
1253     $custom_content = $self->_rewrite_old_classnames($custom_content);
1254
1255     $text .= qq|$_\n|
1256         for @{$self->{_dump_storage}->{$class} || []};
1257
1258     # Check and see if the dump is infact differnt
1259
1260     my $compare_to;
1261     if ($old_md5) {
1262       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1263
1264
1265       if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1266         return unless $self->_upgrading_from && $is_schema;
1267       }
1268     }
1269
1270     $text .= $self->_sig_comment(
1271       $self->version_to_dump,
1272       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1273     );
1274
1275     open(my $fh, '>', $filename)
1276         or croak "Cannot open '$filename' for writing: $!";
1277
1278     # Write the top half and its MD5 sum
1279     print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1280
1281     # Write out anything loaded via external partial class file in @INC
1282     print $fh qq|$_\n|
1283         for @{$self->{_ext_storage}->{$class} || []};
1284
1285     # Write out any custom content the user has added
1286     print $fh $custom_content;
1287
1288     close($fh)
1289         or croak "Error closing '$filename': $!";
1290 }
1291
1292 sub _default_custom_content {
1293     return qq|\n\n# You can replace this text with custom|
1294          . qq| content, and it will be preserved on regeneration|
1295          . qq|\n1;\n|;
1296 }
1297
1298 sub _get_custom_content {
1299     my ($self, $class, $filename, $add_default) = @_;
1300
1301     $add_default = 1 unless defined $add_default;
1302
1303     return ($self->_default_custom_content) if ! -f $filename;
1304
1305     open(my $fh, '<', $filename)
1306         or croak "Cannot open '$filename' for reading: $!";
1307
1308     my $mark_re =
1309         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1310
1311     my $buffer = '';
1312     my ($md5, $ts, $ver);
1313     while(<$fh>) {
1314         if(!$md5 && /$mark_re/) {
1315             $md5 = $2;
1316             my $line = $1;
1317
1318             # Pull out the previous version and timestamp
1319             ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
1320
1321             $buffer .= $line;
1322             croak "Checksum mismatch in '$filename', 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"
1323                 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
1324
1325             $buffer = '';
1326         }
1327         else {
1328             $buffer .= $_;
1329         }
1330     }
1331
1332     croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
1333         . " it does not appear to have been generated by Loader"
1334             if !$md5;
1335
1336     # Default custom content:
1337     $buffer ||= $self->_default_custom_content if $add_default;
1338
1339     return ($buffer, $md5, $ver, $ts);
1340 }
1341
1342 sub _use {
1343     my $self = shift;
1344     my $target = shift;
1345
1346     foreach (@_) {
1347         warn "$target: use $_;" if $self->debug;
1348         $self->_raw_stmt($target, "use $_;");
1349     }
1350 }
1351
1352 sub _inject {
1353     my $self = shift;
1354     my $target = shift;
1355     my $schema_class = $self->schema_class;
1356
1357     my $blist = join(q{ }, @_);
1358     warn "$target: use base qw/ $blist /;" if $self->debug && @_;
1359     $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
1360 }
1361
1362 sub _result_namespace {
1363     my ($self, $schema_class, $ns) = @_;
1364     my @result_namespace;
1365
1366     if ($ns =~ /^\+(.*)/) {
1367         # Fully qualified namespace
1368         @result_namespace = ($1)
1369     }
1370     else {
1371         # Relative namespace
1372         @result_namespace = ($schema_class, $ns);
1373     }
1374
1375     return wantarray ? @result_namespace : join '::', @result_namespace;
1376 }
1377
1378 # Create class with applicable bases, setup monikers, etc
1379 sub _make_src_class {
1380     my ($self, $table) = @_;
1381
1382     my $schema       = $self->schema;
1383     my $schema_class = $self->schema_class;
1384
1385     my $table_moniker = $self->_table2moniker($table);
1386     my @result_namespace = ($schema_class);
1387     if ($self->use_namespaces) {
1388         my $result_namespace = $self->result_namespace || 'Result';
1389         @result_namespace = $self->_result_namespace(
1390             $schema_class,
1391             $result_namespace,
1392         );
1393     }
1394     my $table_class = join(q{::}, @result_namespace, $table_moniker);
1395
1396     if ((my $upgrading_v = $self->_upgrading_from)
1397             || $self->_rewriting) {
1398         local $self->naming->{monikers} = $upgrading_v
1399             if $upgrading_v;
1400
1401         my @result_namespace = @result_namespace;
1402         if ($self->_upgrading_from_load_classes) {
1403             @result_namespace = ($schema_class);
1404         }
1405         elsif (my $ns = $self->_downgrading_to_load_classes) {
1406             @result_namespace = $self->_result_namespace(
1407                 $schema_class,
1408                 $ns,
1409             );
1410         }
1411         elsif ($ns = $self->_rewriting_result_namespace) {
1412             @result_namespace = $self->_result_namespace(
1413                 $schema_class,
1414                 $ns,
1415             );
1416         }
1417
1418         my $old_class = join(q{::}, @result_namespace,
1419             $self->_table2moniker($table));
1420
1421         $self->_upgrading_classes->{$table_class} = $old_class
1422             unless $table_class eq $old_class;
1423     }
1424
1425 # this was a bad idea, should be ok now without it
1426 #    my $table_normalized = lc $table;
1427 #    $self->classes->{$table_normalized} = $table_class;
1428 #    $self->monikers->{$table_normalized} = $table_moniker;
1429
1430     $self->classes->{$table} = $table_class;
1431     $self->monikers->{$table} = $table_moniker;
1432
1433     $self->_use   ($table_class, @{$self->additional_classes});
1434     $self->_inject($table_class, @{$self->left_base_classes});
1435
1436     if (my @components = @{ $self->components }) {
1437         $self->_dbic_stmt($table_class, 'load_components', @components);
1438     }
1439
1440     $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1441         if @{$self->resultset_components};
1442     $self->_inject($table_class, @{$self->additional_base_classes});
1443 }
1444
1445 sub _resolve_col_accessor_collisions {
1446     my ($self, $col_info) = @_;
1447
1448     my $base       = $self->result_base_class || 'DBIx::Class::Core';
1449     my @components = map "DBIx::Class::$_", @{ $self->components || [] };
1450
1451     my @methods;
1452
1453     for my $class ($base, @components) {
1454         eval "require ${class};";
1455         die $@ if $@;
1456
1457         push @methods, @{ Class::Inspector->methods($class) || [] };
1458     }
1459
1460     my %methods;
1461     @methods{@methods} = ();
1462
1463     while (my ($col, $info) = each %$col_info) {
1464         my $accessor = $info->{accessor} || $col;
1465
1466         next if $accessor eq 'id'; # special case (very common column)
1467
1468         if (exists $methods{$accessor}) {
1469             $info->{accessor} = undef;
1470         }
1471     }
1472 }
1473
1474 # Set up metadata (cols, pks, etc)
1475 sub _setup_src_meta {
1476     my ($self, $table) = @_;
1477
1478     my $schema       = $self->schema;
1479     my $schema_class = $self->schema_class;
1480
1481     my $table_class = $self->classes->{$table};
1482     my $table_moniker = $self->monikers->{$table};
1483
1484     my $table_name = $table;
1485     my $name_sep   = $self->schema->storage->sql_maker->name_sep;
1486
1487     if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1488         $table_name = \ $self->_quote_table_name($table_name);
1489     }
1490
1491     $self->_dbic_stmt($table_class,'table',$table_name);
1492
1493     my $cols = $self->_table_columns($table);
1494     my $col_info = $self->__columns_info_for($table);
1495     if ($self->preserve_case) {
1496         for my $col (keys %$col_info) {
1497             $col_info->{$col}{accessor} = lc $col
1498                 if $col ne lc($col);
1499         }
1500     }
1501     else {
1502         # XXX this needs to go away
1503         $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1504     }
1505
1506     $self->_resolve_col_accessor_collisions($col_info);
1507
1508     my $fks = $self->_table_fk_info($table);
1509
1510     for my $fkdef (@$fks) {
1511         for my $col (@{ $fkdef->{local_columns} }) {
1512             $col_info->{$col}{is_foreign_key} = 1;
1513         }
1514     }
1515     $self->_dbic_stmt(
1516         $table_class,
1517         'add_columns',
1518         map { $_, ($col_info->{$_}||{}) } @$cols
1519     );
1520
1521     my %uniq_tag; # used to eliminate duplicate uniqs
1522
1523     my $pks = $self->_table_pk_info($table) || [];
1524     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1525           : carp("$table has no primary key");
1526     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1527
1528     my $uniqs = $self->_table_uniq_info($table) || [];
1529     for (@$uniqs) {
1530         my ($name, $cols) = @$_;
1531         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1532         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1533     }
1534
1535 }
1536
1537 sub __columns_info_for {
1538     my ($self, $table) = @_;
1539
1540     my $result = $self->_columns_info_for($table);
1541
1542     while (my ($col, $info) = each %$result) {
1543         $info = { %$info, %{ $self->_custom_column_info  ($table, $col, $info) } };
1544         $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1545
1546         $result->{$col} = $info;
1547     }
1548
1549     return $result;
1550 }
1551
1552 =head2 tables
1553
1554 Returns a sorted list of loaded tables, using the original database table
1555 names.
1556
1557 =cut
1558
1559 sub tables {
1560     my $self = shift;
1561
1562     return keys %{$self->_tables};
1563 }
1564
1565 # Make a moniker from a table
1566 sub _default_table2moniker {
1567     no warnings 'uninitialized';
1568     my ($self, $table) = @_;
1569
1570     if ($self->naming->{monikers} eq 'v4') {
1571         return join '', map ucfirst, split /[\W_]+/, lc $table;
1572     }
1573     elsif ($self->naming->{monikers} eq 'v5') {
1574         return join '', map ucfirst, split /[\W_]+/,
1575             Lingua::EN::Inflect::Number::to_S(lc $table);
1576     }
1577     elsif ($self->naming->{monikers} eq 'v6') {
1578         (my $as_phrase = lc $table) =~ s/_+/ /g;
1579         my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1580
1581         return join '', map ucfirst, split /\W+/, $inflected;
1582     }
1583
1584     my @words = map lc, split /(?<=[[:lower:]])[\W_]*(?=[[:upper:]])|[\W_]+/, $table;
1585     my $as_phrase = join ' ', @words;
1586
1587     my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1588
1589     return join '', map ucfirst, split /\W+/, $inflected;
1590 }
1591
1592 sub _table2moniker {
1593     my ( $self, $table ) = @_;
1594
1595     my $moniker;
1596
1597     if( ref $self->moniker_map eq 'HASH' ) {
1598         $moniker = $self->moniker_map->{$table};
1599     }
1600     elsif( ref $self->moniker_map eq 'CODE' ) {
1601         $moniker = $self->moniker_map->($table);
1602     }
1603
1604     $moniker ||= $self->_default_table2moniker($table);
1605
1606     return $moniker;
1607 }
1608
1609 sub _load_relationships {
1610     my ($self, $table) = @_;
1611
1612     my $tbl_fk_info = $self->_table_fk_info($table);
1613     foreach my $fkdef (@$tbl_fk_info) {
1614         $fkdef->{remote_source} =
1615             $self->monikers->{delete $fkdef->{remote_table}};
1616     }
1617     my $tbl_uniq_info = $self->_table_uniq_info($table);
1618
1619     my $local_moniker = $self->monikers->{$table};
1620     my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1621
1622     foreach my $src_class (sort keys %$rel_stmts) {
1623         my $src_stmts = $rel_stmts->{$src_class};
1624         foreach my $stmt (@$src_stmts) {
1625             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1626         }
1627     }
1628 }
1629
1630 # Overload these in driver class:
1631
1632 # Returns an arrayref of column names
1633 sub _table_columns { croak "ABSTRACT METHOD" }
1634
1635 # Returns arrayref of pk col names
1636 sub _table_pk_info { croak "ABSTRACT METHOD" }
1637
1638 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1639 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1640
1641 # Returns an arrayref of foreign key constraints, each
1642 #   being a hashref with 3 keys:
1643 #   local_columns (arrayref), remote_columns (arrayref), remote_table
1644 sub _table_fk_info { croak "ABSTRACT METHOD" }
1645
1646 # Returns an array of lower case table names
1647 sub _tables_list { croak "ABSTRACT METHOD" }
1648
1649 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1650 sub _dbic_stmt {
1651     my $self   = shift;
1652     my $class  = shift;
1653     my $method = shift;
1654
1655     # generate the pod for this statement, storing it with $self->_pod
1656     $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
1657
1658     my $args = dump(@_);
1659     $args = '(' . $args . ')' if @_ < 2;
1660     my $stmt = $method . $args . q{;};
1661
1662     warn qq|$class\->$stmt\n| if $self->debug;
1663     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1664     return;
1665 }
1666
1667 # generates the accompanying pod for a DBIC class method statement,
1668 # storing it with $self->_pod
1669 sub _make_pod {
1670     my $self   = shift;
1671     my $class  = shift;
1672     my $method = shift;
1673
1674     if ( $method eq 'table' ) {
1675         my ($table) = @_;
1676         my $pcm = $self->pod_comment_mode;
1677         my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
1678         if ( $self->can('_table_comment') ) {
1679             $comment = $self->_table_comment($table);
1680             $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1681             $comment_in_name   = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1682             $comment_in_desc   = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
1683         }
1684         $self->_pod( $class, "=head1 NAME" );
1685         my $table_descr = $class;
1686         $table_descr .= " - " . $comment if $comment and $comment_in_name;
1687         $self->{_class2table}{ $class } = $table;
1688         $self->_pod( $class, $table_descr );
1689         if ($comment and $comment_in_desc) {
1690             $self->_pod( $class, "=head1 DESCRIPTION" );
1691             $self->_pod( $class, $comment );
1692         }
1693         $self->_pod_cut( $class );
1694     } elsif ( $method eq 'add_columns' ) {
1695         $self->_pod( $class, "=head1 ACCESSORS" );
1696         my $col_counter = 0;
1697         my @cols = @_;
1698         while( my ($name,$attrs) = splice @cols,0,2 ) {
1699             $col_counter++;
1700             $self->_pod( $class, '=head2 ' . $name  );
1701             $self->_pod( $class,
1702                          join "\n", map {
1703                              my $s = $attrs->{$_};
1704                              $s = !defined $s         ? 'undef'          :
1705                                   length($s) == 0     ? '(empty string)' :
1706                                   ref($s) eq 'SCALAR' ? $$s :
1707                                   ref($s)             ? do {
1708                                                         my $dd = Dumper;
1709                                                         $dd->Indent(0);
1710                                                         $dd->Values([$s]);
1711                                                         $dd->Dump;
1712                                                       } :
1713                                   looks_like_number($s) ? $s :
1714                                                         qq{'$s'}
1715                                   ;
1716
1717                              "  $_: $s"
1718                          } sort keys %$attrs,
1719                        );
1720
1721             if( $self->can('_column_comment')
1722                 and my $comment = $self->_column_comment( $self->{_class2table}{$class}, $col_counter)
1723               ) {
1724                 $self->_pod( $class, $comment );
1725             }
1726         }
1727         $self->_pod_cut( $class );
1728     } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1729         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1730         my ( $accessor, $rel_class ) = @_;
1731         $self->_pod( $class, "=head2 $accessor" );
1732         $self->_pod( $class, 'Type: ' . $method );
1733         $self->_pod( $class, "Related object: L<$rel_class>" );
1734         $self->_pod_cut( $class );
1735         $self->{_relations_started} { $class } = 1;
1736     }
1737 }
1738
1739 # Stores a POD documentation
1740 sub _pod {
1741     my ($self, $class, $stmt) = @_;
1742     $self->_raw_stmt( $class, "\n" . $stmt  );
1743 }
1744
1745 sub _pod_cut {
1746     my ($self, $class ) = @_;
1747     $self->_raw_stmt( $class, "\n=cut\n" );
1748 }
1749
1750 # Store a raw source line for a class (for dumping purposes)
1751 sub _raw_stmt {
1752     my ($self, $class, $stmt) = @_;
1753     push(@{$self->{_dump_storage}->{$class}}, $stmt);
1754 }
1755
1756 # Like above, but separately for the externally loaded stuff
1757 sub _ext_stmt {
1758     my ($self, $class, $stmt) = @_;
1759     push(@{$self->{_ext_storage}->{$class}}, $stmt);
1760 }
1761
1762 sub _quote_table_name {
1763     my ($self, $table) = @_;
1764
1765     my $qt = $self->schema->storage->sql_maker->quote_char;
1766
1767     return $table unless $qt;
1768
1769     if (ref $qt) {
1770         return $qt->[0] . $table . $qt->[1];
1771     }
1772
1773     return $qt . $table . $qt;
1774 }
1775
1776 sub _custom_column_info {
1777     my ( $self, $table_name, $column_name, $column_info ) = @_;
1778
1779     if (my $code = $self->custom_column_info) {
1780         return $code->($table_name, $column_name, $column_info) || {};
1781     }
1782     return {};
1783 }
1784
1785 sub _datetime_column_info {
1786     my ( $self, $table_name, $column_name, $column_info ) = @_;
1787     my $result = {};
1788     my $type = $column_info->{data_type} || '';
1789     if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
1790             or ($type =~ /date|timestamp/i)) {
1791         $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
1792         $result->{locale}   = $self->datetime_locale   if $self->datetime_locale;
1793     }
1794     return $result;
1795 }
1796
1797 sub _lc {
1798     my ($self, $name) = @_;
1799
1800     return $self->preserve_case ? $name : lc($name);
1801 }
1802
1803 sub _uc {
1804     my ($self, $name) = @_;
1805
1806     return $self->preserve_case ? $name : uc($name);
1807 }
1808
1809 sub _unregister_source_for_table {
1810     my ($self, $table) = @_;
1811
1812     eval {
1813         local $@;
1814         my $schema = $self->schema;
1815         # in older DBIC it's a private method
1816         my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
1817         $schema->$unregister($self->_table2moniker($table));
1818         delete $self->monikers->{$table};
1819         delete $self->classes->{$table};
1820         delete $self->_upgrading_classes->{$table};
1821         delete $self->{_tables}{$table};
1822     };
1823 }
1824
1825 # remove the dump dir from @INC on destruction
1826 sub DESTROY {
1827     my $self = shift;
1828
1829     @INC = grep $_ ne $self->dump_directory, @INC;
1830 }
1831
1832 =head2 monikers
1833
1834 Returns a hashref of loaded table to moniker mappings.  There will
1835 be two entries for each table, the original name and the "normalized"
1836 name, in the case that the two are different (such as databases
1837 that like uppercase table names, or preserve your original mixed-case
1838 definitions, or what-have-you).
1839
1840 =head2 classes
1841
1842 Returns a hashref of table to class mappings.  In some cases it will
1843 contain multiple entries per table for the original and normalized table
1844 names, as above in L</monikers>.
1845
1846 =head1 SEE ALSO
1847
1848 L<DBIx::Class::Schema::Loader>
1849
1850 =head1 AUTHOR
1851
1852 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1853
1854 =head1 LICENSE
1855
1856 This library is free software; you can redistribute it and/or modify it under
1857 the same terms as Perl itself.
1858
1859 =cut
1860
1861 1;
1862 # vim:et sts=4 sw=4 tw=0: