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

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