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