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