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