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 use DBIx::Class::Schema::Loader::Utils 'split_name';
  24 require DBIx::Class;
  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 custom content also makes the classes
 480 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 package __DBICSL__DUMMY;
 549 use Moose;
 550 use MooseX::NonMoose;
 551 use namespace::autoclean;
 552 EOF
 553         if ($@) {
 554             die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
 555                 "Moose, MooseX::NonMoose and namespace::autoclean";
 556         }
 557     }
 558
 559     push(@{$self->{components}}, 'ResultSetManager')
 560         if @{$self->{resultset_components}};
 561
 562     $self->{monikers} = {};
 563     $self->{classes} = {};
 564     $self->{_upgrading_classes} = {};
 565
 566     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
 567     $self->{schema} ||= $self->{schema_class};
 568
 569     croak "dump_overwrite is deprecated.  Please read the"
 570         . " DBIx::Class::Schema::Loader::Base documentation"
 571             if $self->{dump_overwrite};
 572
 573     $self->{dynamic} = ! $self->{dump_directory};
 574     $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
 575                                                      TMPDIR  => 1,
 576                                                      CLEANUP => 1,
 577                                                    );
 578
 579     $self->{dump_directory} ||= $self->{temp_directory};
 580
 581     $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 582     $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 583
 584     if ((not ref $self->naming) && defined $self->naming) {
 585         my $naming_ver = $self->naming;
 586         $self->{naming} = {
 587             relationships => $naming_ver,
 588             monikers => $naming_ver,
 589             column_accessors => $naming_ver,
 590         };
 591     }
 592
 593     if ($self->naming) {
 594         for (values %{ $self->naming }) {
 595             $_ = $CURRENT_V if $_ eq 'current';
 596         }
 597     }
 598     $self->{naming} ||= {};
 599
 600     if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
 601         croak 'custom_column_info must be a CODE ref';
 602     }
 603
 604     $self->_check_back_compat;
 605
 606     $self->use_namespaces(1) unless defined $self->use_namespaces;
 607     $self->generate_pod(1)   unless defined $self->generate_pod;
 608     $self->pod_comment_mode('auto')         unless defined $self->pod_comment_mode;
 609     $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
 610
 611     $self;
 612 }
 613
 614 sub _check_back_compat {
 615     my ($self) = @_;
 616
 617 # dynamic schemas will always be in 0.04006 mode, unless overridden
 618     if ($self->dynamic) {
 619 # just in case, though no one is likely to dump a dynamic schema
 620         $self->schema_version_to_dump('0.04006');
 621
 622         if (not %{ $self->naming }) {
 623             warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 624
 625 Dynamic schema detected, will run in 0.04006 mode.
 626
 627 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 628 to disable this warning.
 629
 630 Also consider setting 'use_namespaces => 1' if/when upgrading.
 631
 632 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 633 details.
 634 EOF
 635         }
 636         else {
 637             $self->_upgrading_from('v4');
 638         }
 639
 640         $self->naming->{relationships} ||= 'v4';
 641         $self->naming->{monikers}      ||= 'v4';
 642
 643         if ($self->use_namespaces) {
 644             $self->_upgrading_from_load_classes(1);
 645         }
 646         else {
 647             $self->use_namespaces(0);
 648         }
 649
 650         return;
 651     }
 652
 653 # otherwise check if we need backcompat mode for a static schema
 654     my $filename = $self->_get_dump_filename($self->schema_class);
 655     return unless -e $filename;
 656
 657     open(my $fh, '<', $filename)
 658         or croak "Cannot open '$filename' for reading: $!";
 659
 660     my $load_classes     = 0;
 661     my $result_namespace = '';
 662
 663     while (<$fh>) {
 664         if (/^__PACKAGE__->load_classes;/) {
 665             $load_classes = 1;
 666         } elsif (/result_namespace => '([^']+)'/) {
 667             $result_namespace = $1;
 668         } elsif (my ($real_ver) =
 669                 /^# Created by DBIx::Class::Schema::Loader v(\d+\.\d+)/) {
 670
 671             if ($load_classes && (not defined $self->use_namespaces)) {
 672                 warn <<"EOF"  unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 673
 674 'load_classes;' static schema detected, turning off 'use_namespaces'.
 675
 676 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
 677 variable to disable this warning.
 678
 679 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 680 details.
 681 EOF
 682                 $self->use_namespaces(0);
 683             }
 684             elsif ($load_classes && $self->use_namespaces) {
 685                 $self->_upgrading_from_load_classes(1);
 686             }
 687             elsif ((not $load_classes) && defined $self->use_namespaces
 688                                        && (not $self->use_namespaces)) {
 689                 $self->_downgrading_to_load_classes(
 690                     $result_namespace || 'Result'
 691                 );
 692             }
 693             elsif ((not defined $self->use_namespaces)
 694                    || $self->use_namespaces) {
 695                 if (not $self->result_namespace) {
 696                     $self->result_namespace($result_namespace || 'Result');
 697                 }
 698                 elsif ($result_namespace ne $self->result_namespace) {
 699                     $self->_rewriting_result_namespace(
 700                         $result_namespace || 'Result'
 701                     );
 702                 }
 703             }
 704
 705             # XXX when we go past .0 this will need fixing
 706             my ($v) = $real_ver =~ /([1-9])/;
 707             $v = "v$v";
 708
 709             last if $v eq $CURRENT_V || $real_ver =~ /^0\.\d\d999/;
 710
 711             if (not %{ $self->naming }) {
 712                 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 713
 714 Version $real_ver static schema detected, turning on backcompat mode.
 715
 716 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 717 to disable this warning.
 718
 719 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
 720
 721 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
 722 from version 0.04006.
 723 EOF
 724             }
 725             else {
 726                 $self->_upgrading_from($v);
 727                 last;
 728             }
 729
 730             $self->naming->{relationships}    ||= $v;
 731             $self->naming->{monikers}         ||= $v;
 732             $self->naming->{column_accessors} ||= $v;
 733
 734             $self->schema_version_to_dump($real_ver);
 735
 736             last;
 737         }
 738     }
 739     close $fh;
 740 }
 741
 742 sub _validate_class_args {
 743     my $self = shift;
 744     my $args = shift;
 745
 746     foreach my $k (@CLASS_ARGS) {
 747         next unless $self->$k;
 748
 749         my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
 750         foreach my $c (@classes) {
 751             # components default to being under the DBIx::Class namespace unless they
 752             # are preceeded with a '+'
 753             if ( $k =~ m/components$/ && $c !~ s/^\+// ) {
 754                 $c = 'DBIx::Class::' . $c;
 755             }
 756
 757             # 1 == installed, 0 == not installed, undef == invalid classname
 758             my $installed = Class::Inspector->installed($c);
 759             if ( defined($installed) ) {
 760                 if ( $installed == 0 ) {
 761                     croak qq/$c, as specified in the loader option "$k", is not installed/;
 762                 }
 763             } else {
 764                 croak qq/$c, as specified in the loader option "$k", is an invalid class name/;
 765             }
 766         }
 767     }
 768 }
 769
 770 sub _find_file_in_inc {
 771     my ($self, $file) = @_;
 772
 773     foreach my $prefix (@INC) {
 774         my $fullpath = File::Spec->catfile($prefix, $file);
 775         return $fullpath if -f $fullpath
 776             # abs_path throws on Windows for nonexistant files
 777             and eval { Cwd::abs_path($fullpath) } ne
 778                (eval { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) } || '');
 779     }
 780
 781     return;
 782 }
 783
 784 sub _class_path {
 785     my ($self, $class) = @_;
 786
 787     my $class_path = $class;
 788     $class_path =~ s{::}{/}g;
 789     $class_path .= '.pm';
 790
 791     return $class_path;
 792 }
 793
 794 sub _find_class_in_inc {
 795     my ($self, $class) = @_;
 796
 797     return $self->_find_file_in_inc($self->_class_path($class));
 798 }
 799
 800 sub _rewriting {
 801     my $self = shift;
 802
 803     return $self->_upgrading_from
 804         || $self->_upgrading_from_load_classes
 805         || $self->_downgrading_to_load_classes
 806         || $self->_rewriting_result_namespace
 807     ;
 808 }
 809
 810 sub _rewrite_old_classnames {
 811     my ($self, $code) = @_;
 812
 813     return $code unless $self->_rewriting;
 814
 815     my %old_classes = reverse %{ $self->_upgrading_classes };
 816
 817     my $re = join '|', keys %old_classes;
 818     $re = qr/\b($re)\b/;
 819
 820     $code =~ s/$re/$old_classes{$1} || $1/eg;
 821
 822     return $code;
 823 }
 824
 825 sub _load_external {
 826     my ($self, $class) = @_;
 827
 828     return if $self->{skip_load_external};
 829
 830     # so that we don't load our own classes, under any circumstances
 831     local *INC = [ grep $_ ne $self->dump_directory, @INC ];
 832
 833     my $real_inc_path = $self->_find_class_in_inc($class);
 834
 835     my $old_class = $self->_upgrading_classes->{$class}
 836         if $self->_rewriting;
 837
 838     my $old_real_inc_path = $self->_find_class_in_inc($old_class)
 839         if $old_class && $old_class ne $class;
 840
 841     return unless $real_inc_path || $old_real_inc_path;
 842
 843     if ($real_inc_path) {
 844         # If we make it to here, we loaded an external definition
 845         warn qq/# Loaded external class definition for '$class'\n/
 846             if $self->debug;
 847
 848         open(my $fh, '<', $real_inc_path)
 849             or croak "Failed to open '$real_inc_path' for reading: $!";
 850         my $code = do { local $/; <$fh> };
 851         close($fh)
 852             or croak "Failed to close $real_inc_path: $!";
 853         $code = $self->_rewrite_old_classnames($code);
 854
 855         if ($self->dynamic) { # load the class too
 856             # kill redefined warnings
 857             my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 858             local $SIG{__WARN__} = sub {
 859                 $warn_handler->(@_)
 860                     unless $_[0] =~ /^Subroutine \S+ redefined/;
 861             };
 862             eval $code;
 863             die $@ if $@;
 864         }
 865
 866         $self->_ext_stmt($class,
 867           qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
 868          .qq|# They are now part of the custom portion of this file\n|
 869          .qq|# for you to hand-edit.  If you do not either delete\n|
 870          .qq|# this section or remove that file from \@INC, this section\n|
 871          .qq|# will be repeated redundantly when you re-create this\n|
 872          .qq|# file again via Loader!  See skip_load_external to disable\n|
 873          .qq|# this feature.\n|
 874         );
 875         chomp $code;
 876         $self->_ext_stmt($class, $code);
 877         $self->_ext_stmt($class,
 878             qq|# End of lines loaded from '$real_inc_path' |
 879         );
 880     }
 881
 882     if ($old_real_inc_path) {
 883         my $code = slurp $old_real_inc_path;
 884
 885         $self->_ext_stmt($class, <<"EOF");
 886
 887 # These lines were loaded from '$old_real_inc_path',
 888 # based on the Result class name that would have been created by an older
 889 # version of the Loader. For a static schema, this happens only once during
 890 # upgrade. See skip_load_external to disable this feature.
 891 EOF
 892
 893         $code = $self->_rewrite_old_classnames($code);
 894
 895         if ($self->dynamic) {
 896             warn <<"EOF";
 897
 898 Detected external content in '$old_real_inc_path', a class name that would have
 899 been used by an older version of the Loader.
 900
 901 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
 902 new name of the Result.
 903 EOF
 904             # kill redefined warnings
 905             my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 906             local $SIG{__WARN__} = sub {
 907                 $warn_handler->(@_)
 908                     unless $_[0] =~ /^Subroutine \S+ redefined/;
 909             };
 910             eval $code;
 911             die $@ if $@;
 912         }
 913
 914         chomp $code;
 915         $self->_ext_stmt($class, $code);
 916         $self->_ext_stmt($class,
 917             qq|# End of lines loaded from '$old_real_inc_path' |
 918         );
 919     }
 920 }
 921
 922 =head2 load
 923
 924 Does the actual schema-construction work.
 925
 926 =cut
 927
 928 sub load {
 929     my $self = shift;
 930
 931     $self->_load_tables(
 932         $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
 933     );
 934 }
 935
 936 =head2 rescan
 937
 938 Arguments: schema
 939
 940 Rescan the database for changes. Returns a list of the newly added table
 941 monikers.
 942
 943 The schema argument should be the schema class or object to be affected.  It
 944 should probably be derived from the original schema_class used during L</load>.
 945
 946 =cut
 947
 948 sub rescan {
 949     my ($self, $schema) = @_;
 950
 951     $self->{schema} = $schema;
 952     $self->_relbuilder->{schema} = $schema;
 953
 954     my @created;
 955     my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
 956
 957     foreach my $table (@current) {
 958         if(!exists $self->{_tables}->{$table}) {
 959             push(@created, $table);
 960         }
 961     }
 962
 963     my %current;
 964     @current{@current} = ();
 965     foreach my $table (keys %{ $self->{_tables} }) {
 966         if (not exists $current{$table}) {
 967             $self->_unregister_source_for_table($table);
 968         }
 969     }
 970
 971     delete $self->{_dump_storage};
 972     delete $self->{_relations_started};
 973
 974     my $loaded = $self->_load_tables(@current);
 975
 976     return map { $self->monikers->{$_} } @created;
 977 }
 978
 979 sub _relbuilder {
 980     no warnings 'uninitialized';
 981     my ($self) = @_;
 982
 983     return if $self->{skip_relationships};
 984
 985     if ($self->naming->{relationships} eq 'v4') {
 986         require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
 987         return $self->{relbuilder} ||=
 988             DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
 989                 $self->schema,
 990                 $self->inflect_plural,
 991                 $self->inflect_singular,
 992                 $self->relationship_attrs,
 993             );
 994     }
 995     elsif ($self->naming->{relationships} eq 'v5') {
 996         require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_05;
 997         return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_05->new (
 998              $self->schema,
 999              $self->inflect_plural,
1000              $self->inflect_singular,
1001              $self->relationship_attrs,
1002         );
1003     }
1004     elsif ($self->naming->{relationships} eq 'v6') {
1005         require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_06;
1006         return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_06->new (
1007              $self->schema,
1008              $self->inflect_plural,
1009              $self->inflect_singular,
1010              $self->relationship_attrs,
1011         );
1012     }
1013
1014     return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new (
1015              $self->schema,
1016              $self->inflect_plural,
1017              $self->inflect_singular,
1018              $self->relationship_attrs,
1019     );
1020 }
1021
1022 sub _load_tables {
1023     my ($self, @tables) = @_;
1024
1025     # Save the new tables to the tables list
1026     foreach (@tables) {
1027         $self->{_tables}->{$_} = 1;
1028     }
1029
1030     $self->_make_src_class($_) for @tables;
1031
1032     # sanity-check for moniker clashes
1033     my $inverse_moniker_idx;
1034     for (keys %{$self->monikers}) {
1035       push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1036     }
1037
1038     my @clashes;
1039     for (keys %$inverse_moniker_idx) {
1040       my $tables = $inverse_moniker_idx->{$_};
1041       if (@$tables > 1) {
1042         push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1043           join (', ', map { "'$_'" } @$tables),
1044           $_,
1045         );
1046       }
1047     }
1048
1049     if (@clashes) {
1050       die   'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1051           . 'Either change the naming style, or supply an explicit moniker_map: '
1052           . join ('; ', @clashes)
1053           . "\n"
1054       ;
1055     }
1056
1057
1058     $self->_setup_src_meta($_) for @tables;
1059
1060     if(!$self->skip_relationships) {
1061         # The relationship loader needs a working schema
1062         $self->{quiet} = 1;
1063         local $self->{dump_directory} = $self->{temp_directory};
1064         $self->_reload_classes(\@tables);
1065         $self->_load_relationships($_) for @tables;
1066         $self->{quiet} = 0;
1067
1068         # Remove that temp dir from INC so it doesn't get reloaded
1069         @INC = grep $_ ne $self->dump_directory, @INC;
1070     }
1071
1072     $self->_load_external($_)
1073         for map { $self->classes->{$_} } @tables;
1074
1075     # Reload without unloading first to preserve any symbols from external
1076     # packages.
1077     $self->_reload_classes(\@tables, 0);
1078
1079     # Drop temporary cache
1080     delete $self->{_cache};
1081
1082     return \@tables;
1083 }
1084
1085 sub _reload_classes {
1086     my ($self, $tables, $unload) = @_;
1087
1088     my @tables = @$tables;
1089     $unload = 1 unless defined $unload;
1090
1091     # so that we don't repeat custom sections
1092     @INC = grep $_ ne $self->dump_directory, @INC;
1093
1094     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1095
1096     unshift @INC, $self->dump_directory;
1097
1098     my @to_register;
1099     my %have_source = map { $_ => $self->schema->source($_) }
1100         $self->schema->sources;
1101
1102     for my $table (@tables) {
1103         my $moniker = $self->monikers->{$table};
1104         my $class = $self->classes->{$table};
1105
1106         {
1107             no warnings 'redefine';
1108             local *Class::C3::reinitialize = sub {};
1109             use warnings;
1110
1111             if ($class->can('meta')) {
1112                 $class->meta->make_mutable;
1113             }
1114             Class::Unload->unload($class) if $unload;
1115             my ($source, $resultset_class);
1116             if (
1117                 ($source = $have_source{$moniker})
1118                 && ($resultset_class = $source->resultset_class)
1119                 && ($resultset_class ne 'DBIx::Class::ResultSet')
1120             ) {
1121                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1122                 if ($resultset_class->can('meta')) {
1123                     $resultset_class->meta->make_mutable;
1124                 }
1125                 Class::Unload->unload($resultset_class) if $unload;
1126                 $self->_reload_class($resultset_class) if $has_file;
1127             }
1128             $self->_reload_class($class);
1129         }
1130         push @to_register, [$moniker, $class];
1131     }
1132
1133     Class::C3->reinitialize;
1134     for (@to_register) {
1135         $self->schema->register_class(@$_);
1136     }
1137 }
1138
1139 # We use this instead of ensure_class_loaded when there are package symbols we
1140 # want to preserve.
1141 sub _reload_class {
1142     my ($self, $class) = @_;
1143
1144     my $class_path = $self->_class_path($class);
1145     delete $INC{ $class_path };
1146
1147 # kill redefined warnings
1148     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
1149     local $SIG{__WARN__} = sub {
1150         $warn_handler->(@_)
1151             unless $_[0] =~ /^Subroutine \S+ redefined/;
1152     };
1153     eval "require $class;";
1154     die "Failed to reload class $class: $@" if $@;
1155 }
1156
1157 sub _get_dump_filename {
1158     my ($self, $class) = (@_);
1159
1160     $class =~ s{::}{/}g;
1161     return $self->dump_directory . q{/} . $class . q{.pm};
1162 }
1163
1164 sub _ensure_dump_subdirs {
1165     my ($self, $class) = (@_);
1166
1167     my @name_parts = split(/::/, $class);
1168     pop @name_parts; # we don't care about the very last element,
1169                      # which is a filename
1170
1171     my $dir = $self->dump_directory;
1172     while (1) {
1173         if(!-d $dir) {
1174             mkdir($dir) or croak "mkdir('$dir') failed: $!";
1175         }
1176         last if !@name_parts;
1177         $dir = File::Spec->catdir($dir, shift @name_parts);
1178     }
1179 }
1180
1181 sub _dump_to_dir {
1182     my ($self, @classes) = @_;
1183
1184     my $schema_class = $self->schema_class;
1185     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1186
1187     my $target_dir = $self->dump_directory;
1188     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1189         unless $self->{dynamic} or $self->{quiet};
1190
1191     my $schema_text =
1192           qq|package $schema_class;\n\n|
1193         . qq|# Created by DBIx::Class::Schema::Loader\n|
1194         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1195         . qq|use strict;\nuse warnings;\n\n|;
1196     if ($self->use_moose) {
1197         $schema_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1198     }
1199     else {
1200         $schema_text .= qq|use base '$schema_base_class';\n\n|;
1201     }
1202
1203     if ($self->use_namespaces) {
1204         $schema_text .= qq|__PACKAGE__->load_namespaces|;
1205         my $namespace_options;
1206
1207         my @attr = qw/resultset_namespace default_resultset_class/;
1208
1209         unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1210
1211         for my $attr (@attr) {
1212             if ($self->$attr) {
1213                 $namespace_options .= qq|    $attr => '| . $self->$attr . qq|',\n|
1214             }
1215         }
1216         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1217         $schema_text .= qq|;\n|;
1218     }
1219     else {
1220         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1221     }
1222
1223     {
1224         local $self->{version_to_dump} = $self->schema_version_to_dump;
1225         $self->_write_classfile($schema_class, $schema_text, 1);
1226     }
1227
1228     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1229
1230     foreach my $src_class (@classes) {
1231         my $src_text =
1232               qq|package $src_class;\n\n|
1233             . qq|# Created by DBIx::Class::Schema::Loader\n|
1234             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1235             . qq|use strict;\nuse warnings;\n\n|;
1236         if ($self->use_moose) {
1237             $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;\nextends '$result_base_class';\n\n|;
1238         }
1239         else {
1240              $src_text .= qq|use base '$result_base_class';\n\n|;
1241         }
1242         $self->_write_classfile($src_class, $src_text);
1243     }
1244
1245     # remove Result dir if downgrading from use_namespaces, and there are no
1246     # files left.
1247     if (my $result_ns = $self->_downgrading_to_load_classes
1248                         || $self->_rewriting_result_namespace) {
1249         my $result_namespace = $self->_result_namespace(
1250             $schema_class,
1251             $result_ns,
1252         );
1253
1254         (my $result_dir = $result_namespace) =~ s{::}{/}g;
1255         $result_dir = $self->dump_directory . '/' . $result_dir;
1256
1257         unless (my @files = glob "$result_dir/*") {
1258             rmdir $result_dir;
1259         }
1260     }
1261
1262     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1263
1264 }
1265
1266 sub _sig_comment {
1267     my ($self, $version, $ts) = @_;
1268     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1269          . qq| v| . $version
1270          . q| @ | . $ts
1271          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1272 }
1273
1274 sub _write_classfile {
1275     my ($self, $class, $text, $is_schema) = @_;
1276
1277     my $filename = $self->_get_dump_filename($class);
1278     $self->_ensure_dump_subdirs($class);
1279
1280     if (-f $filename && $self->really_erase_my_files) {
1281         warn "Deleting existing file '$filename' due to "
1282             . "'really_erase_my_files' setting\n" unless $self->{quiet};
1283         unlink($filename);
1284     }
1285
1286     my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
1287
1288     # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1289     # If there is already custom content, which does not have the Moose content, add it.
1290     if ($self->use_moose) {
1291         local $self->{use_moose} = 0;
1292
1293         if ($custom_content eq $self->_default_custom_content) {
1294             local $self->{use_moose} = 1;
1295
1296             $custom_content = $self->_default_custom_content;
1297         }
1298         else {
1299             local $self->{use_moose} = 1;
1300
1301             if ($custom_content !~ /\Q@{[$self->_default_moose_custom_content]}\E/) {
1302                 $custom_content .= $self->_default_custom_content;
1303             }
1304         }
1305     }
1306
1307     if (my $old_class = $self->_upgrading_classes->{$class}) {
1308         my $old_filename = $self->_get_dump_filename($old_class);
1309
1310         my ($old_custom_content) = $self->_get_custom_content(
1311             $old_class, $old_filename, 0 # do not add default comment
1312         );
1313
1314         $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
1315
1316         if ($old_custom_content) {
1317             $custom_content =
1318                 "\n" . $old_custom_content . "\n" . $custom_content;
1319         }
1320
1321         unlink $old_filename;
1322     }
1323
1324     $custom_content = $self->_rewrite_old_classnames($custom_content);
1325
1326     $text .= qq|$_\n|
1327         for @{$self->{_dump_storage}->{$class} || []};
1328
1329     # Check and see if the dump is infact differnt
1330
1331     my $compare_to;
1332     if ($old_md5) {
1333       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1334
1335
1336       if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1337         return unless $self->_upgrading_from && $is_schema;
1338       }
1339     }
1340
1341     $text .= $self->_sig_comment(
1342       $self->version_to_dump,
1343       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1344     );
1345
1346     open(my $fh, '>', $filename)
1347         or croak "Cannot open '$filename' for writing: $!";
1348
1349     # Write the top half and its MD5 sum
1350     print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1351
1352     # Write out anything loaded via external partial class file in @INC
1353     print $fh qq|$_\n|
1354         for @{$self->{_ext_storage}->{$class} || []};
1355
1356     # Write out any custom content the user has added
1357     print $fh $custom_content;
1358
1359     close($fh)
1360         or croak "Error closing '$filename': $!";
1361 }
1362
1363 sub _default_moose_custom_content {
1364     return qq|\n__PACKAGE__->meta->make_immutable;|;
1365 }
1366
1367 sub _default_custom_content {
1368     my $self = shift;
1369     my $default = qq|\n\n# You can replace this text with custom|
1370          . qq| content, and it will be preserved on regeneration|;
1371     if ($self->use_moose) {
1372         $default .= $self->_default_moose_custom_content;
1373     }
1374     $default .= qq|\n1;\n|;
1375     return $default;
1376 }
1377
1378 sub _get_custom_content {
1379     my ($self, $class, $filename, $add_default) = @_;
1380
1381     $add_default = 1 unless defined $add_default;
1382
1383     return ($self->_default_custom_content) if ! -f $filename;
1384
1385     open(my $fh, '<', $filename)
1386         or croak "Cannot open '$filename' for reading: $!";
1387
1388     my $mark_re =
1389         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1390
1391     my $buffer = '';
1392     my ($md5, $ts, $ver);
1393     while(<$fh>) {
1394         if(!$md5 && /$mark_re/) {
1395             $md5 = $2;
1396             my $line = $1;
1397
1398             # Pull out the previous version and timestamp
1399             ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
1400
1401             $buffer .= $line;
1402             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"
1403                 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
1404
1405             $buffer = '';
1406         }
1407         else {
1408             $buffer .= $_;
1409         }
1410     }
1411
1412     croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
1413         . " it does not appear to have been generated by Loader"
1414             if !$md5;
1415
1416     # Default custom content:
1417     $buffer ||= $self->_default_custom_content if $add_default;
1418
1419     return ($buffer, $md5, $ver, $ts);
1420 }
1421
1422 sub _use {
1423     my $self = shift;
1424     my $target = shift;
1425
1426     foreach (@_) {
1427         warn "$target: use $_;" if $self->debug;
1428         $self->_raw_stmt($target, "use $_;");
1429     }
1430 }
1431
1432 sub _inject {
1433     my $self = shift;
1434     my $target = shift;
1435     my $schema_class = $self->schema_class;
1436
1437     my $blist = join(q{ }, @_);
1438     warn "$target: use base qw/ $blist /;" if $self->debug && @_;
1439     $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
1440 }
1441
1442 sub _result_namespace {
1443     my ($self, $schema_class, $ns) = @_;
1444     my @result_namespace;
1445
1446     if ($ns =~ /^\+(.*)/) {
1447         # Fully qualified namespace
1448         @result_namespace = ($1)
1449     }
1450     else {
1451         # Relative namespace
1452         @result_namespace = ($schema_class, $ns);
1453     }
1454
1455     return wantarray ? @result_namespace : join '::', @result_namespace;
1456 }
1457
1458 # Create class with applicable bases, setup monikers, etc
1459 sub _make_src_class {
1460     my ($self, $table) = @_;
1461
1462     my $schema       = $self->schema;
1463     my $schema_class = $self->schema_class;
1464
1465     my $table_moniker = $self->_table2moniker($table);
1466     my @result_namespace = ($schema_class);
1467     if ($self->use_namespaces) {
1468         my $result_namespace = $self->result_namespace || 'Result';
1469         @result_namespace = $self->_result_namespace(
1470             $schema_class,
1471             $result_namespace,
1472         );
1473     }
1474     my $table_class = join(q{::}, @result_namespace, $table_moniker);
1475
1476     if ((my $upgrading_v = $self->_upgrading_from)
1477             || $self->_rewriting) {
1478         local $self->naming->{monikers} = $upgrading_v
1479             if $upgrading_v;
1480
1481         my @result_namespace = @result_namespace;
1482         if ($self->_upgrading_from_load_classes) {
1483             @result_namespace = ($schema_class);
1484         }
1485         elsif (my $ns = $self->_downgrading_to_load_classes) {
1486             @result_namespace = $self->_result_namespace(
1487                 $schema_class,
1488                 $ns,
1489             );
1490         }
1491         elsif ($ns = $self->_rewriting_result_namespace) {
1492             @result_namespace = $self->_result_namespace(
1493                 $schema_class,
1494                 $ns,
1495             );
1496         }
1497
1498         my $old_class = join(q{::}, @result_namespace,
1499             $self->_table2moniker($table));
1500
1501         $self->_upgrading_classes->{$table_class} = $old_class
1502             unless $table_class eq $old_class;
1503     }
1504
1505 # this was a bad idea, should be ok now without it
1506 #    my $table_normalized = lc $table;
1507 #    $self->classes->{$table_normalized} = $table_class;
1508 #    $self->monikers->{$table_normalized} = $table_moniker;
1509
1510     $self->classes->{$table} = $table_class;
1511     $self->monikers->{$table} = $table_moniker;
1512
1513     $self->_use   ($table_class, @{$self->additional_classes});
1514     $self->_inject($table_class, @{$self->left_base_classes});
1515
1516     if (my @components = @{ $self->components }) {
1517         $self->_dbic_stmt($table_class, 'load_components', @components);
1518     }
1519
1520     $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1521         if @{$self->resultset_components};
1522     $self->_inject($table_class, @{$self->additional_base_classes});
1523 }
1524
1525 sub _resolve_col_accessor_collisions {
1526     my ($self, $col_info) = @_;
1527
1528     my $base       = $self->result_base_class || 'DBIx::Class::Core';
1529     my @components = map "DBIx::Class::$_", @{ $self->components || [] };
1530
1531     my @methods;
1532
1533     for my $class ($base, @components) {
1534         eval "require ${class};";
1535         die $@ if $@;
1536
1537         push @methods, @{ Class::Inspector->methods($class) || [] };
1538     }
1539
1540     my %methods;
1541     @methods{@methods} = ();
1542
1543     while (my ($col, $info) = each %$col_info) {
1544         my $accessor = $info->{accessor} || $col;
1545
1546         next if $accessor eq 'id'; # special case (very common column)
1547
1548         if (exists $methods{$accessor}) {
1549             $info->{accessor} = undef;
1550         }
1551     }
1552 }
1553
1554 sub _make_column_accessor_name {
1555     my ($self, $column_name) = @_;
1556
1557     return join '_', map lc, split_name $column_name;
1558 }
1559
1560 # Set up metadata (cols, pks, etc)
1561 sub _setup_src_meta {
1562     my ($self, $table) = @_;
1563
1564     my $schema       = $self->schema;
1565     my $schema_class = $self->schema_class;
1566
1567     my $table_class = $self->classes->{$table};
1568     my $table_moniker = $self->monikers->{$table};
1569
1570     my $table_name = $table;
1571     my $name_sep   = $self->schema->storage->sql_maker->name_sep;
1572
1573     if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1574         $table_name = \ $self->_quote_table_name($table_name);
1575     }
1576
1577     my $full_table_name = ($self->qualify_objects ? ($self->db_schema . '.') : '') . (ref $table_name ? $$table_name : $table_name);
1578
1579     # be careful to not create refs Data::Dump can "optimize"
1580     $full_table_name    = \do {"".$full_table_name} if ref $table_name;
1581
1582     $self->_dbic_stmt($table_class, 'table', $full_table_name);
1583
1584     my $cols = $self->_table_columns($table);
1585     my $col_info = $self->__columns_info_for($table);
1586
1587     while (my ($col, $info) = each %$col_info) {
1588         if ($col =~ /\W/) {
1589             ($info->{accessor} = $col) =~ s/\W+/_/g;
1590         }
1591     }
1592
1593     if ($self->preserve_case) {
1594         while (my ($col, $info) = each %$col_info) {
1595             if ($col ne lc($col)) {
1596                 if ((not exists $self->naming->{column_accessors}) || (($self->naming->{column_accessors} =~ /(\d+)/)[0] >= 7)) {
1597                     $info->{accessor} = $self->_make_column_accessor_name($info->{accessor} || $col);
1598                 }
1599                 else {
1600                     $info->{accessor} = lc($info->{accessor} || $col);
1601                 }
1602             }
1603         }
1604     }
1605     else {
1606         # XXX this needs to go away
1607         $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1608     }
1609
1610     $self->_resolve_col_accessor_collisions($col_info);
1611
1612     my $fks = $self->_table_fk_info($table);
1613
1614     foreach my $fkdef (@$fks) {
1615         for my $col (@{ $fkdef->{local_columns} }) {
1616             $col_info->{$col}{is_foreign_key} = 1;
1617         }
1618     }
1619
1620     my $pks = $self->_table_pk_info($table) || [];
1621
1622     foreach my $pkcol (@$pks) {
1623         $col_info->{$pkcol}{is_nullable} = 0;
1624     }
1625
1626     $self->_dbic_stmt(
1627         $table_class,
1628         'add_columns',
1629         map { $_, ($col_info->{$_}||{}) } @$cols
1630     );
1631
1632     my %uniq_tag; # used to eliminate duplicate uniqs
1633
1634     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1635           : carp("$table has no primary key");
1636     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1637
1638     my $uniqs = $self->_table_uniq_info($table) || [];
1639     for (@$uniqs) {
1640         my ($name, $cols) = @$_;
1641         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1642         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1643     }
1644
1645 }
1646
1647 sub __columns_info_for {
1648     my ($self, $table) = @_;
1649
1650     my $result = $self->_columns_info_for($table);
1651
1652     while (my ($col, $info) = each %$result) {
1653         $info = { %$info, %{ $self->_custom_column_info  ($table, $col, $info) } };
1654         $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1655
1656         $result->{$col} = $info;
1657     }
1658
1659     return $result;
1660 }
1661
1662 =head2 tables
1663
1664 Returns a sorted list of loaded tables, using the original database table
1665 names.
1666
1667 =cut
1668
1669 sub tables {
1670     my $self = shift;
1671
1672     return keys %{$self->_tables};
1673 }
1674
1675 # Make a moniker from a table
1676 sub _default_table2moniker {
1677     no warnings 'uninitialized';
1678     my ($self, $table) = @_;
1679
1680     if ($self->naming->{monikers} eq 'v4') {
1681         return join '', map ucfirst, split /[\W_]+/, lc $table;
1682     }
1683     elsif ($self->naming->{monikers} eq 'v5') {
1684         return join '', map ucfirst, split /[\W_]+/,
1685             Lingua::EN::Inflect::Number::to_S(lc $table);
1686     }
1687     elsif ($self->naming->{monikers} eq 'v6') {
1688         (my $as_phrase = lc $table) =~ s/_+/ /g;
1689         my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1690
1691         return join '', map ucfirst, split /\W+/, $inflected;
1692     }
1693
1694     my @words = map lc, split_name $table;
1695     my $as_phrase = join ' ', @words;
1696
1697     my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1698
1699     return join '', map ucfirst, split /\W+/, $inflected;
1700 }
1701
1702 sub _table2moniker {
1703     my ( $self, $table ) = @_;
1704
1705     my $moniker;
1706
1707     if( ref $self->moniker_map eq 'HASH' ) {
1708         $moniker = $self->moniker_map->{$table};
1709     }
1710     elsif( ref $self->moniker_map eq 'CODE' ) {
1711         $moniker = $self->moniker_map->($table);
1712     }
1713
1714     $moniker ||= $self->_default_table2moniker($table);
1715
1716     return $moniker;
1717 }
1718
1719 sub _load_relationships {
1720     my ($self, $table) = @_;
1721
1722     my $tbl_fk_info = $self->_table_fk_info($table);
1723     foreach my $fkdef (@$tbl_fk_info) {
1724         $fkdef->{remote_source} =
1725             $self->monikers->{delete $fkdef->{remote_table}};
1726     }
1727     my $tbl_uniq_info = $self->_table_uniq_info($table);
1728
1729     my $local_moniker = $self->monikers->{$table};
1730     my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1731
1732     foreach my $src_class (sort keys %$rel_stmts) {
1733         my $src_stmts = $rel_stmts->{$src_class};
1734         foreach my $stmt (@$src_stmts) {
1735             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1736         }
1737     }
1738 }
1739
1740 # Overload these in driver class:
1741
1742 # Returns an arrayref of column names
1743 sub _table_columns { croak "ABSTRACT METHOD" }
1744
1745 # Returns arrayref of pk col names
1746 sub _table_pk_info { croak "ABSTRACT METHOD" }
1747
1748 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1749 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1750
1751 # Returns an arrayref of foreign key constraints, each
1752 #   being a hashref with 3 keys:
1753 #   local_columns (arrayref), remote_columns (arrayref), remote_table
1754 sub _table_fk_info { croak "ABSTRACT METHOD" }
1755
1756 # Returns an array of lower case table names
1757 sub _tables_list { croak "ABSTRACT METHOD" }
1758
1759 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1760 sub _dbic_stmt {
1761     my $self   = shift;
1762     my $class  = shift;
1763     my $method = shift;
1764
1765     # generate the pod for this statement, storing it with $self->_pod
1766     $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
1767
1768     my $args = dump(@_);
1769     $args = '(' . $args . ')' if @_ < 2;
1770     my $stmt = $method . $args . q{;};
1771
1772     warn qq|$class\->$stmt\n| if $self->debug;
1773     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1774     return;
1775 }
1776
1777 # generates the accompanying pod for a DBIC class method statement,
1778 # storing it with $self->_pod
1779 sub _make_pod {
1780     my $self   = shift;
1781     my $class  = shift;
1782     my $method = shift;
1783
1784     if ( $method eq 'table' ) {
1785         my ($table) = @_;
1786         my $pcm = $self->pod_comment_mode;
1787         my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
1788         if ( $self->can('_table_comment') ) {
1789             $comment = $self->_table_comment($table);
1790             $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1791             $comment_in_name   = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1792             $comment_in_desc   = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
1793         }
1794         $self->_pod( $class, "=head1 NAME" );
1795         my $table_descr = $class;
1796         $table_descr .= " - " . $comment if $comment and $comment_in_name;
1797         $self->{_class2table}{ $class } = $table;
1798         $self->_pod( $class, $table_descr );
1799         if ($comment and $comment_in_desc) {
1800             $self->_pod( $class, "=head1 DESCRIPTION" );
1801             $self->_pod( $class, $comment );
1802         }
1803         $self->_pod_cut( $class );
1804     } elsif ( $method eq 'add_columns' ) {
1805         $self->_pod( $class, "=head1 ACCESSORS" );
1806         my $col_counter = 0;
1807         my @cols = @_;
1808         while( my ($name,$attrs) = splice @cols,0,2 ) {
1809             $col_counter++;
1810             $self->_pod( $class, '=head2 ' . $name  );
1811             $self->_pod( $class,
1812                          join "\n", map {
1813                              my $s = $attrs->{$_};
1814                              $s = !defined $s         ? 'undef'          :
1815                                   length($s) == 0     ? '(empty string)' :
1816                                   ref($s) eq 'SCALAR' ? $$s :
1817                                   ref($s)             ? do {
1818                                                         my $dd = Dumper;
1819                                                         $dd->Indent(0);
1820                                                         $dd->Values([$s]);
1821                                                         $dd->Dump;
1822                                                       } :
1823                                   looks_like_number($s) ? $s :
1824                                                         qq{'$s'}
1825                                   ;
1826
1827                              "  $_: $s"
1828                          } sort keys %$attrs,
1829                        );
1830
1831             if( $self->can('_column_comment')
1832                 and my $comment = $self->_column_comment( $self->{_class2table}{$class}, $col_counter)
1833               ) {
1834                 $self->_pod( $class, $comment );
1835             }
1836         }
1837         $self->_pod_cut( $class );
1838     } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1839         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1840         my ( $accessor, $rel_class ) = @_;
1841         $self->_pod( $class, "=head2 $accessor" );
1842         $self->_pod( $class, 'Type: ' . $method );
1843         $self->_pod( $class, "Related object: L<$rel_class>" );
1844         $self->_pod_cut( $class );
1845         $self->{_relations_started} { $class } = 1;
1846     }
1847 }
1848
1849 # Stores a POD documentation
1850 sub _pod {
1851     my ($self, $class, $stmt) = @_;
1852     $self->_raw_stmt( $class, "\n" . $stmt  );
1853 }
1854
1855 sub _pod_cut {
1856     my ($self, $class ) = @_;
1857     $self->_raw_stmt( $class, "\n=cut\n" );
1858 }
1859
1860 # Store a raw source line for a class (for dumping purposes)
1861 sub _raw_stmt {
1862     my ($self, $class, $stmt) = @_;
1863     push(@{$self->{_dump_storage}->{$class}}, $stmt);
1864 }
1865
1866 # Like above, but separately for the externally loaded stuff
1867 sub _ext_stmt {
1868     my ($self, $class, $stmt) = @_;
1869     push(@{$self->{_ext_storage}->{$class}}, $stmt);
1870 }
1871
1872 sub _quote_table_name {
1873     my ($self, $table) = @_;
1874
1875     my $qt = $self->schema->storage->sql_maker->quote_char;
1876
1877     return $table unless $qt;
1878
1879     if (ref $qt) {
1880         return $qt->[0] . $table . $qt->[1];
1881     }
1882
1883     return $qt . $table . $qt;
1884 }
1885
1886 sub _custom_column_info {
1887     my ( $self, $table_name, $column_name, $column_info ) = @_;
1888
1889     if (my $code = $self->custom_column_info) {
1890         return $code->($table_name, $column_name, $column_info) || {};
1891     }
1892     return {};
1893 }
1894
1895 sub _datetime_column_info {
1896     my ( $self, $table_name, $column_name, $column_info ) = @_;
1897     my $result = {};
1898     my $type = $column_info->{data_type} || '';
1899     if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
1900             or ($type =~ /date|timestamp/i)) {
1901         $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
1902         $result->{locale}   = $self->datetime_locale   if $self->datetime_locale;
1903     }
1904     return $result;
1905 }
1906
1907 sub _lc {
1908     my ($self, $name) = @_;
1909
1910     return $self->preserve_case ? $name : lc($name);
1911 }
1912
1913 sub _uc {
1914     my ($self, $name) = @_;
1915
1916     return $self->preserve_case ? $name : uc($name);
1917 }
1918
1919 sub _unregister_source_for_table {
1920     my ($self, $table) = @_;
1921
1922     eval {
1923         local $@;
1924         my $schema = $self->schema;
1925         # in older DBIC it's a private method
1926         my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
1927         $schema->$unregister($self->_table2moniker($table));
1928         delete $self->monikers->{$table};
1929         delete $self->classes->{$table};
1930         delete $self->_upgrading_classes->{$table};
1931         delete $self->{_tables}{$table};
1932     };
1933 }
1934
1935 # remove the dump dir from @INC on destruction
1936 sub DESTROY {
1937     my $self = shift;
1938
1939     @INC = grep $_ ne $self->dump_directory, @INC;
1940 }
1941
1942 =head2 monikers
1943
1944 Returns a hashref of loaded table to moniker mappings.  There will
1945 be two entries for each table, the original name and the "normalized"
1946 name, in the case that the two are different (such as databases
1947 that like uppercase table names, or preserve your original mixed-case
1948 definitions, or what-have-you).
1949
1950 =head2 classes
1951
1952 Returns a hashref of table to class mappings.  In some cases it will
1953 contain multiple entries per table for the original and normalized table
1954 names, as above in L</monikers>.
1955
1956 =head1 SEE ALSO
1957
1958 L<DBIx::Class::Schema::Loader>
1959
1960 =head1 AUTHOR
1961
1962 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1963
1964 =head1 LICENSE
1965
1966 This library is free software; you can redistribute it and/or modify it under
1967 the same terms as Perl itself.
1968
1969 =cut
1970
1971 1;
1972 # vim:et sts=4 sw=4 tw=0: