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 use Class::Inspector ();
  18 require DBIx::Class;
  19
  20 our $VERSION = '0.05001';
  21
  22 __PACKAGE__->mk_group_ro_accessors('simple', qw/
  23                                 schema
  24                                 schema_class
  25
  26                                 exclude
  27                                 constraint
  28                                 additional_classes
  29                                 additional_base_classes
  30                                 left_base_classes
  31                                 components
  32                                 resultset_components
  33                                 skip_relationships
  34                                 skip_load_external
  35                                 moniker_map
  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 use constant CLASS_ARGS => qw(
 393     schema_base_class result_base_class additional_base_classes
 394     left_base_classes additional_classes components resultset_components
 395 );
 396
 397 # ensure that a peice of object data is a valid arrayref, creating
 398 # an empty one or encapsulating whatever's there.
 399 sub _ensure_arrayref {
 400     my $self = shift;
 401
 402     foreach (@_) {
 403         $self->{$_} ||= [];
 404         $self->{$_} = [ $self->{$_} ]
 405             unless ref $self->{$_} eq 'ARRAY';
 406     }
 407 }
 408
 409 =head2 new
 410
 411 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
 412 by L<DBIx::Class::Schema::Loader>.
 413
 414 =cut
 415
 416 sub new {
 417     my ( $class, %args ) = @_;
 418
 419     my $self = { %args };
 420
 421     bless $self => $class;
 422
 423     $self->_ensure_arrayref(qw/additional_classes
 424                                additional_base_classes
 425                                left_base_classes
 426                                components
 427                                resultset_components
 428                               /);
 429
 430     $self->_validate_class_args;
 431
 432     push(@{$self->{components}}, 'ResultSetManager')
 433         if @{$self->{resultset_components}};
 434
 435     $self->{monikers} = {};
 436     $self->{classes} = {};
 437     $self->{_upgrading_classes} = {};
 438
 439     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
 440     $self->{schema} ||= $self->{schema_class};
 441
 442     croak "dump_overwrite is deprecated.  Please read the"
 443         . " DBIx::Class::Schema::Loader::Base documentation"
 444             if $self->{dump_overwrite};
 445
 446     $self->{dynamic} = ! $self->{dump_directory};
 447     $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
 448                                                      TMPDIR  => 1,
 449                                                      CLEANUP => 1,
 450                                                    );
 451
 452     $self->{dump_directory} ||= $self->{temp_directory};
 453
 454     $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 455     $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 456
 457     if ((not ref $self->naming) && defined $self->naming) {
 458         my $naming_ver = $self->naming;
 459         $self->{naming} = {
 460             relationships => $naming_ver,
 461             monikers => $naming_ver,
 462         };
 463     }
 464
 465     if ($self->naming) {
 466         for (values %{ $self->naming }) {
 467             $_ = CURRENT_V if $_ eq 'current';
 468         }
 469     }
 470     $self->{naming} ||= {};
 471
 472     $self->_check_back_compat;
 473
 474     $self->use_namespaces(1) unless defined $self->use_namespaces;
 475     $self->generate_pod(1)   unless defined $self->generate_pod;
 476     $self->pod_comment_mode('auto')         unless defined $self->pod_comment_mode;
 477     $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
 478
 479     $self;
 480 }
 481
 482 sub _check_back_compat {
 483     my ($self) = @_;
 484
 485 # dynamic schemas will always be in 0.04006 mode, unless overridden
 486     if ($self->dynamic) {
 487 # just in case, though no one is likely to dump a dynamic schema
 488         $self->schema_version_to_dump('0.04006');
 489
 490         if (not %{ $self->naming }) {
 491             warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 492
 493 Dynamic schema detected, will run in 0.04006 mode.
 494
 495 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 496 to disable this warning.
 497
 498 Also consider setting 'use_namespaces => 1' if/when upgrading.
 499
 500 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 501 details.
 502 EOF
 503         }
 504         else {
 505             $self->_upgrading_from('v4');
 506         }
 507
 508         $self->naming->{relationships} ||= 'v4';
 509         $self->naming->{monikers}      ||= 'v4';
 510
 511         if ($self->use_namespaces) {
 512             $self->_upgrading_from_load_classes(1);
 513         }
 514         else {
 515             $self->use_namespaces(0);
 516         }
 517
 518         return;
 519     }
 520
 521 # otherwise check if we need backcompat mode for a static schema
 522     my $filename = $self->_get_dump_filename($self->schema_class);
 523     return unless -e $filename;
 524
 525     open(my $fh, '<', $filename)
 526         or croak "Cannot open '$filename' for reading: $!";
 527
 528     my $load_classes     = 0;
 529     my $result_namespace = '';
 530
 531     while (<$fh>) {
 532         if (/^__PACKAGE__->load_classes;/) {
 533             $load_classes = 1;
 534         } elsif (/result_namespace => '([^']+)'/) {
 535             $result_namespace = $1;
 536         } elsif (my ($real_ver) =
 537                 /^# Created by DBIx::Class::Schema::Loader v(\d+\.\d+)/) {
 538
 539             if ($load_classes && (not defined $self->use_namespaces)) {
 540                 warn <<"EOF"  unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 541
 542 'load_classes;' static schema detected, turning off 'use_namespaces'.
 543
 544 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
 545 variable to disable this warning.
 546
 547 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 548 details.
 549 EOF
 550                 $self->use_namespaces(0);
 551             }
 552             elsif ($load_classes && $self->use_namespaces) {
 553                 $self->_upgrading_from_load_classes(1);
 554             }
 555             elsif ((not $load_classes) && defined $self->use_namespaces
 556                                        && (not $self->use_namespaces)) {
 557                 $self->_downgrading_to_load_classes(
 558                     $result_namespace || 'Result'
 559                 );
 560             }
 561             elsif ((not defined $self->use_namespaces)
 562                    || $self->use_namespaces) {
 563                 if (not $self->result_namespace) {
 564                     $self->result_namespace($result_namespace || 'Result');
 565                 }
 566                 elsif ($result_namespace ne $self->result_namespace) {
 567                     $self->_rewriting_result_namespace(
 568                         $result_namespace || 'Result'
 569                     );
 570                 }
 571             }
 572
 573             # XXX when we go past .0 this will need fixing
 574             my ($v) = $real_ver =~ /([1-9])/;
 575             $v = "v$v";
 576
 577             last if $v eq CURRENT_V || $real_ver =~ /^0\.\d\d999/;
 578
 579             if (not %{ $self->naming }) {
 580                 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 581
 582 Version $real_ver static schema detected, turning on backcompat mode.
 583
 584 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 585 to disable this warning.
 586
 587 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 588 details.
 589 EOF
 590             }
 591             else {
 592                 $self->_upgrading_from($v);
 593                 last;
 594             }
 595
 596             $self->naming->{relationships} ||= $v;
 597             $self->naming->{monikers}      ||= $v;
 598
 599             $self->schema_version_to_dump($real_ver);
 600
 601             last;
 602         }
 603     }
 604     close $fh;
 605 }
 606
 607 sub _validate_class_args {
 608     my $self = shift;
 609     my $args = shift;
 610
 611     foreach my $k (CLASS_ARGS) {
 612         next unless $self->$k;
 613
 614         my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
 615         foreach my $c (@classes) {
 616             # components default to being under the DBIx::Class namespace unless they
 617             # are preceeded with a '+'
 618             if ( $k =~ m/components$/ && $c !~ s/^\+// ) {
 619                 $c = 'DBIx::Class::' . $c;
 620             }
 621
 622             # 1 == installed, 0 == not installed, undef == invalid classname
 623             my $installed = Class::Inspector->installed($c);
 624             if ( defined($installed) ) {
 625                 if ( $installed == 0 ) {
 626                     croak qq/$c, as specified in the loader option "$k", is not installed/;
 627                 }
 628             } else {
 629                 croak qq/$c, as specified in the loader option "$k", is an invalid class name/;
 630             }
 631         }
 632     }
 633 }
 634
 635 sub _find_file_in_inc {
 636     my ($self, $file) = @_;
 637
 638     foreach my $prefix (@INC) {
 639         my $fullpath = File::Spec->catfile($prefix, $file);
 640         return $fullpath if -f $fullpath
 641             # abs_path throws on Windows for nonexistant files
 642             and eval { Cwd::abs_path($fullpath) } ne
 643                (eval { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) } || '');
 644     }
 645
 646     return;
 647 }
 648
 649 sub _class_path {
 650     my ($self, $class) = @_;
 651
 652     my $class_path = $class;
 653     $class_path =~ s{::}{/}g;
 654     $class_path .= '.pm';
 655
 656     return $class_path;
 657 }
 658
 659 sub _find_class_in_inc {
 660     my ($self, $class) = @_;
 661
 662     return $self->_find_file_in_inc($self->_class_path($class));
 663 }
 664
 665 sub _rewriting {
 666     my $self = shift;
 667
 668     return $self->_upgrading_from
 669         || $self->_upgrading_from_load_classes
 670         || $self->_downgrading_to_load_classes
 671         || $self->_rewriting_result_namespace
 672     ;
 673 }
 674
 675 sub _rewrite_old_classnames {
 676     my ($self, $code) = @_;
 677
 678     return $code unless $self->_rewriting;
 679
 680     my %old_classes = reverse %{ $self->_upgrading_classes };
 681
 682     my $re = join '|', keys %old_classes;
 683     $re = qr/\b($re)\b/;
 684
 685     $code =~ s/$re/$old_classes{$1} || $1/eg;
 686
 687     return $code;
 688 }
 689
 690 sub _load_external {
 691     my ($self, $class) = @_;
 692
 693     return if $self->{skip_load_external};
 694
 695     # so that we don't load our own classes, under any circumstances
 696     local *INC = [ grep $_ ne $self->dump_directory, @INC ];
 697
 698     my $real_inc_path = $self->_find_class_in_inc($class);
 699
 700     my $old_class = $self->_upgrading_classes->{$class}
 701         if $self->_rewriting;
 702
 703     my $old_real_inc_path = $self->_find_class_in_inc($old_class)
 704         if $old_class && $old_class ne $class;
 705
 706     return unless $real_inc_path || $old_real_inc_path;
 707
 708     if ($real_inc_path) {
 709         # If we make it to here, we loaded an external definition
 710         warn qq/# Loaded external class definition for '$class'\n/
 711             if $self->debug;
 712
 713         open(my $fh, '<', $real_inc_path)
 714             or croak "Failed to open '$real_inc_path' for reading: $!";
 715         my $code = do { local $/; <$fh> };
 716         close($fh)
 717             or croak "Failed to close $real_inc_path: $!";
 718         $code = $self->_rewrite_old_classnames($code);
 719
 720         if ($self->dynamic) { # load the class too
 721             # kill redefined warnings
 722             my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 723             local $SIG{__WARN__} = sub {
 724                 $warn_handler->(@_)
 725                     unless $_[0] =~ /^Subroutine \S+ redefined/;
 726             };
 727             eval $code;
 728             die $@ if $@;
 729         }
 730
 731         $self->_ext_stmt($class,
 732           qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
 733          .qq|# They are now part of the custom portion of this file\n|
 734          .qq|# for you to hand-edit.  If you do not either delete\n|
 735          .qq|# this section or remove that file from \@INC, this section\n|
 736          .qq|# will be repeated redundantly when you re-create this\n|
 737          .qq|# file again via Loader!  See skip_load_external to disable\n|
 738          .qq|# this feature.\n|
 739         );
 740         chomp $code;
 741         $self->_ext_stmt($class, $code);
 742         $self->_ext_stmt($class,
 743             qq|# End of lines loaded from '$real_inc_path' |
 744         );
 745     }
 746
 747     if ($old_real_inc_path) {
 748         open(my $fh, '<', $old_real_inc_path)
 749             or croak "Failed to open '$old_real_inc_path' for reading: $!";
 750         $self->_ext_stmt($class, <<"EOF");
 751
 752 # These lines were loaded from '$old_real_inc_path',
 753 # based on the Result class name that would have been created by an 0.04006
 754 # version of the Loader. For a static schema, this happens only once during
 755 # upgrade. See skip_load_external to disable this feature.
 756 EOF
 757
 758         my $code = do {
 759             local ($/, @ARGV) = (undef, $old_real_inc_path); <>
 760         };
 761         $code = $self->_rewrite_old_classnames($code);
 762
 763         if ($self->dynamic) {
 764             warn <<"EOF";
 765
 766 Detected external content in '$old_real_inc_path', a class name that would have
 767 been used by an 0.04006 version of the Loader.
 768
 769 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
 770 new name of the Result.
 771 EOF
 772             # kill redefined warnings
 773             my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 774             local $SIG{__WARN__} = sub {
 775                 $warn_handler->(@_)
 776                     unless $_[0] =~ /^Subroutine \S+ redefined/;
 777             };
 778             eval $code;
 779             die $@ if $@;
 780         }
 781
 782         chomp $code;
 783         $self->_ext_stmt($class, $code);
 784         $self->_ext_stmt($class,
 785             qq|# End of lines loaded from '$old_real_inc_path' |
 786         );
 787     }
 788 }
 789
 790 =head2 load
 791
 792 Does the actual schema-construction work.
 793
 794 =cut
 795
 796 sub load {
 797     my $self = shift;
 798
 799     $self->_load_tables($self->_tables_list);
 800 }
 801
 802 =head2 rescan
 803
 804 Arguments: schema
 805
 806 Rescan the database for newly added tables.  Does
 807 not process drops or changes.  Returns a list of
 808 the newly added table monikers.
 809
 810 The schema argument should be the schema class
 811 or object to be affected.  It should probably
 812 be derived from the original schema_class used
 813 during L</load>.
 814
 815 =cut
 816
 817 sub rescan {
 818     my ($self, $schema) = @_;
 819
 820     $self->{schema} = $schema;
 821     $self->_relbuilder->{schema} = $schema;
 822
 823     my @created;
 824     my @current = $self->_tables_list;
 825     foreach my $table ($self->_tables_list) {
 826         if(!exists $self->{_tables}->{$table}) {
 827             push(@created, $table);
 828         }
 829     }
 830
 831     my $loaded = $self->_load_tables(@created);
 832
 833     return map { $self->monikers->{$_} } @$loaded;
 834 }
 835
 836 sub _relbuilder {
 837     no warnings 'uninitialized';
 838     my ($self) = @_;
 839
 840     return if $self->{skip_relationships};
 841
 842     if ($self->naming->{relationships} eq 'v4') {
 843         require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
 844         return $self->{relbuilder} ||=
 845             DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
 846                 $self->schema, $self->inflect_plural, $self->inflect_singular
 847             );
 848     }
 849
 850     $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new (
 851          $self->schema,
 852          $self->inflect_plural,
 853          $self->inflect_singular,
 854          $self->relationship_attrs,
 855     );
 856 }
 857
 858 sub _load_tables {
 859     my ($self, @tables) = @_;
 860
 861     # First, use _tables_list with constraint and exclude
 862     #  to get a list of tables to operate on
 863
 864     my $constraint   = $self->constraint;
 865     my $exclude      = $self->exclude;
 866
 867     @tables = grep { /$constraint/ } @tables if $constraint;
 868     @tables = grep { ! /$exclude/ } @tables if $exclude;
 869
 870     # Save the new tables to the tables list
 871     foreach (@tables) {
 872         $self->{_tables}->{$_} = 1;
 873     }
 874
 875     $self->_make_src_class($_) for @tables;
 876     $self->_setup_src_meta($_) for @tables;
 877
 878     if(!$self->skip_relationships) {
 879         # The relationship loader needs a working schema
 880         $self->{quiet} = 1;
 881         local $self->{dump_directory} = $self->{temp_directory};
 882         $self->_reload_classes(\@tables);
 883         $self->_load_relationships($_) for @tables;
 884         $self->{quiet} = 0;
 885
 886         # Remove that temp dir from INC so it doesn't get reloaded
 887         @INC = grep $_ ne $self->dump_directory, @INC;
 888     }
 889
 890     $self->_load_external($_)
 891         for map { $self->classes->{$_} } @tables;
 892
 893     # Reload without unloading first to preserve any symbols from external
 894     # packages.
 895     $self->_reload_classes(\@tables, 0);
 896
 897     # Drop temporary cache
 898     delete $self->{_cache};
 899
 900     return \@tables;
 901 }
 902
 903 sub _reload_classes {
 904     my ($self, $tables, $unload) = @_;
 905
 906     my @tables = @$tables;
 907     $unload = 1 unless defined $unload;
 908
 909     # so that we don't repeat custom sections
 910     @INC = grep $_ ne $self->dump_directory, @INC;
 911
 912     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
 913
 914     unshift @INC, $self->dump_directory;
 915
 916     my @to_register;
 917     my %have_source = map { $_ => $self->schema->source($_) }
 918         $self->schema->sources;
 919
 920     for my $table (@tables) {
 921         my $moniker = $self->monikers->{$table};
 922         my $class = $self->classes->{$table};
 923
 924         {
 925             no warnings 'redefine';
 926             local *Class::C3::reinitialize = sub {};
 927             use warnings;
 928
 929             Class::Unload->unload($class) if $unload;
 930             my ($source, $resultset_class);
 931             if (
 932                 ($source = $have_source{$moniker})
 933                 && ($resultset_class = $source->resultset_class)
 934                 && ($resultset_class ne 'DBIx::Class::ResultSet')
 935             ) {
 936                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
 937                 Class::Unload->unload($resultset_class) if $unload;
 938                 $self->_reload_class($resultset_class) if $has_file;
 939             }
 940             $self->_reload_class($class);
 941         }
 942         push @to_register, [$moniker, $class];
 943     }
 944
 945     Class::C3->reinitialize;
 946     for (@to_register) {
 947         $self->schema->register_class(@$_);
 948     }
 949 }
 950
 951 # We use this instead of ensure_class_loaded when there are package symbols we
 952 # want to preserve.
 953 sub _reload_class {
 954     my ($self, $class) = @_;
 955
 956     my $class_path = $self->_class_path($class);
 957     delete $INC{ $class_path };
 958
 959 # kill redefined warnings
 960     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 961     local $SIG{__WARN__} = sub {
 962         $warn_handler->(@_)
 963             unless $_[0] =~ /^Subroutine \S+ redefined/;
 964     };
 965     eval "require $class;";
 966 }
 967
 968 sub _get_dump_filename {
 969     my ($self, $class) = (@_);
 970
 971     $class =~ s{::}{/}g;
 972     return $self->dump_directory . q{/} . $class . q{.pm};
 973 }
 974
 975 sub _ensure_dump_subdirs {
 976     my ($self, $class) = (@_);
 977
 978     my @name_parts = split(/::/, $class);
 979     pop @name_parts; # we don't care about the very last element,
 980                      # which is a filename
 981
 982     my $dir = $self->dump_directory;
 983     while (1) {
 984         if(!-d $dir) {
 985             mkdir($dir) or croak "mkdir('$dir') failed: $!";
 986         }
 987         last if !@name_parts;
 988         $dir = File::Spec->catdir($dir, shift @name_parts);
 989     }
 990 }
 991
 992 sub _dump_to_dir {
 993     my ($self, @classes) = @_;
 994
 995     my $schema_class = $self->schema_class;
 996     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
 997
 998     my $target_dir = $self->dump_directory;
 999     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1000         unless $self->{dynamic} or $self->{quiet};
1001
1002     my $schema_text =
1003           qq|package $schema_class;\n\n|
1004         . qq|# Created by DBIx::Class::Schema::Loader\n|
1005         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1006         . qq|use strict;\nuse warnings;\n\n|
1007         . qq|use base '$schema_base_class';\n\n|;
1008
1009     if ($self->use_namespaces) {
1010         $schema_text .= qq|__PACKAGE__->load_namespaces|;
1011         my $namespace_options;
1012         for my $attr (qw(result_namespace
1013                          resultset_namespace
1014                          default_resultset_class)) {
1015             if ($self->$attr) {
1016                 $namespace_options .= qq|    $attr => '| . $self->$attr . qq|',\n|
1017             }
1018         }
1019         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1020         $schema_text .= qq|;\n|;
1021     }
1022     else {
1023         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1024     }
1025
1026     {
1027         local $self->{version_to_dump} = $self->schema_version_to_dump;
1028         $self->_write_classfile($schema_class, $schema_text, 1);
1029     }
1030
1031     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1032
1033     foreach my $src_class (@classes) {
1034         my $src_text =
1035               qq|package $src_class;\n\n|
1036             . qq|# Created by DBIx::Class::Schema::Loader\n|
1037             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1038             . qq|use strict;\nuse warnings;\n\n|
1039             . qq|use base '$result_base_class';\n\n|;
1040
1041         $self->_write_classfile($src_class, $src_text);
1042     }
1043
1044     # remove Result dir if downgrading from use_namespaces, and there are no
1045     # files left.
1046     if (my $result_ns = $self->_downgrading_to_load_classes
1047                         || $self->_rewriting_result_namespace) {
1048         my $result_namespace = $self->_result_namespace(
1049             $schema_class,
1050             $result_ns,
1051         );
1052
1053         (my $result_dir = $result_namespace) =~ s{::}{/}g;
1054         $result_dir = $self->dump_directory . '/' . $result_dir;
1055
1056         unless (my @files = glob "$result_dir/*") {
1057             rmdir $result_dir;
1058         }
1059     }
1060
1061     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1062
1063 }
1064
1065 sub _sig_comment {
1066     my ($self, $version, $ts) = @_;
1067     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1068          . qq| v| . $version
1069          . q| @ | . $ts
1070          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1071 }
1072
1073 sub _write_classfile {
1074     my ($self, $class, $text, $is_schema) = @_;
1075
1076     my $filename = $self->_get_dump_filename($class);
1077     $self->_ensure_dump_subdirs($class);
1078
1079     if (-f $filename && $self->really_erase_my_files) {
1080         warn "Deleting existing file '$filename' due to "
1081             . "'really_erase_my_files' setting\n" unless $self->{quiet};
1082         unlink($filename);
1083     }
1084
1085     my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
1086
1087     if (my $old_class = $self->_upgrading_classes->{$class}) {
1088         my $old_filename = $self->_get_dump_filename($old_class);
1089
1090         my ($old_custom_content) = $self->_get_custom_content(
1091             $old_class, $old_filename, 0 # do not add default comment
1092         );
1093
1094         $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
1095
1096         if ($old_custom_content) {
1097             $custom_content =
1098                 "\n" . $old_custom_content . "\n" . $custom_content;
1099         }
1100
1101         unlink $old_filename;
1102     }
1103
1104     $custom_content = $self->_rewrite_old_classnames($custom_content);
1105
1106     $text .= qq|$_\n|
1107         for @{$self->{_dump_storage}->{$class} || []};
1108
1109     # Check and see if the dump is infact differnt
1110
1111     my $compare_to;
1112     if ($old_md5) {
1113       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1114
1115
1116       if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1117         return unless $self->_upgrading_from && $is_schema;
1118       }
1119     }
1120
1121     $text .= $self->_sig_comment(
1122       $self->version_to_dump,
1123       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1124     );
1125
1126     open(my $fh, '>', $filename)
1127         or croak "Cannot open '$filename' for writing: $!";
1128
1129     # Write the top half and its MD5 sum
1130     print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1131
1132     # Write out anything loaded via external partial class file in @INC
1133     print $fh qq|$_\n|
1134         for @{$self->{_ext_storage}->{$class} || []};
1135
1136     # Write out any custom content the user has added
1137     print $fh $custom_content;
1138
1139     close($fh)
1140         or croak "Error closing '$filename': $!";
1141 }
1142
1143 sub _default_custom_content {
1144     return qq|\n\n# You can replace this text with custom|
1145          . qq| content, and it will be preserved on regeneration|
1146          . qq|\n1;\n|;
1147 }
1148
1149 sub _get_custom_content {
1150     my ($self, $class, $filename, $add_default) = @_;
1151
1152     $add_default = 1 unless defined $add_default;
1153
1154     return ($self->_default_custom_content) if ! -f $filename;
1155
1156     open(my $fh, '<', $filename)
1157         or croak "Cannot open '$filename' for reading: $!";
1158
1159     my $mark_re =
1160         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1161
1162     my $buffer = '';
1163     my ($md5, $ts, $ver);
1164     while(<$fh>) {
1165         if(!$md5 && /$mark_re/) {
1166             $md5 = $2;
1167             my $line = $1;
1168
1169             # Pull out the previous version and timestamp
1170             ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
1171
1172             $buffer .= $line;
1173             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"
1174                 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
1175
1176             $buffer = '';
1177         }
1178         else {
1179             $buffer .= $_;
1180         }
1181     }
1182
1183     croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
1184         . " it does not appear to have been generated by Loader"
1185             if !$md5;
1186
1187     # Default custom content:
1188     $buffer ||= $self->_default_custom_content if $add_default;
1189
1190     return ($buffer, $md5, $ver, $ts);
1191 }
1192
1193 sub _use {
1194     my $self = shift;
1195     my $target = shift;
1196
1197     foreach (@_) {
1198         warn "$target: use $_;" if $self->debug;
1199         $self->_raw_stmt($target, "use $_;");
1200     }
1201 }
1202
1203 sub _inject {
1204     my $self = shift;
1205     my $target = shift;
1206     my $schema_class = $self->schema_class;
1207
1208     my $blist = join(q{ }, @_);
1209     warn "$target: use base qw/ $blist /;" if $self->debug && @_;
1210     $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
1211 }
1212
1213 sub _result_namespace {
1214     my ($self, $schema_class, $ns) = @_;
1215     my @result_namespace;
1216
1217     if ($ns =~ /^\+(.*)/) {
1218         # Fully qualified namespace
1219         @result_namespace = ($1)
1220     }
1221     else {
1222         # Relative namespace
1223         @result_namespace = ($schema_class, $ns);
1224     }
1225
1226     return wantarray ? @result_namespace : join '::', @result_namespace;
1227 }
1228
1229 # Create class with applicable bases, setup monikers, etc
1230 sub _make_src_class {
1231     my ($self, $table) = @_;
1232
1233     my $schema       = $self->schema;
1234     my $schema_class = $self->schema_class;
1235
1236     my $table_moniker = $self->_table2moniker($table);
1237     my @result_namespace = ($schema_class);
1238     if ($self->use_namespaces) {
1239         my $result_namespace = $self->result_namespace || 'Result';
1240         @result_namespace = $self->_result_namespace(
1241             $schema_class,
1242             $result_namespace,
1243         );
1244     }
1245     my $table_class = join(q{::}, @result_namespace, $table_moniker);
1246
1247     if ((my $upgrading_v = $self->_upgrading_from)
1248             || $self->_rewriting) {
1249         local $self->naming->{monikers} = $upgrading_v
1250             if $upgrading_v;
1251
1252         my @result_namespace = @result_namespace;
1253         if ($self->_upgrading_from_load_classes) {
1254             @result_namespace = ($schema_class);
1255         }
1256         elsif (my $ns = $self->_downgrading_to_load_classes) {
1257             @result_namespace = $self->_result_namespace(
1258                 $schema_class,
1259                 $ns,
1260             );
1261         }
1262         elsif ($ns = $self->_rewriting_result_namespace) {
1263             @result_namespace = $self->_result_namespace(
1264                 $schema_class,
1265                 $ns,
1266             );
1267         }
1268
1269         my $old_class = join(q{::}, @result_namespace,
1270             $self->_table2moniker($table));
1271
1272         $self->_upgrading_classes->{$table_class} = $old_class
1273             unless $table_class eq $old_class;
1274     }
1275
1276     my $table_normalized = lc $table;
1277     $self->classes->{$table} = $table_class;
1278     $self->classes->{$table_normalized} = $table_class;
1279     $self->monikers->{$table} = $table_moniker;
1280     $self->monikers->{$table_normalized} = $table_moniker;
1281
1282     $self->_use   ($table_class, @{$self->additional_classes});
1283     $self->_inject($table_class, @{$self->left_base_classes});
1284
1285     if (my @components = @{ $self->components }) {
1286         $self->_dbic_stmt($table_class, 'load_components', @components);
1287     }
1288
1289     $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1290         if @{$self->resultset_components};
1291     $self->_inject($table_class, @{$self->additional_base_classes});
1292 }
1293
1294 # Set up metadata (cols, pks, etc)
1295 sub _setup_src_meta {
1296     my ($self, $table) = @_;
1297
1298     my $schema       = $self->schema;
1299     my $schema_class = $self->schema_class;
1300
1301     my $table_class = $self->classes->{$table};
1302     my $table_moniker = $self->monikers->{$table};
1303
1304     my $table_name = $table;
1305     my $name_sep   = $self->schema->storage->sql_maker->name_sep;
1306
1307     if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1308         $table_name = \ $self->_quote_table_name($table_name);
1309     }
1310
1311     $self->_dbic_stmt($table_class,'table',$table_name);
1312
1313     my $cols = $self->_table_columns($table);
1314     my $col_info;
1315     eval { $col_info = $self->_columns_info_for($table) };
1316     if($@) {
1317         $self->_dbic_stmt($table_class,'add_columns',@$cols);
1318     }
1319     else {
1320         if ($self->_is_case_sensitive) {
1321             for my $col (keys %$col_info) {
1322                 $col_info->{$col}{accessor} = lc $col
1323                     if $col ne lc($col);
1324             }
1325         } else {
1326             $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1327         }
1328
1329         my $fks = $self->_table_fk_info($table);
1330
1331         for my $fkdef (@$fks) {
1332             for my $col (@{ $fkdef->{local_columns} }) {
1333                 $col_info->{$col}{is_foreign_key} = 1;
1334             }
1335         }
1336         $self->_dbic_stmt(
1337             $table_class,
1338             'add_columns',
1339             map { $_, ($col_info->{$_}||{}) } @$cols
1340         );
1341     }
1342
1343     my %uniq_tag; # used to eliminate duplicate uniqs
1344
1345     my $pks = $self->_table_pk_info($table) || [];
1346     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1347           : carp("$table has no primary key");
1348     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1349
1350     my $uniqs = $self->_table_uniq_info($table) || [];
1351     for (@$uniqs) {
1352         my ($name, $cols) = @$_;
1353         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1354         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1355     }
1356
1357 }
1358
1359 =head2 tables
1360
1361 Returns a sorted list of loaded tables, using the original database table
1362 names.
1363
1364 =cut
1365
1366 sub tables {
1367     my $self = shift;
1368
1369     return keys %{$self->_tables};
1370 }
1371
1372 # Make a moniker from a table
1373 sub _default_table2moniker {
1374     no warnings 'uninitialized';
1375     my ($self, $table) = @_;
1376
1377     if ($self->naming->{monikers} eq 'v4') {
1378         return join '', map ucfirst, split /[\W_]+/, lc $table;
1379     }
1380
1381     return join '', map ucfirst, split /[\W_]+/,
1382         Lingua::EN::Inflect::Number::to_S(lc $table);
1383 }
1384
1385 sub _table2moniker {
1386     my ( $self, $table ) = @_;
1387
1388     my $moniker;
1389
1390     if( ref $self->moniker_map eq 'HASH' ) {
1391         $moniker = $self->moniker_map->{$table};
1392     }
1393     elsif( ref $self->moniker_map eq 'CODE' ) {
1394         $moniker = $self->moniker_map->($table);
1395     }
1396
1397     $moniker ||= $self->_default_table2moniker($table);
1398
1399     return $moniker;
1400 }
1401
1402 sub _load_relationships {
1403     my ($self, $table) = @_;
1404
1405     my $tbl_fk_info = $self->_table_fk_info($table);
1406     foreach my $fkdef (@$tbl_fk_info) {
1407         $fkdef->{remote_source} =
1408             $self->monikers->{delete $fkdef->{remote_table}};
1409     }
1410     my $tbl_uniq_info = $self->_table_uniq_info($table);
1411
1412     my $local_moniker = $self->monikers->{$table};
1413     my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1414
1415     foreach my $src_class (sort keys %$rel_stmts) {
1416         my $src_stmts = $rel_stmts->{$src_class};
1417         foreach my $stmt (@$src_stmts) {
1418             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1419         }
1420     }
1421 }
1422
1423 # Overload these in driver class:
1424
1425 # Returns an arrayref of column names
1426 sub _table_columns { croak "ABSTRACT METHOD" }
1427
1428 # Returns arrayref of pk col names
1429 sub _table_pk_info { croak "ABSTRACT METHOD" }
1430
1431 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1432 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1433
1434 # Returns an arrayref of foreign key constraints, each
1435 #   being a hashref with 3 keys:
1436 #   local_columns (arrayref), remote_columns (arrayref), remote_table
1437 sub _table_fk_info { croak "ABSTRACT METHOD" }
1438
1439 # Returns an array of lower case table names
1440 sub _tables_list { croak "ABSTRACT METHOD" }
1441
1442 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1443 sub _dbic_stmt {
1444     my $self   = shift;
1445     my $class  = shift;
1446     my $method = shift;
1447
1448     # generate the pod for this statement, storing it with $self->_pod
1449     $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
1450
1451     my $args = dump(@_);
1452     $args = '(' . $args . ')' if @_ < 2;
1453     my $stmt = $method . $args . q{;};
1454
1455     warn qq|$class\->$stmt\n| if $self->debug;
1456     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1457     return;
1458 }
1459
1460 # generates the accompanying pod for a DBIC class method statement,
1461 # storing it with $self->_pod
1462 sub _make_pod {
1463     my $self   = shift;
1464     my $class  = shift;
1465     my $method = shift;
1466
1467     if ( $method eq 'table' ) {
1468         my ($table) = @_;
1469         my $pcm = $self->pod_comment_mode;
1470         my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
1471         if ( $self->can('_table_comment') ) {
1472             $comment = $self->_table_comment($table);
1473             $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1474             $comment_in_name   = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1475             $comment_in_desc   = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
1476         }
1477         $self->_pod( $class, "=head1 NAME" );
1478         my $table_descr = $class;
1479         $table_descr .= " - " . $comment if $comment and $comment_in_name;
1480         $self->{_class2table}{ $class } = $table;
1481         $self->_pod( $class, $table_descr );
1482         if ($comment and $comment_in_desc) {
1483             $self->_pod( $class, "=head1 DESCRIPTION" );
1484             $self->_pod( $class, $comment );
1485         }
1486         $self->_pod_cut( $class );
1487     } elsif ( $method eq 'add_columns' ) {
1488         $self->_pod( $class, "=head1 ACCESSORS" );
1489         my $col_counter = 0;
1490         my @cols = @_;
1491         while( my ($name,$attrs) = splice @cols,0,2 ) {
1492             $col_counter++;
1493             $self->_pod( $class, '=head2 ' . $name  );
1494             $self->_pod( $class,
1495                          join "\n", map {
1496                              my $s = $attrs->{$_};
1497                              $s = !defined $s      ? 'undef'          :
1498                                   length($s) == 0  ? '(empty string)' :
1499                                                      $s;
1500
1501                              "  $_: $s"
1502                          } sort keys %$attrs,
1503                        );
1504
1505             if( $self->can('_column_comment')
1506                 and my $comment = $self->_column_comment( $self->{_class2table}{$class}, $col_counter)
1507               ) {
1508                 $self->_pod( $class, $comment );
1509             }
1510         }
1511         $self->_pod_cut( $class );
1512     } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1513         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1514         my ( $accessor, $rel_class ) = @_;
1515         $self->_pod( $class, "=head2 $accessor" );
1516         $self->_pod( $class, 'Type: ' . $method );
1517         $self->_pod( $class, "Related object: L<$rel_class>" );
1518         $self->_pod_cut( $class );
1519         $self->{_relations_started} { $class } = 1;
1520     }
1521 }
1522
1523 # Stores a POD documentation
1524 sub _pod {
1525     my ($self, $class, $stmt) = @_;
1526     $self->_raw_stmt( $class, "\n" . $stmt  );
1527 }
1528
1529 sub _pod_cut {
1530     my ($self, $class ) = @_;
1531     $self->_raw_stmt( $class, "\n=cut\n" );
1532 }
1533
1534 # Store a raw source line for a class (for dumping purposes)
1535 sub _raw_stmt {
1536     my ($self, $class, $stmt) = @_;
1537     push(@{$self->{_dump_storage}->{$class}}, $stmt);
1538 }
1539
1540 # Like above, but separately for the externally loaded stuff
1541 sub _ext_stmt {
1542     my ($self, $class, $stmt) = @_;
1543     push(@{$self->{_ext_storage}->{$class}}, $stmt);
1544 }
1545
1546 sub _quote_table_name {
1547     my ($self, $table) = @_;
1548
1549     my $qt = $self->schema->storage->sql_maker->quote_char;
1550
1551     return $table unless $qt;
1552
1553     if (ref $qt) {
1554         return $qt->[0] . $table . $qt->[1];
1555     }
1556
1557     return $qt . $table . $qt;
1558 }
1559
1560 sub _is_case_sensitive { 0 }
1561
1562 # remove the dump dir from @INC on destruction
1563 sub DESTROY {
1564     my $self = shift;
1565
1566     @INC = grep $_ ne $self->dump_directory, @INC;
1567 }
1568
1569 =head2 monikers
1570
1571 Returns a hashref of loaded table to moniker mappings.  There will
1572 be two entries for each table, the original name and the "normalized"
1573 name, in the case that the two are different (such as databases
1574 that like uppercase table names, or preserve your original mixed-case
1575 definitions, or what-have-you).
1576
1577 =head2 classes
1578
1579 Returns a hashref of table to class mappings.  In some cases it will
1580 contain multiple entries per table for the original and normalized table
1581 names, as above in L</monikers>.
1582
1583 =head1 SEE ALSO
1584
1585 L<DBIx::Class::Schema::Loader>
1586
1587 =head1 AUTHOR
1588
1589 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1590
1591 =head1 LICENSE
1592
1593 This library is free software; you can redistribute it and/or modify it under
1594 the same terms as Perl itself.
1595
1596 =cut
1597
1598 1;