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