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

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