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 File::Temp qw//;
  16 use Class::Unload;
  17 require DBIx::Class;
  18
  19 our $VERSION = '0.04999_12';
  20
  21 __PACKAGE__->mk_group_ro_accessors('simple', qw/
  22                                 schema
  23                                 schema_class
  24
  25                                 exclude
  26                                 constraint
  27                                 additional_classes
  28                                 additional_base_classes
  29                                 left_base_classes
  30                                 components
  31                                 resultset_components
  32                                 skip_relationships
  33                                 skip_load_external
  34                                 moniker_map
  35                                 inflect_singular
  36                                 inflect_plural
  37                                 debug
  38                                 dump_directory
  39                                 dump_overwrite
  40                                 really_erase_my_files
  41                                 use_namespaces
  42                                 result_namespace
  43                                 resultset_namespace
  44                                 default_resultset_class
  45                                 schema_base_class
  46                                 result_base_class
  47                                 overwrite_modifications
  48
  49                                 db_schema
  50                                 _tables
  51                                 classes
  52                                 _upgrading_classes
  53                                 monikers
  54                                 dynamic
  55                                 naming
  56 /);
  57
  58
  59 __PACKAGE__->mk_group_accessors('simple', qw/
  60                                 version_to_dump
  61                                 schema_version_to_dump
  62                                 _upgrading_from
  63 /);
  64
  65 =head1 NAME
  66
  67 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
  68
  69 =head1 SYNOPSIS
  70
  71 See L<DBIx::Class::Schema::Loader>
  72
  73 =head1 DESCRIPTION
  74
  75 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
  76 classes, and implements the common functionality between them.
  77
  78 =head1 CONSTRUCTOR OPTIONS
  79
  80 These constructor options are the base options for
  81 L<DBIx::Class::Schema::Loader/loader_options>.  Available constructor options are:
  82
  83 =head2 skip_relationships
  84
  85 Skip setting up relationships.  The default is to attempt the loading
  86 of relationships.
  87
  88 =head2 skip_load_external
  89
  90 Skip loading of other classes in @INC. The default is to merge all other classes
  91 with the same name found in @INC into the schema file we are creating.
  92
  93 =head2 naming
  94
  95 Static schemas (ones dumped to disk) will, by default, use the new-style 0.05XXX
  96 relationship names and singularized Results, unless you're overwriting an
  97 existing dump made by a 0.04XXX version of L<DBIx::Class::Schema::Loader>, in
  98 which case the backward compatible RelBuilder will be activated, and
  99 singularization will be turned off.
 100
 101 Specifying
 102
 103     naming => 'v5'
 104
 105 will disable the backward-compatible RelBuilder and use
 106 the new-style relationship names along with singularized Results, even when
 107 overwriting a dump made with an earlier version.
 108
 109 The option also takes a hashref:
 110
 111     naming => { relationships => 'v5', monikers => 'v4' }
 112
 113 The keys are:
 114
 115 =over 4
 116
 117 =item relationships
 118
 119 How to name relationship accessors.
 120
 121 =item monikers
 122
 123 How to name Result classes.
 124
 125 =back
 126
 127 The values can be:
 128
 129 =over 4
 130
 131 =item current
 132
 133 Latest default style, whatever that happens to be.
 134
 135 =item v5
 136
 137 Version 0.05XXX style.
 138
 139 =item v4
 140
 141 Version 0.04XXX style.
 142
 143 =back
 144
 145 Dynamic schemas will always default to the 0.04XXX relationship names and won't
 146 singularize Results for backward compatibility, to activate the new RelBuilder
 147 and singularization put this in your C<Schema.pm> file:
 148
 149     __PACKAGE__->naming('current');
 150
 151 Or if you prefer to use 0.05XXX features but insure that nothing breaks in the
 152 next major version upgrade:
 153
 154     __PACKAGE__->naming('v5');
 155
 156 =head2 debug
 157
 158 If set to true, each constructive L<DBIx::Class> statement the loader
 159 decides to execute will be C<warn>-ed before execution.
 160
 161 =head2 db_schema
 162
 163 Set the name of the schema to load (schema in the sense that your database
 164 vendor means it).  Does not currently support loading more than one schema
 165 name.
 166
 167 =head2 constraint
 168
 169 Only load tables matching regex.  Best specified as a qr// regex.
 170
 171 =head2 exclude
 172
 173 Exclude tables matching regex.  Best specified as a qr// regex.
 174
 175 =head2 moniker_map
 176
 177 Overrides the default table name to moniker translation.  Can be either
 178 a hashref of table keys and moniker values, or a coderef for a translator
 179 function taking a single scalar table name argument and returning
 180 a scalar moniker.  If the hash entry does not exist, or the function
 181 returns a false value, the code falls back to default behavior
 182 for that table name.
 183
 184 The default behavior is to singularize the table name, and: C<join '', map
 185 ucfirst, split /[\W_]+/, lc $table>, which is to say: lowercase everything,
 186 split up the table name into chunks anywhere a non-alpha-numeric character
 187 occurs, change the case of first letter of each chunk to upper case, and put
 188 the chunks back together.  Examples:
 189
 190     Table Name  | Moniker Name
 191     ---------------------------
 192     luser       | Luser
 193     luser_group | LuserGroup
 194     luser-opts  | LuserOpts
 195
 196 =head2 inflect_plural
 197
 198 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
 199 if hash key does not exist or coderef returns false), but acts as a map
 200 for pluralizing relationship names.  The default behavior is to utilize
 201 L<Lingua::EN::Inflect::Number/to_PL>.
 202
 203 =head2 inflect_singular
 204
 205 As L</inflect_plural> above, but for singularizing relationship names.
 206 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
 207
 208 =head2 schema_base_class
 209
 210 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
 211
 212 =head2 result_base_class
 213
 214 Base class for your table classes (aka result classes). Defaults to
 215 'DBIx::Class::Core'.
 216
 217 =head2 additional_base_classes
 218
 219 List of additional base classes all of your table classes will use.
 220
 221 =head2 left_base_classes
 222
 223 List of additional base classes all of your table classes will use
 224 that need to be leftmost.
 225
 226 =head2 additional_classes
 227
 228 List of additional classes which all of your table classes will use.
 229
 230 =head2 components
 231
 232 List of additional components to be loaded into all of your table
 233 classes.  A good example would be C<ResultSetManager>.
 234
 235 =head2 resultset_components
 236
 237 List of additional ResultSet components to be loaded into your table
 238 classes.  A good example would be C<AlwaysRS>.  Component
 239 C<ResultSetManager> will be automatically added to the above
 240 C<components> list if this option is set.
 241
 242 =head2 use_namespaces
 243
 244 Generate result class names suitable for
 245 L<DBIx::Class::Schema/load_namespaces> and call that instead of
 246 L<DBIx::Class::Schema/load_classes>. When using this option you can also
 247 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
 248 C<resultset_namespace>, C<default_resultset_class>), and they will be added
 249 to the call (and the generated result class names adjusted appropriately).
 250
 251 =head2 dump_directory
 252
 253 This option is designed to be a tool to help you transition from this
 254 loader to a manually-defined schema when you decide it's time to do so.
 255
 256 The value of this option is a perl libdir pathname.  Within
 257 that directory this module will create a baseline manual
 258 L<DBIx::Class::Schema> module set, based on what it creates at runtime
 259 in memory.
 260
 261 The created schema class will have the same classname as the one on
 262 which you are setting this option (and the ResultSource classes will be
 263 based on this name as well).
 264
 265 Normally you wouldn't hard-code this setting in your schema class, as it
 266 is meant for one-time manual usage.
 267
 268 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
 269 recommended way to access this functionality.
 270
 271 =head2 dump_overwrite
 272
 273 Deprecated.  See L</really_erase_my_files> below, which does *not* mean
 274 the same thing as the old C<dump_overwrite> setting from previous releases.
 275
 276 =head2 really_erase_my_files
 277
 278 Default false.  If true, Loader will unconditionally delete any existing
 279 files before creating the new ones from scratch when dumping a schema to disk.
 280
 281 The default behavior is instead to only replace the top portion of the
 282 file, up to and including the final stanza which contains
 283 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
 284 leaving any customizations you placed after that as they were.
 285
 286 When C<really_erase_my_files> is not set, if the output file already exists,
 287 but the aforementioned final stanza is not found, or the checksum
 288 contained there does not match the generated contents, Loader will
 289 croak and not touch the file.
 290
 291 You should really be using version control on your schema classes (and all
 292 of the rest of your code for that matter).  Don't blame me if a bug in this
 293 code wipes something out when it shouldn't have, you've been warned.
 294
 295 =head2 overwrite_modifications
 296
 297 Default false.  If false, when updating existing files, Loader will
 298 refuse to modify any Loader-generated code that has been modified
 299 since its last run (as determined by the checksum Loader put in its
 300 comment lines).
 301
 302 If true, Loader will discard any manual modifications that have been
 303 made to Loader-generated code.
 304
 305 Again, you should be using version control on your schema classes.  Be
 306 careful with this option.
 307
 308 =head1 METHODS
 309
 310 None of these methods are intended for direct invocation by regular
 311 users of L<DBIx::Class::Schema::Loader>.  Anything you can find here
 312 can also be found via standard L<DBIx::Class::Schema> methods somehow.
 313
 314 =cut
 315
 316 use constant CURRENT_V => 'v5';
 317
 318 # ensure that a peice of object data is a valid arrayref, creating
 319 # an empty one or encapsulating whatever's there.
 320 sub _ensure_arrayref {
 321     my $self = shift;
 322
 323     foreach (@_) {
 324         $self->{$_} ||= [];
 325         $self->{$_} = [ $self->{$_} ]
 326             unless ref $self->{$_} eq 'ARRAY';
 327     }
 328 }
 329
 330 =head2 new
 331
 332 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
 333 by L<DBIx::Class::Schema::Loader>.
 334
 335 =cut
 336
 337 sub new {
 338     my ( $class, %args ) = @_;
 339
 340     my $self = { %args };
 341
 342     bless $self => $class;
 343
 344     $self->_ensure_arrayref(qw/additional_classes
 345                                additional_base_classes
 346                                left_base_classes
 347                                components
 348                                resultset_components
 349                               /);
 350
 351     push(@{$self->{components}}, 'ResultSetManager')
 352         if @{$self->{resultset_components}};
 353
 354     $self->{monikers} = {};
 355     $self->{classes} = {};
 356     $self->{_upgrading_classes} = {};
 357
 358     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
 359     $self->{schema} ||= $self->{schema_class};
 360
 361     croak "dump_overwrite is deprecated.  Please read the"
 362         . " DBIx::Class::Schema::Loader::Base documentation"
 363             if $self->{dump_overwrite};
 364
 365     $self->{dynamic} = ! $self->{dump_directory};
 366     $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
 367                                                      TMPDIR  => 1,
 368                                                      CLEANUP => 1,
 369                                                    );
 370
 371     $self->{dump_directory} ||= $self->{temp_directory};
 372
 373     $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 374     $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 375
 376     if ((not ref $self->naming) && defined $self->naming) {
 377         my $naming_ver = $self->naming;
 378         $self->{naming} = {
 379             relationships => $naming_ver,
 380             monikers => $naming_ver,
 381         };
 382     }
 383
 384     if ($self->naming) {
 385         for (values %{ $self->naming }) {
 386             $_ = CURRENT_V if $_ eq 'current';
 387         }
 388     }
 389     $self->{naming} ||= {};
 390
 391     $self->_check_back_compat;
 392
 393     $self;
 394 }
 395
 396 sub _check_back_compat {
 397     my ($self) = @_;
 398
 399 # dynamic schemas will always be in 0.04006 mode, unless overridden
 400     if ($self->dynamic) {
 401 # just in case, though no one is likely to dump a dynamic schema
 402         $self->schema_version_to_dump('0.04006');
 403
 404         if (not %{ $self->naming }) {
 405             warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 406
 407 Dynamic schema detected, will run in 0.04006 mode.
 408
 409 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 410 to disable this warning.
 411
 412 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 413 details.
 414 EOF
 415         }
 416         else {
 417             $self->_upgrading_from('v4');
 418         }
 419
 420         $self->naming->{relationships} ||= 'v4';
 421         $self->naming->{monikers}      ||= 'v4';
 422
 423         return;
 424     }
 425
 426 # otherwise check if we need backcompat mode for a static schema
 427     my $filename = $self->_get_dump_filename($self->schema_class);
 428     return unless -e $filename;
 429
 430     open(my $fh, '<', $filename)
 431         or croak "Cannot open '$filename' for reading: $!";
 432
 433     while (<$fh>) {
 434         if (/^# Created by DBIx::Class::Schema::Loader v((\d+)\.(\d+))/) {
 435             my $real_ver = $1;
 436
 437             # XXX when we go past .0 this will need fixing
 438             my ($v) = $real_ver =~ /([1-9])/;
 439             $v = "v$v";
 440
 441             last if $v eq CURRENT_V || $real_ver =~ /^0\.04999/;
 442
 443             if (not %{ $self->naming }) {
 444                 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 445
 446 Version $real_ver static schema detected, turning on backcompat mode.
 447
 448 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 449 to disable this warning.
 450
 451 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 452 details.
 453 EOF
 454             }
 455             else {
 456                 $self->_upgrading_from($v);
 457             }
 458
 459             $self->naming->{relationships} ||= $v;
 460             $self->naming->{monikers}      ||= $v;
 461
 462             $self->schema_version_to_dump($real_ver);
 463
 464             last;
 465         }
 466     }
 467     close $fh;
 468 }
 469
 470 sub _find_file_in_inc {
 471     my ($self, $file) = @_;
 472
 473     foreach my $prefix (@INC) {
 474         my $fullpath = File::Spec->catfile($prefix, $file);
 475         return $fullpath if -f $fullpath
 476             and Cwd::abs_path($fullpath) ne
 477                (Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || '');
 478     }
 479
 480     return;
 481 }
 482
 483 sub _class_path {
 484     my ($self, $class) = @_;
 485
 486     my $class_path = $class;
 487     $class_path =~ s{::}{/}g;
 488     $class_path .= '.pm';
 489
 490     return $class_path;
 491 }
 492
 493 sub _find_class_in_inc {
 494     my ($self, $class) = @_;
 495
 496     return $self->_find_file_in_inc($self->_class_path($class));
 497 }
 498
 499 sub _load_external {
 500     my ($self, $class) = @_;
 501
 502     return if $self->{skip_load_external};
 503
 504     # so that we don't load our own classes, under any circumstances
 505     local *INC = [ grep $_ ne $self->dump_directory, @INC ];
 506
 507     my $real_inc_path = $self->_find_class_in_inc($class);
 508
 509     my $old_class = $self->_upgrading_classes->{$class}
 510         if $self->_upgrading_from;
 511
 512     my $old_real_inc_path = $self->_find_class_in_inc($old_class)
 513         if $old_class && $old_class ne $class;
 514
 515     return unless $real_inc_path || $old_real_inc_path;
 516
 517     if ($real_inc_path) {
 518         # If we make it to here, we loaded an external definition
 519         warn qq/# Loaded external class definition for '$class'\n/
 520             if $self->debug;
 521
 522         open(my $fh, '<', $real_inc_path)
 523             or croak "Failed to open '$real_inc_path' for reading: $!";
 524         $self->_ext_stmt($class,
 525           qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
 526          .qq|# They are now part of the custom portion of this file\n|
 527          .qq|# for you to hand-edit.  If you do not either delete\n|
 528          .qq|# this section or remove that file from \@INC, this section\n|
 529          .qq|# will be repeated redundantly when you re-create this\n|
 530          .qq|# file again via Loader!\n|
 531         );
 532         while(<$fh>) {
 533             chomp;
 534             $self->_ext_stmt($class, $_);
 535         }
 536         $self->_ext_stmt($class,
 537             qq|# End of lines loaded from '$real_inc_path' |
 538         );
 539         close($fh)
 540             or croak "Failed to close $real_inc_path: $!";
 541
 542         if ($self->dynamic) { # load the class too
 543             # kill redefined warnings
 544             my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 545             local $SIG{__WARN__} = sub {
 546                 $warn_handler->(@_)
 547                     unless $_[0] =~ /^Subroutine \S+ redefined/;
 548             };
 549             do $real_inc_path;
 550             die $@ if $@;
 551         }
 552     }
 553
 554     if ($old_real_inc_path) {
 555         open(my $fh, '<', $old_real_inc_path)
 556             or croak "Failed to open '$old_real_inc_path' for reading: $!";
 557         $self->_ext_stmt($class, <<"EOF");
 558
 559 # These lines were loaded from '$old_real_inc_path', based on the Result class
 560 # name that would have been created by an 0.04006 version of the Loader. For a
 561 # static schema, this happens only once during upgrade.
 562 EOF
 563         if ($self->dynamic) {
 564             warn <<"EOF";
 565
 566 Detected external content in '$old_real_inc_path', a class name that would have
 567 been used by an 0.04006 version of the Loader.
 568
 569 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
 570 new name of the Result.
 571 EOF
 572             # kill redefined warnings
 573             my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 574             local $SIG{__WARN__} = sub {
 575                 $warn_handler->(@_)
 576                     unless $_[0] =~ /^Subroutine \S+ redefined/;
 577             };
 578             my $code = do {
 579                 local ($/, @ARGV) = (undef, $old_real_inc_path); <>
 580             };
 581             $code =~ s/$old_class/$class/g;
 582             eval $code;
 583             die $@ if $@;
 584         }
 585
 586         while(<$fh>) {
 587             chomp;
 588             $self->_ext_stmt($class, $_);
 589         }
 590         $self->_ext_stmt($class,
 591             qq|# End of lines loaded from '$old_real_inc_path' |
 592         );
 593
 594         close($fh)
 595             or croak "Failed to close $old_real_inc_path: $!";
 596     }
 597 }
 598
 599 =head2 load
 600
 601 Does the actual schema-construction work.
 602
 603 =cut
 604
 605 sub load {
 606     my $self = shift;
 607
 608     $self->_load_tables($self->_tables_list);
 609 }
 610
 611 =head2 rescan
 612
 613 Arguments: schema
 614
 615 Rescan the database for newly added tables.  Does
 616 not process drops or changes.  Returns a list of
 617 the newly added table monikers.
 618
 619 The schema argument should be the schema class
 620 or object to be affected.  It should probably
 621 be derived from the original schema_class used
 622 during L</load>.
 623
 624 =cut
 625
 626 sub rescan {
 627     my ($self, $schema) = @_;
 628
 629     $self->{schema} = $schema;
 630     $self->_relbuilder->{schema} = $schema;
 631
 632     my @created;
 633     my @current = $self->_tables_list;
 634     foreach my $table ($self->_tables_list) {
 635         if(!exists $self->{_tables}->{$table}) {
 636             push(@created, $table);
 637         }
 638     }
 639
 640     my $loaded = $self->_load_tables(@created);
 641
 642     return map { $self->monikers->{$_} } @$loaded;
 643 }
 644
 645 sub _relbuilder {
 646     no warnings 'uninitialized';
 647     my ($self) = @_;
 648
 649     return if $self->{skip_relationships};
 650
 651     if ($self->naming->{relationships} eq 'v4') {
 652         require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
 653         return $self->{relbuilder} ||=
 654             DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
 655                 $self->schema, $self->inflect_plural, $self->inflect_singular
 656             );
 657     }
 658
 659     $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new(
 660         $self->schema, $self->inflect_plural, $self->inflect_singular
 661     );
 662 }
 663
 664 sub _load_tables {
 665     my ($self, @tables) = @_;
 666
 667     # First, use _tables_list with constraint and exclude
 668     #  to get a list of tables to operate on
 669
 670     my $constraint   = $self->constraint;
 671     my $exclude      = $self->exclude;
 672
 673     @tables = grep { /$constraint/ } @tables if $constraint;
 674     @tables = grep { ! /$exclude/ } @tables if $exclude;
 675
 676     # Save the new tables to the tables list
 677     foreach (@tables) {
 678         $self->{_tables}->{$_} = 1;
 679     }
 680
 681     $self->_make_src_class($_) for @tables;
 682     $self->_setup_src_meta($_) for @tables;
 683
 684     if(!$self->skip_relationships) {
 685         # The relationship loader needs a working schema
 686         $self->{quiet} = 1;
 687         local $self->{dump_directory} = $self->{temp_directory};
 688         $self->_reload_classes(\@tables);
 689         $self->_load_relationships($_) for @tables;
 690         $self->{quiet} = 0;
 691
 692         # Remove that temp dir from INC so it doesn't get reloaded
 693         @INC = grep $_ ne $self->dump_directory, @INC;
 694     }
 695
 696     $self->_load_external($_)
 697         for map { $self->classes->{$_} } @tables;
 698
 699     # Reload without unloading first to preserve any symbols from external
 700     # packages.
 701     $self->_reload_classes(\@tables, 0);
 702
 703     # Drop temporary cache
 704     delete $self->{_cache};
 705
 706     return \@tables;
 707 }
 708
 709 sub _reload_classes {
 710     my ($self, $tables, $unload) = @_;
 711
 712     my @tables = @$tables;
 713     $unload = 1 unless defined $unload;
 714
 715     # so that we don't repeat custom sections
 716     @INC = grep $_ ne $self->dump_directory, @INC;
 717
 718     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
 719
 720     unshift @INC, $self->dump_directory;
 721
 722     my @to_register;
 723     my %have_source = map { $_ => $self->schema->source($_) }
 724         $self->schema->sources;
 725
 726     for my $table (@tables) {
 727         my $moniker = $self->monikers->{$table};
 728         my $class = $self->classes->{$table};
 729
 730         {
 731             no warnings 'redefine';
 732             local *Class::C3::reinitialize = sub {};
 733             use warnings;
 734
 735             Class::Unload->unload($class) if $unload;
 736             my ($source, $resultset_class);
 737             if (
 738                 ($source = $have_source{$moniker})
 739                 && ($resultset_class = $source->resultset_class)
 740                 && ($resultset_class ne 'DBIx::Class::ResultSet')
 741             ) {
 742                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
 743                 Class::Unload->unload($resultset_class) if $unload;
 744                 $self->_reload_class($resultset_class) if $has_file;
 745             }
 746             $self->_reload_class($class);
 747         }
 748         push @to_register, [$moniker, $class];
 749     }
 750
 751     Class::C3->reinitialize;
 752     for (@to_register) {
 753         $self->schema->register_class(@$_);
 754     }
 755 }
 756
 757 # We use this instead of ensure_class_loaded when there are package symbols we
 758 # want to preserve.
 759 sub _reload_class {
 760     my ($self, $class) = @_;
 761
 762     my $class_path = $self->_class_path($class);
 763     delete $INC{ $class_path };
 764
 765 # kill redefined warnings
 766     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 767     local $SIG{__WARN__} = sub {
 768         $warn_handler->(@_)
 769             unless $_[0] =~ /^Subroutine \S+ redefined/;
 770     };
 771     eval "require $class;";
 772 }
 773
 774 sub _get_dump_filename {
 775     my ($self, $class) = (@_);
 776
 777     $class =~ s{::}{/}g;
 778     return $self->dump_directory . q{/} . $class . q{.pm};
 779 }
 780
 781 sub _ensure_dump_subdirs {
 782     my ($self, $class) = (@_);
 783
 784     my @name_parts = split(/::/, $class);
 785     pop @name_parts; # we don't care about the very last element,
 786                      # which is a filename
 787
 788     my $dir = $self->dump_directory;
 789     while (1) {
 790         if(!-d $dir) {
 791             mkdir($dir) or croak "mkdir('$dir') failed: $!";
 792         }
 793         last if !@name_parts;
 794         $dir = File::Spec->catdir($dir, shift @name_parts);
 795     }
 796 }
 797
 798 sub _dump_to_dir {
 799     my ($self, @classes) = @_;
 800
 801     my $schema_class = $self->schema_class;
 802     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
 803
 804     my $target_dir = $self->dump_directory;
 805     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
 806         unless $self->{dynamic} or $self->{quiet};
 807
 808     my $schema_text =
 809           qq|package $schema_class;\n\n|
 810         . qq|# Created by DBIx::Class::Schema::Loader\n|
 811         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
 812         . qq|use strict;\nuse warnings;\n\n|
 813         . qq|use base '$schema_base_class';\n\n|;
 814
 815     if ($self->use_namespaces) {
 816         $schema_text .= qq|__PACKAGE__->load_namespaces|;
 817         my $namespace_options;
 818         for my $attr (qw(result_namespace
 819                          resultset_namespace
 820                          default_resultset_class)) {
 821             if ($self->$attr) {
 822                 $namespace_options .= qq|    $attr => '| . $self->$attr . qq|',\n|
 823             }
 824         }
 825         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
 826         $schema_text .= qq|;\n|;
 827     }
 828     else {
 829         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
 830     }
 831
 832     {
 833         local $self->{version_to_dump} = $self->schema_version_to_dump;
 834         $self->_write_classfile($schema_class, $schema_text);
 835     }
 836
 837     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
 838
 839     foreach my $src_class (@classes) {
 840         my $src_text =
 841               qq|package $src_class;\n\n|
 842             . qq|# Created by DBIx::Class::Schema::Loader\n|
 843             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
 844             . qq|use strict;\nuse warnings;\n\n|
 845             . qq|use base '$result_base_class';\n\n|;
 846
 847         $self->_write_classfile($src_class, $src_text);
 848     }
 849
 850     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
 851
 852 }
 853
 854 sub _sig_comment {
 855     my ($self, $version, $ts) = @_;
 856     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
 857          . qq| v| . $version
 858          . q| @ | . $ts
 859          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
 860 }
 861
 862 sub _write_classfile {
 863     my ($self, $class, $text) = @_;
 864
 865     my $filename = $self->_get_dump_filename($class);
 866     $self->_ensure_dump_subdirs($class);
 867
 868     if (-f $filename && $self->really_erase_my_files) {
 869         warn "Deleting existing file '$filename' due to "
 870             . "'really_erase_my_files' setting\n" unless $self->{quiet};
 871         unlink($filename);
 872     }
 873
 874     my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
 875
 876     if ($self->_upgrading_from) {
 877         my $old_class = $self->_upgrading_classes->{$class};
 878
 879         if ($old_class && ($old_class ne $class)) {
 880             my $old_filename = $self->_get_dump_filename($old_class);
 881
 882             my ($old_custom_content) = $self->_get_custom_content(
 883                 $old_class, $old_filename, 0 # do not add default comment
 884             );
 885
 886             $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
 887
 888             if ($old_custom_content) {
 889                 $custom_content =
 890                     "\n" . $old_custom_content . "\n" . $custom_content;
 891             }
 892
 893             unlink $old_filename;
 894         }
 895     }
 896
 897     $text .= qq|$_\n|
 898         for @{$self->{_dump_storage}->{$class} || []};
 899
 900     # Check and see if the dump is infact differnt
 901
 902     my $compare_to;
 903     if ($old_md5) {
 904       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
 905
 906
 907       if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
 908         return;
 909       }
 910     }
 911
 912     $text .= $self->_sig_comment(
 913       $self->version_to_dump,
 914       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
 915     );
 916
 917     open(my $fh, '>', $filename)
 918         or croak "Cannot open '$filename' for writing: $!";
 919
 920     # Write the top half and its MD5 sum
 921     print $fh $text . Digest::MD5::md5_base64($text) . "\n";
 922
 923     # Write out anything loaded via external partial class file in @INC
 924     print $fh qq|$_\n|
 925         for @{$self->{_ext_storage}->{$class} || []};
 926
 927     # Write out any custom content the user has added
 928     print $fh $custom_content;
 929
 930     close($fh)
 931         or croak "Error closing '$filename': $!";
 932 }
 933
 934 sub _default_custom_content {
 935     return qq|\n\n# You can replace this text with custom|
 936          . qq| content, and it will be preserved on regeneration|
 937          . qq|\n1;\n|;
 938 }
 939
 940 sub _get_custom_content {
 941     my ($self, $class, $filename, $add_default) = @_;
 942
 943     $add_default = 1 unless defined $add_default;
 944
 945     return ($self->_default_custom_content) if ! -f $filename;
 946
 947     open(my $fh, '<', $filename)
 948         or croak "Cannot open '$filename' for reading: $!";
 949
 950     my $mark_re =
 951         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
 952
 953     my $buffer = '';
 954     my ($md5, $ts, $ver);
 955     while(<$fh>) {
 956         if(!$md5 && /$mark_re/) {
 957             $md5 = $2;
 958             my $line = $1;
 959
 960             # Pull out the previous version and timestamp
 961             ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
 962
 963             $buffer .= $line;
 964             croak "Checksum mismatch in '$filename'"
 965                 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
 966
 967             $buffer = '';
 968         }
 969         else {
 970             $buffer .= $_;
 971         }
 972     }
 973
 974     croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
 975         . " it does not appear to have been generated by Loader"
 976             if !$md5;
 977
 978     # Default custom content:
 979     $buffer ||= $self->_default_custom_content if $add_default;
 980
 981     return ($buffer, $md5, $ver, $ts);
 982 }
 983
 984 sub _use {
 985     my $self = shift;
 986     my $target = shift;
 987
 988     foreach (@_) {
 989         warn "$target: use $_;" if $self->debug;
 990         $self->_raw_stmt($target, "use $_;");
 991     }
 992 }
 993
 994 sub _inject {
 995     my $self = shift;
 996     my $target = shift;
 997     my $schema_class = $self->schema_class;
 998
 999     my $blist = join(q{ }, @_);
1000     warn "$target: use base qw/ $blist /;" if $self->debug && @_;
1001     $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
1002 }
1003
1004 # Create class with applicable bases, setup monikers, etc
1005 sub _make_src_class {
1006     my ($self, $table) = @_;
1007
1008     my $schema       = $self->schema;
1009     my $schema_class = $self->schema_class;
1010
1011     my $table_moniker = $self->_table2moniker($table);
1012     my @result_namespace = ($schema_class);
1013     if ($self->use_namespaces) {
1014         my $result_namespace = $self->result_namespace || 'Result';
1015         if ($result_namespace =~ /^\+(.*)/) {
1016             # Fully qualified namespace
1017             @result_namespace =  ($1)
1018         }
1019         else {
1020             # Relative namespace
1021             push @result_namespace, $result_namespace;
1022         }
1023     }
1024     my $table_class = join(q{::}, @result_namespace, $table_moniker);
1025
1026     if (my $upgrading_v = $self->_upgrading_from) {
1027         local $self->naming->{monikers} = $upgrading_v;
1028
1029         my $old_class = join(q{::}, @result_namespace,
1030             $self->_table2moniker($table));
1031
1032         $self->_upgrading_classes->{$table_class} = $old_class;
1033     }
1034
1035     my $table_normalized = lc $table;
1036     $self->classes->{$table} = $table_class;
1037     $self->classes->{$table_normalized} = $table_class;
1038     $self->monikers->{$table} = $table_moniker;
1039     $self->monikers->{$table_normalized} = $table_moniker;
1040
1041     $self->_use   ($table_class, @{$self->additional_classes});
1042     $self->_inject($table_class, @{$self->left_base_classes});
1043
1044     if (my @components = @{ $self->components }) {
1045         $self->_dbic_stmt($table_class, 'load_components', @components);
1046     }
1047
1048     $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1049         if @{$self->resultset_components};
1050     $self->_inject($table_class, @{$self->additional_base_classes});
1051 }
1052
1053 # Set up metadata (cols, pks, etc)
1054 sub _setup_src_meta {
1055     my ($self, $table) = @_;
1056
1057     my $schema       = $self->schema;
1058     my $schema_class = $self->schema_class;
1059
1060     my $table_class = $self->classes->{$table};
1061     my $table_moniker = $self->monikers->{$table};
1062
1063     my $table_name = $table;
1064     my $name_sep   = $self->schema->storage->sql_maker->name_sep;
1065
1066     if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1067         $table_name = \ $self->_quote_table_name($table_name);
1068     }
1069
1070     $self->_dbic_stmt($table_class,'table',$table_name);
1071
1072     my $cols = $self->_table_columns($table);
1073     my $col_info;
1074     eval { $col_info = $self->_columns_info_for($table) };
1075     if($@) {
1076         $self->_dbic_stmt($table_class,'add_columns',@$cols);
1077     }
1078     else {
1079         if ($self->_is_case_sensitive) {
1080             for my $col (keys %$col_info) {
1081                 $col_info->{$col}{accessor} = lc $col
1082                     if $col ne lc($col);
1083             }
1084         } else {
1085             $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1086         }
1087
1088         my $fks = $self->_table_fk_info($table);
1089
1090         for my $fkdef (@$fks) {
1091             for my $col (@{ $fkdef->{local_columns} }) {
1092                 $col_info->{$col}{is_foreign_key} = 1;
1093             }
1094         }
1095         $self->_dbic_stmt(
1096             $table_class,
1097             'add_columns',
1098             map { $_, ($col_info->{$_}||{}) } @$cols
1099         );
1100     }
1101
1102     my %uniq_tag; # used to eliminate duplicate uniqs
1103
1104     my $pks = $self->_table_pk_info($table) || [];
1105     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1106           : carp("$table has no primary key");
1107     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1108
1109     my $uniqs = $self->_table_uniq_info($table) || [];
1110     for (@$uniqs) {
1111         my ($name, $cols) = @$_;
1112         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1113         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1114     }
1115
1116 }
1117
1118 =head2 tables
1119
1120 Returns a sorted list of loaded tables, using the original database table
1121 names.
1122
1123 =cut
1124
1125 sub tables {
1126     my $self = shift;
1127
1128     return keys %{$self->_tables};
1129 }
1130
1131 # Make a moniker from a table
1132 sub _default_table2moniker {
1133     no warnings 'uninitialized';
1134     my ($self, $table) = @_;
1135
1136     if ($self->naming->{monikers} eq 'v4') {
1137         return join '', map ucfirst, split /[\W_]+/, lc $table;
1138     }
1139
1140     return join '', map ucfirst, split /[\W_]+/,
1141         Lingua::EN::Inflect::Number::to_S(lc $table);
1142 }
1143
1144 sub _table2moniker {
1145     my ( $self, $table ) = @_;
1146
1147     my $moniker;
1148
1149     if( ref $self->moniker_map eq 'HASH' ) {
1150         $moniker = $self->moniker_map->{$table};
1151     }
1152     elsif( ref $self->moniker_map eq 'CODE' ) {
1153         $moniker = $self->moniker_map->($table);
1154     }
1155
1156     $moniker ||= $self->_default_table2moniker($table);
1157
1158     return $moniker;
1159 }
1160
1161 sub _load_relationships {
1162     my ($self, $table) = @_;
1163
1164     my $tbl_fk_info = $self->_table_fk_info($table);
1165     foreach my $fkdef (@$tbl_fk_info) {
1166         $fkdef->{remote_source} =
1167             $self->monikers->{delete $fkdef->{remote_table}};
1168     }
1169     my $tbl_uniq_info = $self->_table_uniq_info($table);
1170
1171     my $local_moniker = $self->monikers->{$table};
1172     my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1173
1174     foreach my $src_class (sort keys %$rel_stmts) {
1175         my $src_stmts = $rel_stmts->{$src_class};
1176         foreach my $stmt (@$src_stmts) {
1177             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1178         }
1179     }
1180 }
1181
1182 # Overload these in driver class:
1183
1184 # Returns an arrayref of column names
1185 sub _table_columns { croak "ABSTRACT METHOD" }
1186
1187 # Returns arrayref of pk col names
1188 sub _table_pk_info { croak "ABSTRACT METHOD" }
1189
1190 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1191 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1192
1193 # Returns an arrayref of foreign key constraints, each
1194 #   being a hashref with 3 keys:
1195 #   local_columns (arrayref), remote_columns (arrayref), remote_table
1196 sub _table_fk_info { croak "ABSTRACT METHOD" }
1197
1198 # Returns an array of lower case table names
1199 sub _tables_list { croak "ABSTRACT METHOD" }
1200
1201 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1202 sub _dbic_stmt {
1203     my $self = shift;
1204     my $class = shift;
1205     my $method = shift;
1206     if ( $method eq 'table' ) {
1207         my ($table) = @_;
1208         $self->_pod( $class, "=head1 NAME" );
1209         my $table_descr = $class;
1210         if ( $self->can('_table_comment') ) {
1211             my $comment = $self->_table_comment($table);
1212             $table_descr .= " - " . $comment if $comment;
1213         }
1214         $self->{_class2table}{ $class } = $table;
1215         $self->_pod( $class, $table_descr );
1216         $self->_pod_cut( $class );
1217     } elsif ( $method eq 'add_columns' ) {
1218         $self->_pod( $class, "=head1 ACCESSORS" );
1219         my $i = 0;
1220         foreach ( @_ ) {
1221             $i++;
1222             next unless $i % 2;
1223             $self->_pod( $class, '=head2 ' . $_  );
1224             my $comment;
1225             $comment = $self->_column_comment( $self->{_class2table}{$class}, ($i - 1) / 2 + 1  ) if $self->can('_column_comment');
1226             $self->_pod( $class, $comment ) if $comment;
1227         }
1228         $self->_pod_cut( $class );
1229     } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1230         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1231         my ( $accessor, $rel_class ) = @_;
1232         $self->_pod( $class, "=head2 $accessor" );
1233         $self->_pod( $class, 'Type: ' . $method );
1234         $self->_pod( $class, "Related object: L<$rel_class>" );
1235         $self->_pod_cut( $class );
1236         $self->{_relations_started} { $class } = 1;
1237     }
1238     my $args = dump(@_);
1239     $args = '(' . $args . ')' if @_ < 2;
1240     my $stmt = $method . $args . q{;};
1241
1242     warn qq|$class\->$stmt\n| if $self->debug;
1243     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1244     return;
1245 }
1246
1247 # Stores a POD documentation
1248 sub _pod {
1249     my ($self, $class, $stmt) = @_;
1250     $self->_raw_stmt( $class, "\n" . $stmt  );
1251 }
1252
1253 sub _pod_cut {
1254     my ($self, $class ) = @_;
1255     $self->_raw_stmt( $class, "\n=cut\n" );
1256 }
1257
1258
1259 # Store a raw source line for a class (for dumping purposes)
1260 sub _raw_stmt {
1261     my ($self, $class, $stmt) = @_;
1262     push(@{$self->{_dump_storage}->{$class}}, $stmt);
1263 }
1264
1265 # Like above, but separately for the externally loaded stuff
1266 sub _ext_stmt {
1267     my ($self, $class, $stmt) = @_;
1268     push(@{$self->{_ext_storage}->{$class}}, $stmt);
1269 }
1270
1271 sub _quote_table_name {
1272     my ($self, $table) = @_;
1273
1274     my $qt = $self->schema->storage->sql_maker->quote_char;
1275
1276     return $table unless $qt;
1277
1278     if (ref $qt) {
1279         return $qt->[0] . $table . $qt->[1];
1280     }
1281
1282     return $qt . $table . $qt;
1283 }
1284
1285 sub _is_case_sensitive { 0 }
1286
1287 # remove the dump dir from @INC on destruction
1288 sub DESTROY {
1289     my $self = shift;
1290
1291     @INC = grep $_ ne $self->dump_directory, @INC;
1292 }
1293
1294 =head2 monikers
1295
1296 Returns a hashref of loaded table to moniker mappings.  There will
1297 be two entries for each table, the original name and the "normalized"
1298 name, in the case that the two are different (such as databases
1299 that like uppercase table names, or preserve your original mixed-case
1300 definitions, or what-have-you).
1301
1302 =head2 classes
1303
1304 Returns a hashref of table to class mappings.  In some cases it will
1305 contain multiple entries per table for the original and normalized table
1306 names, as above in L</monikers>.
1307
1308 =head1 SEE ALSO
1309
1310 L<DBIx::Class::Schema::Loader>
1311
1312 =head1 AUTHOR
1313
1314 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1315
1316 =head1 LICENSE
1317
1318 This library is free software; you can redistribute it and/or modify it under
1319 the same terms as Perl itself.
1320
1321 =cut
1322
1323 1;