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 Scalar::Util 'looks_like_number';
  20 use File::Slurp 'slurp';
  21 use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed/;
  22 use DBIx::Class::Schema::Loader::Optional::Dependencies ();
  23 use Try::Tiny;
  24 use 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 => 0 },
 263   },
 264
 265 use this to turn off DEFERRABLE on your foreign key constraints.
 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         if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
 549             die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\nYou are missing: %s.\n",
 550                 "Moose, MooseX::NonMoose and namespace::autoclean",
 551                 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
 552         }
 553     }
 554
 555     push(@{$self->{components}}, 'ResultSetManager')
 556         if @{$self->{resultset_components}};
 557
 558     $self->{monikers} = {};
 559     $self->{classes} = {};
 560     $self->{_upgrading_classes} = {};
 561
 562     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
 563     $self->{schema} ||= $self->{schema_class};
 564
 565     croak "dump_overwrite is deprecated.  Please read the"
 566         . " DBIx::Class::Schema::Loader::Base documentation"
 567             if $self->{dump_overwrite};
 568
 569     $self->{dynamic} = ! $self->{dump_directory};
 570     $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
 571                                                      TMPDIR  => 1,
 572                                                      CLEANUP => 1,
 573                                                    );
 574
 575     $self->{dump_directory} ||= $self->{temp_directory};
 576
 577     $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 578     $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 579
 580     if ((not ref $self->naming) && defined $self->naming) {
 581         my $naming_ver = $self->naming;
 582         $self->{naming} = {
 583             relationships => $naming_ver,
 584             monikers => $naming_ver,
 585             column_accessors => $naming_ver,
 586         };
 587     }
 588
 589     if ($self->naming) {
 590         for (values %{ $self->naming }) {
 591             $_ = $CURRENT_V if $_ eq 'current';
 592         }
 593     }
 594     $self->{naming} ||= {};
 595
 596     if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
 597         croak 'custom_column_info must be a CODE ref';
 598     }
 599
 600     $self->_check_back_compat;
 601
 602     $self->use_namespaces(1) unless defined $self->use_namespaces;
 603     $self->generate_pod(1)   unless defined $self->generate_pod;
 604     $self->pod_comment_mode('auto')         unless defined $self->pod_comment_mode;
 605     $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
 606
 607     $self;
 608 }
 609
 610 sub _check_back_compat {
 611     my ($self) = @_;
 612
 613 # dynamic schemas will always be in 0.04006 mode, unless overridden
 614     if ($self->dynamic) {
 615 # just in case, though no one is likely to dump a dynamic schema
 616         $self->schema_version_to_dump('0.04006');
 617
 618         if (not %{ $self->naming }) {
 619             warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 620
 621 Dynamic schema detected, will run in 0.04006 mode.
 622
 623 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 624 to disable this warning.
 625
 626 Also consider setting 'use_namespaces => 1' if/when upgrading.
 627
 628 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 629 details.
 630 EOF
 631         }
 632         else {
 633             $self->_upgrading_from('v4');
 634         }
 635
 636         $self->naming->{relationships} ||= 'v4';
 637         $self->naming->{monikers}      ||= 'v4';
 638
 639         if ($self->use_namespaces) {
 640             $self->_upgrading_from_load_classes(1);
 641         }
 642         else {
 643             $self->use_namespaces(0);
 644         }
 645
 646         return;
 647     }
 648
 649 # otherwise check if we need backcompat mode for a static schema
 650     my $filename = $self->_get_dump_filename($self->schema_class);
 651     return unless -e $filename;
 652
 653     open(my $fh, '<', $filename)
 654         or croak "Cannot open '$filename' for reading: $!";
 655
 656     my $load_classes     = 0;
 657     my $result_namespace = '';
 658
 659     while (<$fh>) {
 660         if (/^__PACKAGE__->load_classes;/) {
 661             $load_classes = 1;
 662         } elsif (/result_namespace => '([^']+)'/) {
 663             $result_namespace = $1;
 664         } elsif (my ($real_ver) =
 665                 /^# Created by DBIx::Class::Schema::Loader v(\d+\.\d+)/) {
 666
 667             if ($load_classes && (not defined $self->use_namespaces)) {
 668                 warn <<"EOF"  unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 669
 670 'load_classes;' static schema detected, turning off 'use_namespaces'.
 671
 672 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
 673 variable to disable this warning.
 674
 675 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 676 details.
 677 EOF
 678                 $self->use_namespaces(0);
 679             }
 680             elsif ($load_classes && $self->use_namespaces) {
 681                 $self->_upgrading_from_load_classes(1);
 682             }
 683             elsif ((not $load_classes) && defined $self->use_namespaces
 684                                        && (not $self->use_namespaces)) {
 685                 $self->_downgrading_to_load_classes(
 686                     $result_namespace || 'Result'
 687                 );
 688             }
 689             elsif ((not defined $self->use_namespaces)
 690                    || $self->use_namespaces) {
 691                 if (not $self->result_namespace) {
 692                     $self->result_namespace($result_namespace || 'Result');
 693                 }
 694                 elsif ($result_namespace ne $self->result_namespace) {
 695                     $self->_rewriting_result_namespace(
 696                         $result_namespace || 'Result'
 697                     );
 698                 }
 699             }
 700
 701             # XXX when we go past .0 this will need fixing
 702             my ($v) = $real_ver =~ /([1-9])/;
 703             $v = "v$v";
 704
 705             last if $v eq $CURRENT_V || $real_ver =~ /^0\.\d\d999/;
 706
 707             if (not %{ $self->naming }) {
 708                 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 709
 710 Version $real_ver static schema detected, turning on backcompat mode.
 711
 712 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 713 to disable this warning.
 714
 715 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
 716
 717 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
 718 from version 0.04006.
 719 EOF
 720             }
 721             else {
 722                 $self->_upgrading_from($v);
 723                 last;
 724             }
 725
 726             $self->naming->{relationships}    ||= $v;
 727             $self->naming->{monikers}         ||= $v;
 728             $self->naming->{column_accessors} ||= $v;
 729
 730             $self->schema_version_to_dump($real_ver);
 731
 732             last;
 733         }
 734     }
 735     close $fh;
 736 }
 737
 738 sub _validate_class_args {
 739     my $self = shift;
 740     my $args = shift;
 741
 742     foreach my $k (@CLASS_ARGS) {
 743         next unless $self->$k;
 744
 745         my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
 746         foreach my $c (@classes) {
 747             # components default to being under the DBIx::Class namespace unless they
 748             # are preceeded with a '+'
 749             if ( $k =~ m/components$/ && $c !~ s/^\+// ) {
 750                 $c = 'DBIx::Class::' . $c;
 751             }
 752
 753             # 1 == installed, 0 == not installed, undef == invalid classname
 754             my $installed = Class::Inspector->installed($c);
 755             if ( defined($installed) ) {
 756                 if ( $installed == 0 ) {
 757                     croak qq/$c, as specified in the loader option "$k", is not installed/;
 758                 }
 759             } else {
 760                 croak qq/$c, as specified in the loader option "$k", is an invalid class name/;
 761             }
 762         }
 763     }
 764 }
 765
 766 sub _find_file_in_inc {
 767     my ($self, $file) = @_;
 768
 769     foreach my $prefix (@INC) {
 770         my $fullpath = File::Spec->catfile($prefix, $file);
 771         return $fullpath if -f $fullpath
 772             # abs_path throws on Windows for nonexistant files
 773             and eval { Cwd::abs_path($fullpath) } ne
 774                (eval { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) } || '');
 775     }
 776
 777     return;
 778 }
 779
 780 sub _class_path {
 781     my ($self, $class) = @_;
 782
 783     my $class_path = $class;
 784     $class_path =~ s{::}{/}g;
 785     $class_path .= '.pm';
 786
 787     return $class_path;
 788 }
 789
 790 sub _find_class_in_inc {
 791     my ($self, $class) = @_;
 792
 793     return $self->_find_file_in_inc($self->_class_path($class));
 794 }
 795
 796 sub _rewriting {
 797     my $self = shift;
 798
 799     return $self->_upgrading_from
 800         || $self->_upgrading_from_load_classes
 801         || $self->_downgrading_to_load_classes
 802         || $self->_rewriting_result_namespace
 803     ;
 804 }
 805
 806 sub _rewrite_old_classnames {
 807     my ($self, $code) = @_;
 808
 809     return $code unless $self->_rewriting;
 810
 811     my %old_classes = reverse %{ $self->_upgrading_classes };
 812
 813     my $re = join '|', keys %old_classes;
 814     $re = qr/\b($re)\b/;
 815
 816     $code =~ s/$re/$old_classes{$1} || $1/eg;
 817
 818     return $code;
 819 }
 820
 821 sub _load_external {
 822     my ($self, $class) = @_;
 823
 824     return if $self->{skip_load_external};
 825
 826     # so that we don't load our own classes, under any circumstances
 827     local *INC = [ grep $_ ne $self->dump_directory, @INC ];
 828
 829     my $real_inc_path = $self->_find_class_in_inc($class);
 830
 831     my $old_class = $self->_upgrading_classes->{$class}
 832         if $self->_rewriting;
 833
 834     my $old_real_inc_path = $self->_find_class_in_inc($old_class)
 835         if $old_class && $old_class ne $class;
 836
 837     return unless $real_inc_path || $old_real_inc_path;
 838
 839     if ($real_inc_path) {
 840         # If we make it to here, we loaded an external definition
 841         warn qq/# Loaded external class definition for '$class'\n/
 842             if $self->debug;
 843
 844         open(my $fh, '<', $real_inc_path)
 845             or croak "Failed to open '$real_inc_path' for reading: $!";
 846         my $code = do { local $/; <$fh> };
 847         close($fh)
 848             or croak "Failed to close $real_inc_path: $!";
 849         $code = $self->_rewrite_old_classnames($code);
 850
 851         if ($self->dynamic) { # load the class too
 852             # kill redefined warnings
 853             my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 854             local $SIG{__WARN__} = sub {
 855                 $warn_handler->(@_)
 856                     unless $_[0] =~ /^Subroutine \S+ redefined/;
 857             };
 858             eval $code;
 859             die $@ if $@;
 860         }
 861
 862         $self->_ext_stmt($class,
 863           qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
 864          .qq|# They are now part of the custom portion of this file\n|
 865          .qq|# for you to hand-edit.  If you do not either delete\n|
 866          .qq|# this section or remove that file from \@INC, this section\n|
 867          .qq|# will be repeated redundantly when you re-create this\n|
 868          .qq|# file again via Loader!  See skip_load_external to disable\n|
 869          .qq|# this feature.\n|
 870         );
 871         chomp $code;
 872         $self->_ext_stmt($class, $code);
 873         $self->_ext_stmt($class,
 874             qq|# End of lines loaded from '$real_inc_path' |
 875         );
 876     }
 877
 878     if ($old_real_inc_path) {
 879         my $code = slurp $old_real_inc_path;
 880
 881         $self->_ext_stmt($class, <<"EOF");
 882
 883 # These lines were loaded from '$old_real_inc_path',
 884 # based on the Result class name that would have been created by an older
 885 # version of the Loader. For a static schema, this happens only once during
 886 # upgrade. See skip_load_external to disable this feature.
 887 EOF
 888
 889         $code = $self->_rewrite_old_classnames($code);
 890
 891         if ($self->dynamic) {
 892             warn <<"EOF";
 893
 894 Detected external content in '$old_real_inc_path', a class name that would have
 895 been used by an older version of the Loader.
 896
 897 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
 898 new name of the Result.
 899 EOF
 900             # kill redefined warnings
 901             my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 902             local $SIG{__WARN__} = sub {
 903                 $warn_handler->(@_)
 904                     unless $_[0] =~ /^Subroutine \S+ redefined/;
 905             };
 906             eval $code;
 907             die $@ if $@;
 908         }
 909
 910         chomp $code;
 911         $self->_ext_stmt($class, $code);
 912         $self->_ext_stmt($class,
 913             qq|# End of lines loaded from '$old_real_inc_path' |
 914         );
 915     }
 916 }
 917
 918 =head2 load
 919
 920 Does the actual schema-construction work.
 921
 922 =cut
 923
 924 sub load {
 925     my $self = shift;
 926
 927     $self->_load_tables(
 928         $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
 929     );
 930 }
 931
 932 =head2 rescan
 933
 934 Arguments: schema
 935
 936 Rescan the database for changes. Returns a list of the newly added table
 937 monikers.
 938
 939 The schema argument should be the schema class or object to be affected.  It
 940 should probably be derived from the original schema_class used during L</load>.
 941
 942 =cut
 943
 944 sub rescan {
 945     my ($self, $schema) = @_;
 946
 947     $self->{schema} = $schema;
 948     $self->_relbuilder->{schema} = $schema;
 949
 950     my @created;
 951     my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
 952
 953     foreach my $table (@current) {
 954         if(!exists $self->{_tables}->{$table}) {
 955             push(@created, $table);
 956         }
 957     }
 958
 959     my %current;
 960     @current{@current} = ();
 961     foreach my $table (keys %{ $self->{_tables} }) {
 962         if (not exists $current{$table}) {
 963             $self->_unregister_source_for_table($table);
 964         }
 965     }
 966
 967     delete $self->{_dump_storage};
 968     delete $self->{_relations_started};
 969
 970     my $loaded = $self->_load_tables(@current);
 971
 972     return map { $self->monikers->{$_} } @created;
 973 }
 974
 975 sub _relbuilder {
 976     no warnings 'uninitialized';
 977     my ($self) = @_;
 978
 979     return if $self->{skip_relationships};
 980
 981     if ($self->naming->{relationships} eq 'v4') {
 982         require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
 983         return $self->{relbuilder} ||=
 984             DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
 985                 $self->schema,
 986                 $self->inflect_plural,
 987                 $self->inflect_singular,
 988                 $self->relationship_attrs,
 989             );
 990     }
 991     elsif ($self->naming->{relationships} eq 'v5') {
 992         require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_05;
 993         return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_05->new (
 994              $self->schema,
 995              $self->inflect_plural,
 996              $self->inflect_singular,
 997              $self->relationship_attrs,
 998         );
 999     }
1000     elsif ($self->naming->{relationships} eq 'v6') {
1001         require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_06;
1002         return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_06->new (
1003              $self->schema,
1004              $self->inflect_plural,
1005              $self->inflect_singular,
1006              $self->relationship_attrs,
1007         );
1008     }
1009
1010     return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new (
1011              $self->schema,
1012              $self->inflect_plural,
1013              $self->inflect_singular,
1014              $self->relationship_attrs,
1015     );
1016 }
1017
1018 sub _load_tables {
1019     my ($self, @tables) = @_;
1020
1021     # Save the new tables to the tables list
1022     foreach (@tables) {
1023         $self->{_tables}->{$_} = 1;
1024     }
1025
1026     $self->_make_src_class($_) for @tables;
1027
1028     # sanity-check for moniker clashes
1029     my $inverse_moniker_idx;
1030     for (keys %{$self->monikers}) {
1031       push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1032     }
1033
1034     my @clashes;
1035     for (keys %$inverse_moniker_idx) {
1036       my $tables = $inverse_moniker_idx->{$_};
1037       if (@$tables > 1) {
1038         push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1039           join (', ', map { "'$_'" } @$tables),
1040           $_,
1041         );
1042       }
1043     }
1044
1045     if (@clashes) {
1046       die   'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1047           . 'Either change the naming style, or supply an explicit moniker_map: '
1048           . join ('; ', @clashes)
1049           . "\n"
1050       ;
1051     }
1052
1053
1054     $self->_setup_src_meta($_) for @tables;
1055
1056     if(!$self->skip_relationships) {
1057         # The relationship loader needs a working schema
1058         $self->{quiet} = 1;
1059         local $self->{dump_directory} = $self->{temp_directory};
1060         $self->_reload_classes(\@tables);
1061         $self->_load_relationships($_) for @tables;
1062         $self->{quiet} = 0;
1063
1064         # Remove that temp dir from INC so it doesn't get reloaded
1065         @INC = grep $_ ne $self->dump_directory, @INC;
1066     }
1067
1068     $self->_load_external($_)
1069         for map { $self->classes->{$_} } @tables;
1070
1071     # Reload without unloading first to preserve any symbols from external
1072     # packages.
1073     $self->_reload_classes(\@tables, 0);
1074
1075     # Drop temporary cache
1076     delete $self->{_cache};
1077
1078     return \@tables;
1079 }
1080
1081 sub _reload_classes {
1082     my ($self, $tables, $unload) = @_;
1083
1084     my @tables = @$tables;
1085     $unload = 1 unless defined $unload;
1086
1087     # so that we don't repeat custom sections
1088     @INC = grep $_ ne $self->dump_directory, @INC;
1089
1090     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1091
1092     unshift @INC, $self->dump_directory;
1093
1094     my @to_register;
1095     my %have_source = map { $_ => $self->schema->source($_) }
1096         $self->schema->sources;
1097
1098     for my $table (@tables) {
1099         my $moniker = $self->monikers->{$table};
1100         my $class = $self->classes->{$table};
1101
1102         {
1103             no warnings 'redefine';
1104             local *Class::C3::reinitialize = sub {};
1105             use warnings;
1106
1107             if ($class->can('meta') && try { $class->meta->isa('Moose::Meta::Class') }) {
1108                 $class->meta->make_mutable;
1109             }
1110             Class::Unload->unload($class) if $unload;
1111             my ($source, $resultset_class);
1112             if (
1113                 ($source = $have_source{$moniker})
1114                 && ($resultset_class = $source->resultset_class)
1115                 && ($resultset_class ne 'DBIx::Class::ResultSet')
1116             ) {
1117                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1118                 if ($resultset_class->can('meta') && try { $resultset_class->meta->isa('Moose::Meta::Class') }) {
1119                     $resultset_class->meta->make_mutable;
1120                 }
1121                 Class::Unload->unload($resultset_class) if $unload;
1122                 $self->_reload_class($resultset_class) if $has_file;
1123             }
1124             $self->_reload_class($class);
1125         }
1126         push @to_register, [$moniker, $class];
1127     }
1128
1129     Class::C3->reinitialize;
1130     for (@to_register) {
1131         $self->schema->register_class(@$_);
1132     }
1133 }
1134
1135 # We use this instead of ensure_class_loaded when there are package symbols we
1136 # want to preserve.
1137 sub _reload_class {
1138     my ($self, $class) = @_;
1139
1140     my $class_path = $self->_class_path($class);
1141     delete $INC{ $class_path };
1142
1143 # kill redefined warnings
1144     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
1145     local $SIG{__WARN__} = sub {
1146         $warn_handler->(@_)
1147             unless $_[0] =~ /^Subroutine \S+ redefined/;
1148     };
1149     eval "require $class;";
1150     die "Failed to reload class $class: $@" if $@;
1151 }
1152
1153 sub _get_dump_filename {
1154     my ($self, $class) = (@_);
1155
1156     $class =~ s{::}{/}g;
1157     return $self->dump_directory . q{/} . $class . q{.pm};
1158 }
1159
1160 sub _ensure_dump_subdirs {
1161     my ($self, $class) = (@_);
1162
1163     my @name_parts = split(/::/, $class);
1164     pop @name_parts; # we don't care about the very last element,
1165                      # which is a filename
1166
1167     my $dir = $self->dump_directory;
1168     while (1) {
1169         if(!-d $dir) {
1170             mkdir($dir) or croak "mkdir('$dir') failed: $!";
1171         }
1172         last if !@name_parts;
1173         $dir = File::Spec->catdir($dir, shift @name_parts);
1174     }
1175 }
1176
1177 sub _dump_to_dir {
1178     my ($self, @classes) = @_;
1179
1180     my $schema_class = $self->schema_class;
1181     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1182
1183     my $target_dir = $self->dump_directory;
1184     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1185         unless $self->{dynamic} or $self->{quiet};
1186
1187     my $schema_text =
1188           qq|package $schema_class;\n\n|
1189         . qq|# Created by DBIx::Class::Schema::Loader\n|
1190         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1191         . qq|use strict;\nuse warnings;\n\n|;
1192     if ($self->use_moose) {
1193         $schema_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1194     }
1195     else {
1196         $schema_text .= qq|use base '$schema_base_class';\n\n|;
1197     }
1198
1199     if ($self->use_namespaces) {
1200         $schema_text .= qq|__PACKAGE__->load_namespaces|;
1201         my $namespace_options;
1202
1203         my @attr = qw/resultset_namespace default_resultset_class/;
1204
1205         unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1206
1207         for my $attr (@attr) {
1208             if ($self->$attr) {
1209                 $namespace_options .= qq|    $attr => '| . $self->$attr . qq|',\n|
1210             }
1211         }
1212         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1213         $schema_text .= qq|;\n|;
1214     }
1215     else {
1216         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1217     }
1218
1219     {
1220         local $self->{version_to_dump} = $self->schema_version_to_dump;
1221         $self->_write_classfile($schema_class, $schema_text, 1);
1222     }
1223
1224     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1225
1226     foreach my $src_class (@classes) {
1227         my $src_text =
1228               qq|package $src_class;\n\n|
1229             . qq|# Created by DBIx::Class::Schema::Loader\n|
1230             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1231             . qq|use strict;\nuse warnings;\n\n|;
1232         if ($self->use_moose) {
1233             $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1234
1235             # these options 'use base' which is compile time
1236             if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1237                 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n\n|;
1238             }
1239             else {
1240                 $src_text .= qq|\nextends '$result_base_class';\n\n|;
1241             }
1242         }
1243         else {
1244              $src_text .= qq|use base '$result_base_class';\n\n|;
1245         }
1246         $self->_write_classfile($src_class, $src_text);
1247     }
1248
1249     # remove Result dir if downgrading from use_namespaces, and there are no
1250     # files left.
1251     if (my $result_ns = $self->_downgrading_to_load_classes
1252                         || $self->_rewriting_result_namespace) {
1253         my $result_namespace = $self->_result_namespace(
1254             $schema_class,
1255             $result_ns,
1256         );
1257
1258         (my $result_dir = $result_namespace) =~ s{::}{/}g;
1259         $result_dir = $self->dump_directory . '/' . $result_dir;
1260
1261         unless (my @files = glob "$result_dir/*") {
1262             rmdir $result_dir;
1263         }
1264     }
1265
1266     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1267
1268 }
1269
1270 sub _sig_comment {
1271     my ($self, $version, $ts) = @_;
1272     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1273          . qq| v| . $version
1274          . q| @ | . $ts
1275          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1276 }
1277
1278 sub _write_classfile {
1279     my ($self, $class, $text, $is_schema) = @_;
1280
1281     my $filename = $self->_get_dump_filename($class);
1282     $self->_ensure_dump_subdirs($class);
1283
1284     if (-f $filename && $self->really_erase_my_files) {
1285         warn "Deleting existing file '$filename' due to "
1286             . "'really_erase_my_files' setting\n" unless $self->{quiet};
1287         unlink($filename);
1288     }
1289
1290     my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
1291
1292     # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1293     # If there is already custom content, which does not have the Moose content, add it.
1294     if ($self->use_moose) {
1295         local $self->{use_moose} = 0;
1296
1297         if ($custom_content eq $self->_default_custom_content) {
1298             local $self->{use_moose} = 1;
1299
1300             $custom_content = $self->_default_custom_content;
1301         }
1302         else {
1303             local $self->{use_moose} = 1;
1304
1305             if ($custom_content !~ /\Q@{[$self->_default_moose_custom_content]}\E/) {
1306                 $custom_content .= $self->_default_custom_content;
1307             }
1308         }
1309     }
1310
1311     if (my $old_class = $self->_upgrading_classes->{$class}) {
1312         my $old_filename = $self->_get_dump_filename($old_class);
1313
1314         my ($old_custom_content) = $self->_get_custom_content(
1315             $old_class, $old_filename, 0 # do not add default comment
1316         );
1317
1318         $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
1319
1320         if ($old_custom_content) {
1321             $custom_content =
1322                 "\n" . $old_custom_content . "\n" . $custom_content;
1323         }
1324
1325         unlink $old_filename;
1326     }
1327
1328     $custom_content = $self->_rewrite_old_classnames($custom_content);
1329
1330     $text .= qq|$_\n|
1331         for @{$self->{_dump_storage}->{$class} || []};
1332
1333     # Check and see if the dump is infact differnt
1334
1335     my $compare_to;
1336     if ($old_md5) {
1337       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1338
1339
1340       if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1341         return unless $self->_upgrading_from && $is_schema;
1342       }
1343     }
1344
1345     $text .= $self->_sig_comment(
1346       $self->version_to_dump,
1347       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1348     );
1349
1350     open(my $fh, '>', $filename)
1351         or croak "Cannot open '$filename' for writing: $!";
1352
1353     # Write the top half and its MD5 sum
1354     print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1355
1356     # Write out anything loaded via external partial class file in @INC
1357     print $fh qq|$_\n|
1358         for @{$self->{_ext_storage}->{$class} || []};
1359
1360     # Write out any custom content the user has added
1361     print $fh $custom_content;
1362
1363     close($fh)
1364         or croak "Error closing '$filename': $!";
1365 }
1366
1367 sub _default_moose_custom_content {
1368     return qq|\n__PACKAGE__->meta->make_immutable;|;
1369 }
1370
1371 sub _default_custom_content {
1372     my $self = shift;
1373     my $default = qq|\n\n# You can replace this text with custom|
1374          . qq| content, and it will be preserved on regeneration|;
1375     if ($self->use_moose) {
1376         $default .= $self->_default_moose_custom_content;
1377     }
1378     $default .= qq|\n1;\n|;
1379     return $default;
1380 }
1381
1382 sub _get_custom_content {
1383     my ($self, $class, $filename, $add_default) = @_;
1384
1385     $add_default = 1 unless defined $add_default;
1386
1387     return ($self->_default_custom_content) if ! -f $filename;
1388
1389     open(my $fh, '<', $filename)
1390         or croak "Cannot open '$filename' for reading: $!";
1391
1392     my $mark_re =
1393         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1394
1395     my $buffer = '';
1396     my ($md5, $ts, $ver);
1397     while(<$fh>) {
1398         if(!$md5 && /$mark_re/) {
1399             $md5 = $2;
1400             my $line = $1;
1401
1402             # Pull out the previous version and timestamp
1403             ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
1404
1405             $buffer .= $line;
1406             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"
1407                 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
1408
1409             $buffer = '';
1410         }
1411         else {
1412             $buffer .= $_;
1413         }
1414     }
1415
1416     croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
1417         . " it does not appear to have been generated by Loader"
1418             if !$md5;
1419
1420     # Default custom content:
1421     $buffer ||= $self->_default_custom_content if $add_default;
1422
1423     return ($buffer, $md5, $ver, $ts);
1424 }
1425
1426 sub _use {
1427     my $self = shift;
1428     my $target = shift;
1429
1430     foreach (@_) {
1431         warn "$target: use $_;" if $self->debug;
1432         $self->_raw_stmt($target, "use $_;");
1433     }
1434 }
1435
1436 sub _inject {
1437     my $self = shift;
1438     my $target = shift;
1439
1440     my $blist = join(q{ }, @_);
1441
1442     return unless $blist;
1443
1444     warn "$target: use base qw/$blist/;" if $self->debug;
1445     $self->_raw_stmt($target, "use base qw/$blist/;");
1446 }
1447
1448 sub _result_namespace {
1449     my ($self, $schema_class, $ns) = @_;
1450     my @result_namespace;
1451
1452     if ($ns =~ /^\+(.*)/) {
1453         # Fully qualified namespace
1454         @result_namespace = ($1)
1455     }
1456     else {
1457         # Relative namespace
1458         @result_namespace = ($schema_class, $ns);
1459     }
1460
1461     return wantarray ? @result_namespace : join '::', @result_namespace;
1462 }
1463
1464 # Create class with applicable bases, setup monikers, etc
1465 sub _make_src_class {
1466     my ($self, $table) = @_;
1467
1468     my $schema       = $self->schema;
1469     my $schema_class = $self->schema_class;
1470
1471     my $table_moniker = $self->_table2moniker($table);
1472     my @result_namespace = ($schema_class);
1473     if ($self->use_namespaces) {
1474         my $result_namespace = $self->result_namespace || 'Result';
1475         @result_namespace = $self->_result_namespace(
1476             $schema_class,
1477             $result_namespace,
1478         );
1479     }
1480     my $table_class = join(q{::}, @result_namespace, $table_moniker);
1481
1482     if ((my $upgrading_v = $self->_upgrading_from)
1483             || $self->_rewriting) {
1484         local $self->naming->{monikers} = $upgrading_v
1485             if $upgrading_v;
1486
1487         my @result_namespace = @result_namespace;
1488         if ($self->_upgrading_from_load_classes) {
1489             @result_namespace = ($schema_class);
1490         }
1491         elsif (my $ns = $self->_downgrading_to_load_classes) {
1492             @result_namespace = $self->_result_namespace(
1493                 $schema_class,
1494                 $ns,
1495             );
1496         }
1497         elsif ($ns = $self->_rewriting_result_namespace) {
1498             @result_namespace = $self->_result_namespace(
1499                 $schema_class,
1500                 $ns,
1501             );
1502         }
1503
1504         my $old_class = join(q{::}, @result_namespace,
1505             $self->_table2moniker($table));
1506
1507         $self->_upgrading_classes->{$table_class} = $old_class
1508             unless $table_class eq $old_class;
1509     }
1510
1511 # this was a bad idea, should be ok now without it
1512 #    my $table_normalized = lc $table;
1513 #    $self->classes->{$table_normalized} = $table_class;
1514 #    $self->monikers->{$table_normalized} = $table_moniker;
1515
1516     $self->classes->{$table} = $table_class;
1517     $self->monikers->{$table} = $table_moniker;
1518
1519     $self->_use   ($table_class, @{$self->additional_classes});
1520     $self->_inject($table_class, @{$self->left_base_classes});
1521
1522     if (my @components = @{ $self->components }) {
1523         $self->_dbic_stmt($table_class, 'load_components', @components);
1524     }
1525
1526     $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1527         if @{$self->resultset_components};
1528     $self->_inject($table_class, @{$self->additional_base_classes});
1529 }
1530
1531 sub _resolve_col_accessor_collisions {
1532     my ($self, $col_info) = @_;
1533
1534     my $base       = $self->result_base_class || 'DBIx::Class::Core';
1535     my @components = map "DBIx::Class::$_", @{ $self->components || [] };
1536
1537     my @methods;
1538
1539     for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) {
1540         eval "require ${class};";
1541         die $@ if $@;
1542
1543         push @methods, @{ Class::Inspector->methods($class) || [] };
1544     }
1545
1546     my %methods;
1547     @methods{@methods} = ();
1548
1549     # futureproof meta
1550     $methods{meta} = undef;
1551
1552     while (my ($col, $info) = each %$col_info) {
1553         my $accessor = $info->{accessor} || $col;
1554
1555         next if $accessor eq 'id'; # special case (very common column)
1556
1557         if (exists $methods{$accessor}) {
1558             $info->{accessor} = undef;
1559         }
1560     }
1561 }
1562
1563 sub _make_column_accessor_name {
1564     my ($self, $column_name) = @_;
1565
1566     return join '_', map lc, split_name $column_name;
1567 }
1568
1569 # Set up metadata (cols, pks, etc)
1570 sub _setup_src_meta {
1571     my ($self, $table) = @_;
1572
1573     my $schema       = $self->schema;
1574     my $schema_class = $self->schema_class;
1575
1576     my $table_class = $self->classes->{$table};
1577     my $table_moniker = $self->monikers->{$table};
1578
1579     my $table_name = $table;
1580     my $name_sep   = $self->schema->storage->sql_maker->name_sep;
1581
1582     if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1583         $table_name = \ $self->_quote_table_name($table_name);
1584     }
1585
1586     my $full_table_name = ($self->qualify_objects ? ($self->db_schema . '.') : '') . (ref $table_name ? $$table_name : $table_name);
1587
1588     # be careful to not create refs Data::Dump can "optimize"
1589     $full_table_name    = \do {"".$full_table_name} if ref $table_name;
1590
1591     $self->_dbic_stmt($table_class, 'table', $full_table_name);
1592
1593     my $cols = $self->_table_columns($table);
1594     my $col_info = $self->__columns_info_for($table);
1595
1596     while (my ($col, $info) = each %$col_info) {
1597         if ($col =~ /\W/) {
1598             ($info->{accessor} = $col) =~ s/\W+/_/g;
1599         }
1600     }
1601
1602     if ($self->preserve_case) {
1603         while (my ($col, $info) = each %$col_info) {
1604             if ($col ne lc($col)) {
1605                 if ((not exists $self->naming->{column_accessors}) || (($self->naming->{column_accessors} =~ /(\d+)/)[0] >= 7)) {
1606                     $info->{accessor} = $self->_make_column_accessor_name($info->{accessor} || $col);
1607                 }
1608                 else {
1609                     $info->{accessor} = lc($info->{accessor} || $col);
1610                 }
1611             }
1612         }
1613     }
1614     else {
1615         # XXX this needs to go away
1616         $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1617     }
1618
1619     $self->_resolve_col_accessor_collisions($col_info);
1620
1621     my $fks = $self->_table_fk_info($table);
1622
1623     foreach my $fkdef (@$fks) {
1624         for my $col (@{ $fkdef->{local_columns} }) {
1625             $col_info->{$col}{is_foreign_key} = 1;
1626         }
1627     }
1628
1629     my $pks = $self->_table_pk_info($table) || [];
1630
1631     foreach my $pkcol (@$pks) {
1632         $col_info->{$pkcol}{is_nullable} = 0;
1633     }
1634
1635     $self->_dbic_stmt(
1636         $table_class,
1637         'add_columns',
1638         map { $_, ($col_info->{$_}||{}) } @$cols
1639     );
1640
1641     my %uniq_tag; # used to eliminate duplicate uniqs
1642
1643     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1644           : carp("$table has no primary key");
1645     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1646
1647     my $uniqs = $self->_table_uniq_info($table) || [];
1648     for (@$uniqs) {
1649         my ($name, $cols) = @$_;
1650         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1651         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1652     }
1653
1654 }
1655
1656 sub __columns_info_for {
1657     my ($self, $table) = @_;
1658
1659     my $result = $self->_columns_info_for($table);
1660
1661     while (my ($col, $info) = each %$result) {
1662         $info = { %$info, %{ $self->_custom_column_info  ($table, $col, $info) } };
1663         $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1664
1665         $result->{$col} = $info;
1666     }
1667
1668     return $result;
1669 }
1670
1671 =head2 tables
1672
1673 Returns a sorted list of loaded tables, using the original database table
1674 names.
1675
1676 =cut
1677
1678 sub tables {
1679     my $self = shift;
1680
1681     return keys %{$self->_tables};
1682 }
1683
1684 # Make a moniker from a table
1685 sub _default_table2moniker {
1686     no warnings 'uninitialized';
1687     my ($self, $table) = @_;
1688
1689     if ($self->naming->{monikers} eq 'v4') {
1690         return join '', map ucfirst, split /[\W_]+/, lc $table;
1691     }
1692     elsif ($self->naming->{monikers} eq 'v5') {
1693         return join '', map ucfirst, split /[\W_]+/,
1694             Lingua::EN::Inflect::Number::to_S(lc $table);
1695     }
1696     elsif ($self->naming->{monikers} eq 'v6') {
1697         (my $as_phrase = lc $table) =~ s/_+/ /g;
1698         my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1699
1700         return join '', map ucfirst, split /\W+/, $inflected;
1701     }
1702
1703     my @words = map lc, split_name $table;
1704     my $as_phrase = join ' ', @words;
1705
1706     my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1707
1708     return join '', map ucfirst, split /\W+/, $inflected;
1709 }
1710
1711 sub _table2moniker {
1712     my ( $self, $table ) = @_;
1713
1714     my $moniker;
1715
1716     if( ref $self->moniker_map eq 'HASH' ) {
1717         $moniker = $self->moniker_map->{$table};
1718     }
1719     elsif( ref $self->moniker_map eq 'CODE' ) {
1720         $moniker = $self->moniker_map->($table);
1721     }
1722
1723     $moniker ||= $self->_default_table2moniker($table);
1724
1725     return $moniker;
1726 }
1727
1728 sub _load_relationships {
1729     my ($self, $table) = @_;
1730
1731     my $tbl_fk_info = $self->_table_fk_info($table);
1732     foreach my $fkdef (@$tbl_fk_info) {
1733         $fkdef->{remote_source} =
1734             $self->monikers->{delete $fkdef->{remote_table}};
1735     }
1736     my $tbl_uniq_info = $self->_table_uniq_info($table);
1737
1738     my $local_moniker = $self->monikers->{$table};
1739     my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1740
1741     foreach my $src_class (sort keys %$rel_stmts) {
1742         my $src_stmts = $rel_stmts->{$src_class};
1743         foreach my $stmt (@$src_stmts) {
1744             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1745         }
1746     }
1747 }
1748
1749 # Overload these in driver class:
1750
1751 # Returns an arrayref of column names
1752 sub _table_columns { croak "ABSTRACT METHOD" }
1753
1754 # Returns arrayref of pk col names
1755 sub _table_pk_info { croak "ABSTRACT METHOD" }
1756
1757 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1758 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1759
1760 # Returns an arrayref of foreign key constraints, each
1761 #   being a hashref with 3 keys:
1762 #   local_columns (arrayref), remote_columns (arrayref), remote_table
1763 sub _table_fk_info { croak "ABSTRACT METHOD" }
1764
1765 # Returns an array of lower case table names
1766 sub _tables_list { croak "ABSTRACT METHOD" }
1767
1768 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1769 sub _dbic_stmt {
1770     my $self   = shift;
1771     my $class  = shift;
1772     my $method = shift;
1773
1774     # generate the pod for this statement, storing it with $self->_pod
1775     $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
1776
1777     my $args = dump(@_);
1778     $args = '(' . $args . ')' if @_ < 2;
1779     my $stmt = $method . $args . q{;};
1780
1781     warn qq|$class\->$stmt\n| if $self->debug;
1782     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1783     return;
1784 }
1785
1786 # generates the accompanying pod for a DBIC class method statement,
1787 # storing it with $self->_pod
1788 sub _make_pod {
1789     my $self   = shift;
1790     my $class  = shift;
1791     my $method = shift;
1792
1793     if ( $method eq 'table' ) {
1794         my ($table) = @_;
1795         my $pcm = $self->pod_comment_mode;
1796         my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
1797         $comment = $self->__table_comment($table);
1798         $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1799         $comment_in_name   = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1800         $comment_in_desc   = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
1801         $self->_pod( $class, "=head1 NAME" );
1802         my $table_descr = $class;
1803         $table_descr .= " - " . $comment if $comment and $comment_in_name;
1804         $self->{_class2table}{ $class } = $table;
1805         $self->_pod( $class, $table_descr );
1806         if ($comment and $comment_in_desc) {
1807             $self->_pod( $class, "=head1 DESCRIPTION" );
1808             $self->_pod( $class, $comment );
1809         }
1810         $self->_pod_cut( $class );
1811     } elsif ( $method eq 'add_columns' ) {
1812         $self->_pod( $class, "=head1 ACCESSORS" );
1813         my $col_counter = 0;
1814         my @cols = @_;
1815         while( my ($name,$attrs) = splice @cols,0,2 ) {
1816             $col_counter++;
1817             $self->_pod( $class, '=head2 ' . $name  );
1818             $self->_pod( $class,
1819                          join "\n", map {
1820                              my $s = $attrs->{$_};
1821                              $s = !defined $s         ? 'undef'          :
1822                                   length($s) == 0     ? '(empty string)' :
1823                                   ref($s) eq 'SCALAR' ? $$s :
1824                                   ref($s)             ? dumper_squashed $s :
1825                                   looks_like_number($s) ? $s :
1826                                                         qq{'$s'}
1827                                   ;
1828
1829                              "  $_: $s"
1830                          } sort keys %$attrs,
1831                        );
1832
1833             if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter)) {
1834                 $self->_pod( $class, $comment );
1835             }
1836         }
1837         $self->_pod_cut( $class );
1838     } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1839         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1840         my ( $accessor, $rel_class ) = @_;
1841         $self->_pod( $class, "=head2 $accessor" );
1842         $self->_pod( $class, 'Type: ' . $method );
1843         $self->_pod( $class, "Related object: L<$rel_class>" );
1844         $self->_pod_cut( $class );
1845         $self->{_relations_started} { $class } = 1;
1846     }
1847 }
1848
1849 sub _filter_comment {
1850     my ($self, $txt) = @_;
1851
1852     $txt = '' if not defined $txt;
1853
1854     $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
1855
1856     return $txt;
1857 }
1858
1859 sub __table_comment {
1860     my $self = shift;
1861
1862     if (my $code = $self->can('_table_comment')) {
1863         return $self->_filter_comment($self->$code(@_));
1864     }
1865
1866     return '';
1867 }
1868
1869 sub __column_comment {
1870     my $self = shift;
1871
1872     if (my $code = $self->can('_column_comment')) {
1873         return $self->_filter_comment($self->$code(@_));
1874     }
1875
1876     return '';
1877 }
1878
1879 # Stores a POD documentation
1880 sub _pod {
1881     my ($self, $class, $stmt) = @_;
1882     $self->_raw_stmt( $class, "\n" . $stmt  );
1883 }
1884
1885 sub _pod_cut {
1886     my ($self, $class ) = @_;
1887     $self->_raw_stmt( $class, "\n=cut\n" );
1888 }
1889
1890 # Store a raw source line for a class (for dumping purposes)
1891 sub _raw_stmt {
1892     my ($self, $class, $stmt) = @_;
1893     push(@{$self->{_dump_storage}->{$class}}, $stmt);
1894 }
1895
1896 # Like above, but separately for the externally loaded stuff
1897 sub _ext_stmt {
1898     my ($self, $class, $stmt) = @_;
1899     push(@{$self->{_ext_storage}->{$class}}, $stmt);
1900 }
1901
1902 sub _quote_table_name {
1903     my ($self, $table) = @_;
1904
1905     my $qt = $self->schema->storage->sql_maker->quote_char;
1906
1907     return $table unless $qt;
1908
1909     if (ref $qt) {
1910         return $qt->[0] . $table . $qt->[1];
1911     }
1912
1913     return $qt . $table . $qt;
1914 }
1915
1916 sub _custom_column_info {
1917     my ( $self, $table_name, $column_name, $column_info ) = @_;
1918
1919     if (my $code = $self->custom_column_info) {
1920         return $code->($table_name, $column_name, $column_info) || {};
1921     }
1922     return {};
1923 }
1924
1925 sub _datetime_column_info {
1926     my ( $self, $table_name, $column_name, $column_info ) = @_;
1927     my $result = {};
1928     my $type = $column_info->{data_type} || '';
1929     if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
1930             or ($type =~ /date|timestamp/i)) {
1931         $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
1932         $result->{locale}   = $self->datetime_locale   if $self->datetime_locale;
1933     }
1934     return $result;
1935 }
1936
1937 sub _lc {
1938     my ($self, $name) = @_;
1939
1940     return $self->preserve_case ? $name : lc($name);
1941 }
1942
1943 sub _uc {
1944     my ($self, $name) = @_;
1945
1946     return $self->preserve_case ? $name : uc($name);
1947 }
1948
1949 sub _unregister_source_for_table {
1950     my ($self, $table) = @_;
1951
1952     eval {
1953         local $@;
1954         my $schema = $self->schema;
1955         # in older DBIC it's a private method
1956         my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
1957         $schema->$unregister($self->_table2moniker($table));
1958         delete $self->monikers->{$table};
1959         delete $self->classes->{$table};
1960         delete $self->_upgrading_classes->{$table};
1961         delete $self->{_tables}{$table};
1962     };
1963 }
1964
1965 # remove the dump dir from @INC on destruction
1966 sub DESTROY {
1967     my $self = shift;
1968
1969     @INC = grep $_ ne $self->dump_directory, @INC;
1970 }
1971
1972 =head2 monikers
1973
1974 Returns a hashref of loaded table to moniker mappings.  There will
1975 be two entries for each table, the original name and the "normalized"
1976 name, in the case that the two are different (such as databases
1977 that like uppercase table names, or preserve your original mixed-case
1978 definitions, or what-have-you).
1979
1980 =head2 classes
1981
1982 Returns a hashref of table to class mappings.  In some cases it will
1983 contain multiple entries per table for the original and normalized table
1984 names, as above in L</monikers>.
1985
1986 =head1 SEE ALSO
1987
1988 L<DBIx::Class::Schema::Loader>
1989
1990 =head1 AUTHOR
1991
1992 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1993
1994 =head1 LICENSE
1995
1996 This library is free software; you can redistribute it and/or modify it under
1997 the same terms as Perl itself.
1998
1999 =cut
2000
2001 1;
2002 # vim:et sts=4 sw=4 tw=0: