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