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