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