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