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