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::Fast 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_07';
  20
  21 __PACKAGE__->mk_ro_accessors(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                                 moniker_map
  34                                 inflect_singular
  35                                 inflect_plural
  36                                 debug
  37                                 dump_directory
  38                                 dump_overwrite
  39                                 really_erase_my_files
  40                                 use_namespaces
  41                                 result_namespace
  42                                 resultset_namespace
  43                                 default_resultset_class
  44                                 schema_base_class
  45                                 result_base_class
  46
  47                                 db_schema
  48                                 _tables
  49                                 classes
  50                                 monikers
  51                              /);
  52
  53 =head1 NAME
  54
  55 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
  56
  57 =head1 SYNOPSIS
  58
  59 See L<DBIx::Class::Schema::Loader>
  60
  61 =head1 DESCRIPTION
  62
  63 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
  64 classes, and implements the common functionality between them.
  65
  66 =head1 CONSTRUCTOR OPTIONS
  67
  68 These constructor options are the base options for
  69 L<DBIx::Class::Schema::Loader/loader_options>.  Available constructor options are:
  70
  71 =head2 skip_relationships
  72
  73 Skip setting up relationships.  The default is to attempt the loading
  74 of relationships.
  75
  76 =head2 debug
  77
  78 If set to true, each constructive L<DBIx::Class> statement the loader
  79 decides to execute will be C<warn>-ed before execution.
  80
  81 =head2 db_schema
  82
  83 Set the name of the schema to load (schema in the sense that your database
  84 vendor means it).  Does not currently support loading more than one schema
  85 name.
  86
  87 =head2 constraint
  88
  89 Only load tables matching regex.  Best specified as a qr// regex.
  90
  91 =head2 exclude
  92
  93 Exclude tables matching regex.  Best specified as a qr// regex.
  94
  95 =head2 moniker_map
  96
  97 Overrides the default table name to moniker translation.  Can be either
  98 a hashref of table keys and moniker values, or a coderef for a translator
  99 function taking a single scalar table name argument and returning
 100 a scalar moniker.  If the hash entry does not exist, or the function
 101 returns a false value, the code falls back to default behavior
 102 for that table name.
 103
 104 The default behavior is: C<join '', map ucfirst, split /[\W_]+/, lc $table>,
 105 which is to say: lowercase everything, split up the table name into chunks
 106 anywhere a non-alpha-numeric character occurs, change the case of first letter
 107 of each chunk to upper case, and put the chunks back together.  Examples:
 108
 109     Table Name  | Moniker Name
 110     ---------------------------
 111     luser       | Luser
 112     luser_group | LuserGroup
 113     luser-opts  | LuserOpts
 114
 115 =head2 inflect_plural
 116
 117 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
 118 if hash key does not exist or coderef returns false), but acts as a map
 119 for pluralizing relationship names.  The default behavior is to utilize
 120 L<Lingua::EN::Inflect::Number/to_PL>.
 121
 122 =head2 inflect_singular
 123
 124 As L</inflect_plural> above, but for singularizing relationship names.
 125 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
 126
 127 =head2 schema_base_class
 128
 129 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
 130
 131 =head2 result_base_class
 132
 133 Base class for your table classes (aka result classes). Defaults to 'DBIx::Class'.
 134
 135 =head2 additional_base_classes
 136
 137 List of additional base classes all of your table classes will use.
 138
 139 =head2 left_base_classes
 140
 141 List of additional base classes all of your table classes will use
 142 that need to be leftmost.
 143
 144 =head2 additional_classes
 145
 146 List of additional classes which all of your table classes will use.
 147
 148 =head2 components
 149
 150 List of additional components to be loaded into all of your table
 151 classes.  A good example would be C<ResultSetManager>.
 152
 153 =head2 resultset_components
 154
 155 List of additional ResultSet components to be loaded into your table
 156 classes.  A good example would be C<AlwaysRS>.  Component
 157 C<ResultSetManager> will be automatically added to the above
 158 C<components> list if this option is set.
 159
 160 =head2 use_namespaces
 161
 162 Generate result class names suitable for
 163 L<DBIx::Class::Schema/load_namespaces> and call that instead of
 164 L<DBIx::Class::Schema/load_classes>. When using this option you can also
 165 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
 166 C<resultset_namespace>, C<default_resultset_class>), and they will be added
 167 to the call (and the generated result class names adjusted appropriately).
 168
 169 =head2 dump_directory
 170
 171 This option is designed to be a tool to help you transition from this
 172 loader to a manually-defined schema when you decide it's time to do so.
 173
 174 The value of this option is a perl libdir pathname.  Within
 175 that directory this module will create a baseline manual
 176 L<DBIx::Class::Schema> module set, based on what it creates at runtime
 177 in memory.
 178
 179 The created schema class will have the same classname as the one on
 180 which you are setting this option (and the ResultSource classes will be
 181 based on this name as well).
 182
 183 Normally you wouldn't hard-code this setting in your schema class, as it
 184 is meant for one-time manual usage.
 185
 186 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
 187 recommended way to access this functionality.
 188
 189 =head2 dump_overwrite
 190
 191 Deprecated.  See L</really_erase_my_files> below, which does *not* mean
 192 the same thing as the old C<dump_overwrite> setting from previous releases.
 193
 194 =head2 really_erase_my_files
 195
 196 Default false.  If true, Loader will unconditionally delete any existing
 197 files before creating the new ones from scratch when dumping a schema to disk.
 198
 199 The default behavior is instead to only replace the top portion of the
 200 file, up to and including the final stanza which contains
 201 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
 202 leaving any customizations you placed after that as they were.
 203
 204 When C<really_erase_my_files> is not set, if the output file already exists,
 205 but the aforementioned final stanza is not found, or the checksum
 206 contained there does not match the generated contents, Loader will
 207 croak and not touch the file.
 208
 209 You should really be using version control on your schema classes (and all
 210 of the rest of your code for that matter).  Don't blame me if a bug in this
 211 code wipes something out when it shouldn't have, you've been warned.
 212
 213 =head1 METHODS
 214
 215 None of these methods are intended for direct invocation by regular
 216 users of L<DBIx::Class::Schema::Loader>.  Anything you can find here
 217 can also be found via standard L<DBIx::Class::Schema> methods somehow.
 218
 219 =cut
 220
 221 # ensure that a peice of object data is a valid arrayref, creating
 222 # an empty one or encapsulating whatever's there.
 223 sub _ensure_arrayref {
 224     my $self = shift;
 225
 226     foreach (@_) {
 227         $self->{$_} ||= [];
 228         $self->{$_} = [ $self->{$_} ]
 229             unless ref $self->{$_} eq 'ARRAY';
 230     }
 231 }
 232
 233 =head2 new
 234
 235 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
 236 by L<DBIx::Class::Schema::Loader>.
 237
 238 =cut
 239
 240 sub new {
 241     my ( $class, %args ) = @_;
 242
 243     my $self = { %args };
 244
 245     bless $self => $class;
 246
 247     $self->_ensure_arrayref(qw/additional_classes
 248                                additional_base_classes
 249                                left_base_classes
 250                                components
 251                                resultset_components
 252                               /);
 253
 254     push(@{$self->{components}}, 'ResultSetManager')
 255         if @{$self->{resultset_components}};
 256
 257     $self->{monikers} = {};
 258     $self->{classes} = {};
 259
 260     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
 261     $self->{schema} ||= $self->{schema_class};
 262
 263     croak "dump_overwrite is deprecated.  Please read the"
 264         . " DBIx::Class::Schema::Loader::Base documentation"
 265             if $self->{dump_overwrite};
 266
 267     $self->{dynamic} = ! $self->{dump_directory};
 268     $self->{dump_directory} ||= File::Temp::tempdir( 'dbicXXXX',
 269                                                      TMPDIR  => 1,
 270                                                      CLEANUP => 1,
 271                                                    );
 272     $self->_check_back_compat;
 273     $self;
 274 }
 275
 276 sub _check_back_compat {
 277     my ($self) = @_;
 278
 279     my $filename = $self->_get_dump_filename($self->schema_class);
 280     return unless -e $filename;
 281
 282     open(my $fh, '<', $filename)
 283         or croak "Cannot open '$filename' for reading: $!";
 284
 285     while (<$fh>) {
 286         if (/^# Created by DBIx::Class::Schema::Loader (v\d+)\.(\d+)/) {
 287             my $ver = "${1}_${2}";
 288             while (1) {
 289                 my $compat_class = "DBIx::Class::Schema::Loader::Compat::${ver}";
 290                 if ($self->load_optional_class($compat_class)) {
 291                     no strict 'refs';
 292                     my $class = ref $self || $self;
 293                     unshift @{"${class}::ISA"}, $compat_class;
 294                     last;
 295                 }
 296                 $ver =~ s/\d\z// or last;
 297             }
 298             last;
 299         }
 300     }
 301     close $fh;
 302 }
 303
 304 sub _find_file_in_inc {
 305     my ($self, $file) = @_;
 306
 307     foreach my $prefix (@INC) {
 308         my $fullpath = File::Spec->catfile($prefix, $file);
 309         return $fullpath if -f $fullpath
 310             and Cwd::abs_path($fullpath) ne
 311                 Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || '';
 312     }
 313
 314     return;
 315 }
 316
 317 sub _load_external {
 318     my ($self, $class) = @_;
 319
 320     my $class_path = $class;
 321     $class_path =~ s{::}{/}g;
 322     $class_path .= '.pm';
 323
 324     my $real_inc_path = $self->_find_file_in_inc($class_path);
 325
 326     return if !$real_inc_path;
 327
 328     # If we make it to here, we loaded an external definition
 329     warn qq/# Loaded external class definition for '$class'\n/
 330         if $self->debug;
 331
 332     croak 'Failed to locate actual external module file for '
 333           . "'$class'"
 334               if !$real_inc_path;
 335     open(my $fh, '<', $real_inc_path)
 336         or croak "Failed to open '$real_inc_path' for reading: $!";
 337     $self->_ext_stmt($class,
 338          qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
 339         .qq|# They are now part of the custom portion of this file\n|
 340         .qq|# for you to hand-edit.  If you do not either delete\n|
 341         .qq|# this section or remove that file from \@INC, this section\n|
 342         .qq|# will be repeated redundantly when you re-create this\n|
 343         .qq|# file again via Loader!\n|
 344     );
 345     while(<$fh>) {
 346         chomp;
 347         $self->_ext_stmt($class, $_);
 348     }
 349     $self->_ext_stmt($class,
 350         qq|# End of lines loaded from '$real_inc_path' |
 351     );
 352     close($fh)
 353         or croak "Failed to close $real_inc_path: $!";
 354 }
 355
 356 =head2 load
 357
 358 Does the actual schema-construction work.
 359
 360 =cut
 361
 362 sub load {
 363     my $self = shift;
 364
 365     $self->_load_tables($self->_tables_list);
 366 }
 367
 368 =head2 rescan
 369
 370 Arguments: schema
 371
 372 Rescan the database for newly added tables.  Does
 373 not process drops or changes.  Returns a list of
 374 the newly added table monikers.
 375
 376 The schema argument should be the schema class
 377 or object to be affected.  It should probably
 378 be derived from the original schema_class used
 379 during L</load>.
 380
 381 =cut
 382
 383 sub rescan {
 384     my ($self, $schema) = @_;
 385
 386     $self->{schema} = $schema;
 387     $self->_relbuilder->{schema} = $schema;
 388
 389     my @created;
 390     my @current = $self->_tables_list;
 391     foreach my $table ($self->_tables_list) {
 392         if(!exists $self->{_tables}->{$table}) {
 393             push(@created, $table);
 394         }
 395     }
 396
 397     my $loaded = $self->_load_tables(@created);
 398
 399     return map { $self->monikers->{$_} } @$loaded;
 400 }
 401
 402 sub _relbuilder {
 403     my ($self) = @_;
 404     $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new(
 405         $self->schema, $self->inflect_plural, $self->inflect_singular
 406     );
 407 }
 408
 409 sub _load_tables {
 410     my ($self, @tables) = @_;
 411
 412     # First, use _tables_list with constraint and exclude
 413     #  to get a list of tables to operate on
 414
 415     my $constraint   = $self->constraint;
 416     my $exclude      = $self->exclude;
 417
 418     @tables = grep { /$constraint/ } @tables if $constraint;
 419     @tables = grep { ! /$exclude/ } @tables if $exclude;
 420
 421     # Save the new tables to the tables list
 422     foreach (@tables) {
 423         $self->{_tables}->{$_} = 1;
 424     }
 425
 426     $self->_make_src_class($_) for @tables;
 427     $self->_setup_src_meta($_) for @tables;
 428
 429     if(!$self->skip_relationships) {
 430         # The relationship loader needs a working schema
 431         $self->{quiet} = 1;
 432         $self->_reload_classes(@tables);
 433         $self->_load_relationships($_) for @tables;
 434         $self->{quiet} = 0;
 435     }
 436
 437     $self->_load_external($_)
 438         for map { $self->classes->{$_} } @tables;
 439
 440     $self->_reload_classes(@tables);
 441
 442     # Drop temporary cache
 443     delete $self->{_cache};
 444
 445     return \@tables;
 446 }
 447
 448 sub _reload_classes {
 449     my ($self, @tables) = @_;
 450
 451     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
 452
 453     unshift @INC, $self->dump_directory;
 454
 455     my @to_register;
 456     my %have_source = map { $_ => $self->schema->source($_) }
 457         $self->schema->sources;
 458
 459     for my $table (@tables) {
 460         my $moniker = $self->monikers->{$table};
 461         my $class = $self->classes->{$table};
 462
 463         {
 464             no warnings 'redefine';
 465             local *Class::C3::reinitialize = sub {};
 466             use warnings;
 467
 468             Class::Unload->unload($class);
 469             my ($source, $resultset_class);
 470             if (
 471                 ($source = $have_source{$moniker})
 472                 && ($resultset_class = $source->resultset_class)
 473                 && ($resultset_class ne 'DBIx::Class::ResultSet')
 474             ) {
 475                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
 476                 Class::Unload->unload($resultset_class);
 477                 $self->ensure_class_loaded($resultset_class) if $has_file;
 478             }
 479             $self->ensure_class_loaded($class);
 480         }
 481         push @to_register, [$moniker, $class];
 482     }
 483
 484     Class::C3->reinitialize;
 485     for (@to_register) {
 486         $self->schema->register_class(@$_);
 487     }
 488 }
 489
 490 sub _get_dump_filename {
 491     my ($self, $class) = (@_);
 492
 493     $class =~ s{::}{/}g;
 494     return $self->dump_directory . q{/} . $class . q{.pm};
 495 }
 496
 497 sub _ensure_dump_subdirs {
 498     my ($self, $class) = (@_);
 499
 500     my @name_parts = split(/::/, $class);
 501     pop @name_parts; # we don't care about the very last element,
 502                      # which is a filename
 503
 504     my $dir = $self->dump_directory;
 505     while (1) {
 506         if(!-d $dir) {
 507             mkdir($dir) or croak "mkdir('$dir') failed: $!";
 508         }
 509         last if !@name_parts;
 510         $dir = File::Spec->catdir($dir, shift @name_parts);
 511     }
 512 }
 513
 514 sub _dump_to_dir {
 515     my ($self, @classes) = @_;
 516
 517     my $schema_class = $self->schema_class;
 518     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
 519
 520     my $target_dir = $self->dump_directory;
 521     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
 522         unless $self->{dynamic} or $self->{quiet};
 523
 524     my $schema_text =
 525           qq|package $schema_class;\n\n|
 526         . qq|use strict;\nuse warnings;\n\n|
 527         . qq|use base '$schema_base_class';\n\n|;
 528
 529     if ($self->use_namespaces) {
 530         $schema_text .= qq|__PACKAGE__->load_namespaces|;
 531         my $namespace_options;
 532         for my $attr (qw(result_namespace
 533                          resultset_namespace
 534                          default_resultset_class)) {
 535             if ($self->$attr) {
 536                 $namespace_options .= qq|    $attr => '| . $self->$attr . qq|',\n|
 537             }
 538         }
 539         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
 540         $schema_text .= qq|;\n|;
 541     }
 542     else {
 543         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
 544     }
 545
 546     $self->_write_classfile($schema_class, $schema_text);
 547
 548     my $result_base_class = $self->result_base_class || 'DBIx::Class';
 549
 550     foreach my $src_class (@classes) {
 551         my $src_text =
 552               qq|package $src_class;\n\n|
 553             . qq|use strict;\nuse warnings;\n\n|
 554             . qq|use base '$result_base_class';\n\n|;
 555
 556         $self->_write_classfile($src_class, $src_text);
 557     }
 558
 559     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
 560
 561 }
 562
 563 sub _write_classfile {
 564     my ($self, $class, $text) = @_;
 565
 566     my $filename = $self->_get_dump_filename($class);
 567     $self->_ensure_dump_subdirs($class);
 568
 569     if (-f $filename && $self->really_erase_my_files) {
 570         warn "Deleting existing file '$filename' due to "
 571             . "'really_erase_my_files' setting\n" unless $self->{quiet};
 572         unlink($filename);
 573     }
 574
 575     my $custom_content = $self->_get_custom_content($class, $filename);
 576     $custom_content ||= qq|\n\n# You can replace this text with custom|
 577         . qq| content, and it will be preserved on regeneration|
 578         . qq|\n1;\n|;
 579
 580     $text .= qq|$_\n|
 581         for @{$self->{_dump_storage}->{$class} || []};
 582
 583     $text .= qq|\n\n# Created by DBIx::Class::Schema::Loader|
 584         . qq| v| . $DBIx::Class::Schema::Loader::VERSION
 585         . q| @ | . POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
 586         . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
 587
 588     open(my $fh, '>', $filename)
 589         or croak "Cannot open '$filename' for writing: $!";
 590
 591     # Write the top half and its MD5 sum
 592     print $fh $text . Digest::MD5::md5_base64($text) . "\n";
 593
 594     # Write out anything loaded via external partial class file in @INC
 595     print $fh qq|$_\n|
 596         for @{$self->{_ext_storage}->{$class} || []};
 597
 598     # Write out any custom content the user has added
 599     print $fh $custom_content;
 600
 601     close($fh)
 602         or croak "Error closing '$filename': $!";
 603 }
 604
 605 sub _get_custom_content {
 606     my ($self, $class, $filename) = @_;
 607
 608     return if ! -f $filename;
 609     open(my $fh, '<', $filename)
 610         or croak "Cannot open '$filename' for reading: $!";
 611
 612     my $mark_re =
 613         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
 614
 615     my $found = 0;
 616     my $buffer = '';
 617     while(<$fh>) {
 618         if(!$found && /$mark_re/) {
 619             $found = 1;
 620             $buffer .= $1;
 621             croak "Checksum mismatch in '$filename'"
 622                 if Digest::MD5::md5_base64($buffer) ne $2;
 623
 624             $buffer = '';
 625         }
 626         else {
 627             $buffer .= $_;
 628         }
 629     }
 630
 631     croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
 632         . " it does not appear to have been generated by Loader"
 633             if !$found;
 634
 635     return $buffer;
 636 }
 637
 638 sub _use {
 639     my $self = shift;
 640     my $target = shift;
 641
 642     foreach (@_) {
 643         warn "$target: use $_;" if $self->debug;
 644         $self->_raw_stmt($target, "use $_;");
 645     }
 646 }
 647
 648 sub _inject {
 649     my $self = shift;
 650     my $target = shift;
 651     my $schema_class = $self->schema_class;
 652
 653     my $blist = join(q{ }, @_);
 654     warn "$target: use base qw/ $blist /;" if $self->debug && @_;
 655     $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
 656 }
 657
 658 # Create class with applicable bases, setup monikers, etc
 659 sub _make_src_class {
 660     my ($self, $table) = @_;
 661
 662     my $schema       = $self->schema;
 663     my $schema_class = $self->schema_class;
 664
 665     my $table_moniker = $self->_table2moniker($table);
 666     my @result_namespace = ($schema_class);
 667     if ($self->use_namespaces) {
 668         my $result_namespace = $self->result_namespace || 'Result';
 669         if ($result_namespace =~ /^\+(.*)/) {
 670             # Fully qualified namespace
 671             @result_namespace =  ($1)
 672         }
 673         else {
 674             # Relative namespace
 675             push @result_namespace, $result_namespace;
 676         }
 677     }
 678     my $table_class = join(q{::}, @result_namespace, $table_moniker);
 679
 680     my $table_normalized = lc $table;
 681     $self->classes->{$table} = $table_class;
 682     $self->classes->{$table_normalized} = $table_class;
 683     $self->monikers->{$table} = $table_moniker;
 684     $self->monikers->{$table_normalized} = $table_moniker;
 685
 686     $self->_use   ($table_class, @{$self->additional_classes});
 687     $self->_inject($table_class, @{$self->left_base_classes});
 688
 689     $self->_dbic_stmt($table_class, 'load_components', @{$self->components}, 'Core');
 690
 691     $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
 692         if @{$self->resultset_components};
 693     $self->_inject($table_class, @{$self->additional_base_classes});
 694 }
 695
 696 # Set up metadata (cols, pks, etc)
 697 sub _setup_src_meta {
 698     my ($self, $table) = @_;
 699
 700     my $schema       = $self->schema;
 701     my $schema_class = $self->schema_class;
 702
 703     my $table_class = $self->classes->{$table};
 704     my $table_moniker = $self->monikers->{$table};
 705
 706     $self->_dbic_stmt($table_class,'table',$table);
 707
 708     my $cols = $self->_table_columns($table);
 709     my $col_info;
 710     eval { $col_info = $self->_columns_info_for($table) };
 711     if($@) {
 712         $self->_dbic_stmt($table_class,'add_columns',@$cols);
 713     }
 714     else {
 715         my %col_info_lc = map { lc($_), $col_info->{$_} } keys %$col_info;
 716         my $fks = $self->_table_fk_info($table);
 717         for my $fkdef (@$fks) {
 718             for my $col (@{ $fkdef->{local_columns} }) {
 719                 $col_info_lc{$col}->{is_foreign_key} = 1;
 720             }
 721         }
 722         $self->_dbic_stmt(
 723             $table_class,
 724             'add_columns',
 725             map { $_, ($col_info_lc{$_}||{}) } @$cols
 726         );
 727     }
 728
 729     my %uniq_tag; # used to eliminate duplicate uniqs
 730
 731     my $pks = $self->_table_pk_info($table) || [];
 732     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
 733           : carp("$table has no primary key");
 734     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
 735
 736     my $uniqs = $self->_table_uniq_info($table) || [];
 737     for (@$uniqs) {
 738         my ($name, $cols) = @$_;
 739         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
 740         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
 741     }
 742
 743 }
 744
 745 =head2 tables
 746
 747 Returns a sorted list of loaded tables, using the original database table
 748 names.
 749
 750 =cut
 751
 752 sub tables {
 753     my $self = shift;
 754
 755     return keys %{$self->_tables};
 756 }
 757
 758 # Make a moniker from a table
 759 sub _default_table2moniker {
 760     my ($self, $table) = @_;
 761
 762     return join '', map ucfirst, split /[\W_]+/,
 763         Lingua::EN::Inflect::Number::to_S(lc $table);
 764 }
 765
 766 sub _table2moniker {
 767     my ( $self, $table ) = @_;
 768
 769     my $moniker;
 770
 771     if( ref $self->moniker_map eq 'HASH' ) {
 772         $moniker = $self->moniker_map->{$table};
 773     }
 774     elsif( ref $self->moniker_map eq 'CODE' ) {
 775         $moniker = $self->moniker_map->($table);
 776     }
 777
 778     $moniker ||= $self->_default_table2moniker($table);
 779
 780     return $moniker;
 781 }
 782
 783 sub _load_relationships {
 784     my ($self, $table) = @_;
 785
 786     my $tbl_fk_info = $self->_table_fk_info($table);
 787     foreach my $fkdef (@$tbl_fk_info) {
 788         $fkdef->{remote_source} =
 789             $self->monikers->{delete $fkdef->{remote_table}};
 790     }
 791     my $tbl_uniq_info = $self->_table_uniq_info($table);
 792
 793     my $local_moniker = $self->monikers->{$table};
 794     my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
 795
 796     foreach my $src_class (sort keys %$rel_stmts) {
 797         my $src_stmts = $rel_stmts->{$src_class};
 798         foreach my $stmt (@$src_stmts) {
 799             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
 800         }
 801     }
 802 }
 803
 804 # Overload these in driver class:
 805
 806 # Returns an arrayref of column names
 807 sub _table_columns { croak "ABSTRACT METHOD" }
 808
 809 # Returns arrayref of pk col names
 810 sub _table_pk_info { croak "ABSTRACT METHOD" }
 811
 812 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
 813 sub _table_uniq_info { croak "ABSTRACT METHOD" }
 814
 815 # Returns an arrayref of foreign key constraints, each
 816 #   being a hashref with 3 keys:
 817 #   local_columns (arrayref), remote_columns (arrayref), remote_table
 818 sub _table_fk_info { croak "ABSTRACT METHOD" }
 819
 820 # Returns an array of lower case table names
 821 sub _tables_list { croak "ABSTRACT METHOD" }
 822
 823 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
 824 sub _dbic_stmt {
 825     my $self = shift;
 826     my $class = shift;
 827     my $method = shift;
 828
 829     my $args = dump(@_);
 830     $args = '(' . $args . ')' if @_ < 2;
 831     my $stmt = $method . $args . q{;};
 832
 833     warn qq|$class\->$stmt\n| if $self->debug;
 834     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
 835 }
 836
 837 # Store a raw source line for a class (for dumping purposes)
 838 sub _raw_stmt {
 839     my ($self, $class, $stmt) = @_;
 840     push(@{$self->{_dump_storage}->{$class}}, $stmt);
 841 }
 842
 843 # Like above, but separately for the externally loaded stuff
 844 sub _ext_stmt {
 845     my ($self, $class, $stmt) = @_;
 846     push(@{$self->{_ext_storage}->{$class}}, $stmt);
 847 }
 848
 849 =head2 monikers
 850
 851 Returns a hashref of loaded table to moniker mappings.  There will
 852 be two entries for each table, the original name and the "normalized"
 853 name, in the case that the two are different (such as databases
 854 that like uppercase table names, or preserve your original mixed-case
 855 definitions, or what-have-you).
 856
 857 =head2 classes
 858
 859 Returns a hashref of table to class mappings.  In some cases it will
 860 contain multiple entries per table for the original and normalized table
 861 names, as above in L</monikers>.
 862
 863 =head1 SEE ALSO
 864
 865 L<DBIx::Class::Schema::Loader>
 866
 867 =cut
 868
 869 1;