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