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

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