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