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