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

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