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_11';
  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->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
 269                                                      TMPDIR  => 1,
 270                                                      CLEANUP => 1,
 271                                                    );
 272
 273     $self->{dump_directory} ||= $self->{temp_directory};
 274
 275     $self->{relbuilder} = DBIx::Class::Schema::Loader::RelBuilder->new(
 276         $self->schema, $self->inflect_plural, $self->inflect_singular
 277     ) if !$self->{skip_relationships};
 278
 279     $self;
 280 }
 281
 282 sub _find_file_in_inc {
 283     my ($self, $file) = @_;
 284
 285     foreach my $prefix (@INC) {
 286         my $fullpath = File::Spec->catfile($prefix, $file);
 287         return $fullpath if -f $fullpath
 288             and Cwd::abs_path($fullpath) ne
 289                 Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || '';
 290     }
 291
 292     return;
 293 }
 294
 295 sub _load_external {
 296     my ($self, $class) = @_;
 297
 298     my $class_path = $class;
 299     $class_path =~ s{::}{/}g;
 300     $class_path .= '.pm';
 301
 302     my $real_inc_path = $self->_find_file_in_inc($class_path);
 303
 304     return if !$real_inc_path;
 305
 306     # If we make it to here, we loaded an external definition
 307     warn qq/# Loaded external class definition for '$class'\n/
 308         if $self->debug;
 309
 310     croak 'Failed to locate actual external module file for '
 311           . "'$class'"
 312               if !$real_inc_path;
 313     open(my $fh, '<', $real_inc_path)
 314         or croak "Failed to open '$real_inc_path' for reading: $!";
 315     $self->_ext_stmt($class,
 316          qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
 317         .qq|# They are now part of the custom portion of this file\n|
 318         .qq|# for you to hand-edit.  If you do not either delete\n|
 319         .qq|# this section or remove that file from \@INC, this section\n|
 320         .qq|# will be repeated redundantly when you re-create this\n|
 321         .qq|# file again via Loader!\n|
 322     );
 323     while(<$fh>) {
 324         chomp;
 325         $self->_ext_stmt($class, $_);
 326     }
 327     $self->_ext_stmt($class,
 328         qq|# End of lines loaded from '$real_inc_path' |
 329     );
 330     close($fh)
 331         or croak "Failed to close $real_inc_path: $!";
 332 }
 333
 334 =head2 load
 335
 336 Does the actual schema-construction work.
 337
 338 =cut
 339
 340 sub load {
 341     my $self = shift;
 342
 343     $self->_load_tables($self->_tables_list);
 344 }
 345
 346 =head2 rescan
 347
 348 Arguments: schema
 349
 350 Rescan the database for newly added tables.  Does
 351 not process drops or changes.  Returns a list of
 352 the newly added table monikers.
 353
 354 The schema argument should be the schema class
 355 or object to be affected.  It should probably
 356 be derived from the original schema_class used
 357 during L</load>.
 358
 359 =cut
 360
 361 sub rescan {
 362     my ($self, $schema) = @_;
 363
 364     $self->{schema} = $schema;
 365     $self->{relbuilder}{schema} = $schema;
 366
 367     my @created;
 368     my @current = $self->_tables_list;
 369     foreach my $table ($self->_tables_list) {
 370         if(!exists $self->{_tables}->{$table}) {
 371             push(@created, $table);
 372         }
 373     }
 374
 375     my $loaded = $self->_load_tables(@created);
 376
 377     return map { $self->monikers->{$_} } @$loaded;
 378 }
 379
 380 sub _load_tables {
 381     my ($self, @tables) = @_;
 382
 383     # First, use _tables_list with constraint and exclude
 384     #  to get a list of tables to operate on
 385
 386     my $constraint   = $self->constraint;
 387     my $exclude      = $self->exclude;
 388
 389     @tables = grep { /$constraint/ } @tables if $constraint;
 390     @tables = grep { ! /$exclude/ } @tables if $exclude;
 391
 392     # Save the new tables to the tables list
 393     foreach (@tables) {
 394         $self->{_tables}->{$_} = 1;
 395     }
 396
 397     $self->_make_src_class($_) for @tables;
 398     $self->_setup_src_meta($_) for @tables;
 399
 400     if(!$self->skip_relationships) {
 401         # The relationship loader needs a working schema
 402         $self->{quiet} = 1;
 403         local $self->{dump_directory} = $self->{temp_directory};
 404         $self->_reload_classes(@tables);
 405         $self->_load_relationships($_) for @tables;
 406         $self->{quiet} = 0;
 407
 408         # Remove that temp dir from INC so it doesn't get reloaded
 409         @INC = grep { $_ ne $self->{dump_directory} } @INC;
 410     }
 411
 412     $self->_load_external($_)
 413         for map { $self->classes->{$_} } @tables;
 414
 415     $self->_reload_classes(@tables);
 416
 417     # Drop temporary cache
 418     delete $self->{_cache};
 419
 420     return \@tables;
 421 }
 422
 423 sub _reload_classes {
 424     my ($self, @tables) = @_;
 425
 426     # so that we don't repeat custom sections
 427     @INC = grep $_ ne $self->dump_directory, @INC;
 428
 429     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
 430
 431     unshift @INC, $self->dump_directory;
 432
 433     my @to_register;
 434     my %have_source = map { $_ => $self->schema->source($_) }
 435         $self->schema->sources;
 436
 437     for my $table (@tables) {
 438         my $moniker = $self->monikers->{$table};
 439         my $class = $self->classes->{$table};
 440
 441         {
 442             no warnings 'redefine';
 443             local *Class::C3::reinitialize = sub {};
 444             use warnings;
 445
 446             Class::Unload->unload($class);
 447             my ($source, $resultset_class);
 448             if (
 449                 ($source = $have_source{$moniker})
 450                 && ($resultset_class = $source->resultset_class)
 451                 && ($resultset_class ne 'DBIx::Class::ResultSet')
 452             ) {
 453                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
 454                 Class::Unload->unload($resultset_class);
 455                 $self->ensure_class_loaded($resultset_class) if $has_file;
 456             }
 457             $self->ensure_class_loaded($class);
 458         }
 459         push @to_register, [$moniker, $class];
 460     }
 461
 462     Class::C3->reinitialize;
 463     for (@to_register) {
 464         $self->schema->register_class(@$_);
 465     }
 466 }
 467
 468 sub _get_dump_filename {
 469     my ($self, $class) = (@_);
 470
 471     $class =~ s{::}{/}g;
 472     return $self->dump_directory . q{/} . $class . q{.pm};
 473 }
 474
 475 sub _ensure_dump_subdirs {
 476     my ($self, $class) = (@_);
 477
 478     my @name_parts = split(/::/, $class);
 479     pop @name_parts; # we don't care about the very last element,
 480                      # which is a filename
 481
 482     my $dir = $self->dump_directory;
 483     while (1) {
 484         if(!-d $dir) {
 485             mkdir($dir) or croak "mkdir('$dir') failed: $!";
 486         }
 487         last if !@name_parts;
 488         $dir = File::Spec->catdir($dir, shift @name_parts);
 489     }
 490 }
 491
 492 sub _dump_to_dir {
 493     my ($self, @classes) = @_;
 494
 495     my $schema_class = $self->schema_class;
 496     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
 497
 498     my $target_dir = $self->dump_directory;
 499     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
 500         unless $self->{dynamic} or $self->{quiet};
 501
 502     my $schema_text =
 503           qq|package $schema_class;\n\n|
 504         . qq|# Created by DBIx::Class::Schema::Loader\n|
 505         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
 506         . qq|use strict;\nuse warnings;\n\n|
 507         . qq|use base '$schema_base_class';\n\n|;
 508
 509     if ($self->use_namespaces) {
 510         $schema_text .= qq|__PACKAGE__->load_namespaces|;
 511         my $namespace_options;
 512         for my $attr (qw(result_namespace
 513                          resultset_namespace
 514                          default_resultset_class)) {
 515             if ($self->$attr) {
 516                 $namespace_options .= qq|    $attr => '| . $self->$attr . qq|',\n|
 517             }
 518         }
 519         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
 520         $schema_text .= qq|;\n|;
 521     }
 522     else {
 523         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
 524     }
 525
 526     $self->_write_classfile($schema_class, $schema_text);
 527
 528     my $result_base_class = $self->result_base_class || 'DBIx::Class';
 529
 530     foreach my $src_class (@classes) {
 531         my $src_text =
 532               qq|package $src_class;\n\n|
 533             . qq|# Created by DBIx::Class::Schema::Loader\n|
 534             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
 535             . qq|use strict;\nuse warnings;\n\n|
 536             . qq|use base '$result_base_class';\n\n|;
 537
 538         $self->_write_classfile($src_class, $src_text);
 539     }
 540
 541     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
 542
 543 }
 544
 545 sub _sig_comment {
 546     my ($self, $version, $ts) = @_;
 547     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
 548          . qq| v| . $version
 549          . q| @ | . $ts
 550          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
 551 }
 552
 553 sub _write_classfile {
 554     my ($self, $class, $text) = @_;
 555
 556     my $filename = $self->_get_dump_filename($class);
 557     $self->_ensure_dump_subdirs($class);
 558
 559     if (-f $filename && $self->really_erase_my_files) {
 560         warn "Deleting existing file '$filename' due to "
 561             . "'really_erase_my_files' setting\n" unless $self->{quiet};
 562         unlink($filename);
 563     }
 564
 565     my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
 566
 567     $text .= qq|$_\n|
 568         for @{$self->{_dump_storage}->{$class} || []};
 569
 570     # Check and see if the dump is infact differnt
 571
 572     my $compare_to;
 573     if ($old_md5) {
 574       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
 575
 576
 577       if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
 578         return;
 579       }
 580     }
 581
 582     $text .= $self->_sig_comment(
 583       $DBIx::Class::Schema::Loader::VERSION,
 584       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
 585     );
 586
 587     open(my $fh, '>', $filename)
 588         or croak "Cannot open '$filename' for writing: $!";
 589
 590     # Write the top half and its MD5 sum
 591     print $fh $text . Digest::MD5::md5_base64($text) . "\n";
 592
 593     # Write out anything loaded via external partial class file in @INC
 594     print $fh qq|$_\n|
 595         for @{$self->{_ext_storage}->{$class} || []};
 596
 597     # Write out any custom content the user has added
 598     print $fh $custom_content;
 599
 600     close($fh)
 601         or croak "Error closing '$filename': $!";
 602 }
 603
 604 sub _default_custom_content {
 605     return qq|\n\n# You can replace this text with custom|
 606          . qq| content, and it will be preserved on regeneration|
 607          . qq|\n1;\n|;
 608 }
 609
 610 sub _get_custom_content {
 611     my ($self, $class, $filename) = @_;
 612
 613     return ($self->_default_custom_content) if ! -f $filename;
 614
 615     open(my $fh, '<', $filename)
 616         or croak "Cannot open '$filename' for reading: $!";
 617
 618     my $mark_re =
 619         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
 620
 621     my $buffer = '';
 622     my ($md5, $ts, $ver);
 623     while(<$fh>) {
 624         if(!$md5 && /$mark_re/) {
 625             $md5 = $2;
 626             my $line = $1;
 627
 628             # Pull out the previous version and timestamp
 629             ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
 630
 631             $buffer .= $line;
 632             croak "Checksum mismatch in '$filename'"
 633                 if Digest::MD5::md5_base64($buffer) ne $md5;
 634
 635             $buffer = '';
 636         }
 637         else {
 638             $buffer .= $_;
 639         }
 640     }
 641
 642     croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
 643         . " it does not appear to have been generated by Loader"
 644             if !$md5;
 645
 646     # Default custom content:
 647     $buffer ||= $self->_default_custom_content;
 648
 649     return ($buffer, $md5, $ver, $ts);
 650 }
 651
 652 sub _use {
 653     my $self = shift;
 654     my $target = shift;
 655
 656     foreach (@_) {
 657         warn "$target: use $_;" if $self->debug;
 658         $self->_raw_stmt($target, "use $_;");
 659     }
 660 }
 661
 662 sub _inject {
 663     my $self = shift;
 664     my $target = shift;
 665     my $schema_class = $self->schema_class;
 666
 667     my $blist = join(q{ }, @_);
 668     warn "$target: use base qw/ $blist /;" if $self->debug && @_;
 669     $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
 670 }
 671
 672 # Create class with applicable bases, setup monikers, etc
 673 sub _make_src_class {
 674     my ($self, $table) = @_;
 675
 676     my $schema       = $self->schema;
 677     my $schema_class = $self->schema_class;
 678
 679     my $table_moniker = $self->_table2moniker($table);
 680     my @result_namespace = ($schema_class);
 681     if ($self->use_namespaces) {
 682         my $result_namespace = $self->result_namespace || 'Result';
 683         if ($result_namespace =~ /^\+(.*)/) {
 684             # Fully qualified namespace
 685             @result_namespace =  ($1)
 686         }
 687         else {
 688             # Relative namespace
 689             push @result_namespace, $result_namespace;
 690         }
 691     }
 692     my $table_class = join(q{::}, @result_namespace, $table_moniker);
 693
 694     my $table_normalized = lc $table;
 695     $self->classes->{$table} = $table_class;
 696     $self->classes->{$table_normalized} = $table_class;
 697     $self->monikers->{$table} = $table_moniker;
 698     $self->monikers->{$table_normalized} = $table_moniker;
 699
 700     $self->_use   ($table_class, @{$self->additional_classes});
 701     $self->_inject($table_class, @{$self->left_base_classes});
 702
 703     $self->_dbic_stmt($table_class, 'load_components', @{$self->components}, 'Core');
 704
 705     $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
 706         if @{$self->resultset_components};
 707     $self->_inject($table_class, @{$self->additional_base_classes});
 708 }
 709
 710 # Set up metadata (cols, pks, etc)
 711 sub _setup_src_meta {
 712     my ($self, $table) = @_;
 713
 714     my $schema       = $self->schema;
 715     my $schema_class = $self->schema_class;
 716
 717     my $table_class = $self->classes->{$table};
 718     my $table_moniker = $self->monikers->{$table};
 719
 720     my $table_name = $table;
 721     my $name_sep   = $self->schema->storage->sql_maker->name_sep;
 722
 723     if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
 724         $table_name = \ $self->_quote_table_name($table_name);
 725     }
 726
 727     $self->_dbic_stmt($table_class,'table',$table_name);
 728
 729     my $cols = $self->_table_columns($table);
 730     my $col_info;
 731     eval { $col_info = $self->_columns_info_for($table) };
 732     if($@) {
 733         $self->_dbic_stmt($table_class,'add_columns',@$cols);
 734     }
 735     else {
 736         if ($self->_is_case_sensitive) {
 737             for my $col (keys %$col_info) {
 738                 $col_info->{$col}{accessor} = lc $col
 739                     if $col ne lc($col);
 740             }
 741         } else {
 742             $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
 743         }
 744
 745         my $fks = $self->_table_fk_info($table);
 746
 747         for my $fkdef (@$fks) {
 748             for my $col (@{ $fkdef->{local_columns} }) {
 749                 $col_info->{$col}{is_foreign_key} = 1;
 750             }
 751         }
 752         $self->_dbic_stmt(
 753             $table_class,
 754             'add_columns',
 755             map { $_, ($col_info->{$_}||{}) } @$cols
 756         );
 757     }
 758
 759     my %uniq_tag; # used to eliminate duplicate uniqs
 760
 761     my $pks = $self->_table_pk_info($table) || [];
 762     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
 763           : carp("$table has no primary key");
 764     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
 765
 766     my $uniqs = $self->_table_uniq_info($table) || [];
 767     for (@$uniqs) {
 768         my ($name, $cols) = @$_;
 769         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
 770         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
 771     }
 772
 773 }
 774
 775 =head2 tables
 776
 777 Returns a sorted list of loaded tables, using the original database table
 778 names.
 779
 780 =cut
 781
 782 sub tables {
 783     my $self = shift;
 784
 785     return keys %{$self->_tables};
 786 }
 787
 788 # Make a moniker from a table
 789 sub _default_table2moniker {
 790     my ($self, $table) = @_;
 791
 792     return join '', map ucfirst, split /[\W_]+/,
 793         Lingua::EN::Inflect::Number::to_S(lc $table);
 794 }
 795
 796 sub _table2moniker {
 797     my ( $self, $table ) = @_;
 798
 799     my $moniker;
 800
 801     if( ref $self->moniker_map eq 'HASH' ) {
 802         $moniker = $self->moniker_map->{$table};
 803     }
 804     elsif( ref $self->moniker_map eq 'CODE' ) {
 805         $moniker = $self->moniker_map->($table);
 806     }
 807
 808     $moniker ||= $self->_default_table2moniker($table);
 809
 810     return $moniker;
 811 }
 812
 813 sub _load_relationships {
 814     my ($self, $table) = @_;
 815
 816     my $tbl_fk_info = $self->_table_fk_info($table);
 817     foreach my $fkdef (@$tbl_fk_info) {
 818         $fkdef->{remote_source} =
 819             $self->monikers->{delete $fkdef->{remote_table}};
 820     }
 821     my $tbl_uniq_info = $self->_table_uniq_info($table);
 822
 823     my $local_moniker = $self->monikers->{$table};
 824     my $rel_stmts = $self->{relbuilder}->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
 825
 826     foreach my $src_class (sort keys %$rel_stmts) {
 827         my $src_stmts = $rel_stmts->{$src_class};
 828         foreach my $stmt (@$src_stmts) {
 829             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
 830         }
 831     }
 832 }
 833
 834 # Overload these in driver class:
 835
 836 # Returns an arrayref of column names
 837 sub _table_columns { croak "ABSTRACT METHOD" }
 838
 839 # Returns arrayref of pk col names
 840 sub _table_pk_info { croak "ABSTRACT METHOD" }
 841
 842 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
 843 sub _table_uniq_info { croak "ABSTRACT METHOD" }
 844
 845 # Returns an arrayref of foreign key constraints, each
 846 #   being a hashref with 3 keys:
 847 #   local_columns (arrayref), remote_columns (arrayref), remote_table
 848 sub _table_fk_info { croak "ABSTRACT METHOD" }
 849
 850 # Returns an array of lower case table names
 851 sub _tables_list { croak "ABSTRACT METHOD" }
 852
 853 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
 854 sub _dbic_stmt {
 855     my $self = shift;
 856     my $class = shift;
 857     my $method = shift;
 858     if ( $method eq 'table' ) {
 859         my ($table) = @_;
 860         $self->_pod( $class, "=head1 NAME" );
 861         my $table_descr = $class;
 862         if ( $self->can('_table_comment') ) {
 863             my $comment = $self->_table_comment($table);
 864             $table_descr .= " - " . $comment if $comment;
 865         }
 866         $self->{_class2table}{ $class } = $table;
 867         $self->_pod( $class, $table_descr );
 868         $self->_pod_cut( $class );
 869     } elsif ( $method eq 'add_columns' ) {
 870         $self->_pod( $class, "=head1 ACCESSORS" );
 871         my $i = 0;
 872         foreach ( @_ ) {
 873             $i++;
 874             next unless $i % 2;
 875             $self->_pod( $class, '=head2 ' . $_  );
 876             my $comment;
 877             $comment = $self->_column_comment( $self->{_class2table}{$class}, ($i - 1) / 2 + 1  ) if $self->can('_column_comment');
 878             $self->_pod( $class, $comment ) if $comment;
 879         }
 880         $self->_pod_cut( $class );
 881     } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
 882         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
 883         my ( $accessor, $rel_class ) = @_;
 884         $self->_pod( $class, "=head2 $accessor" );
 885         $self->_pod( $class, 'Type: ' . $method );
 886         $self->_pod( $class, "Related object: L<$rel_class>" );
 887         $self->_pod_cut( $class );
 888         $self->{_relations_started} { $class } = 1;
 889     }
 890     my $args = dump(@_);
 891     $args = '(' . $args . ')' if @_ < 2;
 892     my $stmt = $method . $args . q{;};
 893
 894     warn qq|$class\->$stmt\n| if $self->debug;
 895     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
 896     return;
 897 }
 898
 899 # Stores a POD documentation
 900 sub _pod {
 901     my ($self, $class, $stmt) = @_;
 902     $self->_raw_stmt( $class, "\n" . $stmt  );
 903 }
 904
 905 sub _pod_cut {
 906     my ($self, $class ) = @_;
 907     $self->_raw_stmt( $class, "\n=cut\n" );
 908 }
 909
 910
 911 # Store a raw source line for a class (for dumping purposes)
 912 sub _raw_stmt {
 913     my ($self, $class, $stmt) = @_;
 914     push(@{$self->{_dump_storage}->{$class}}, $stmt);
 915 }
 916
 917 # Like above, but separately for the externally loaded stuff
 918 sub _ext_stmt {
 919     my ($self, $class, $stmt) = @_;
 920     push(@{$self->{_ext_storage}->{$class}}, $stmt);
 921 }
 922
 923 sub _quote_table_name {
 924     my ($self, $table) = @_;
 925
 926     my $qt = $self->schema->storage->sql_maker->quote_char;
 927
 928     return $table unless $qt;
 929
 930     if (ref $qt) {
 931         return $qt->[0] . $table . $qt->[1];
 932     }
 933
 934     return $qt . $table . $qt;
 935 }
 936
 937 sub _is_case_sensitive { 0 }
 938
 939 =head2 monikers
 940
 941 Returns a hashref of loaded table to moniker mappings.  There will
 942 be two entries for each table, the original name and the "normalized"
 943 name, in the case that the two are different (such as databases
 944 that like uppercase table names, or preserve your original mixed-case
 945 definitions, or what-have-you).
 946
 947 =head2 classes
 948
 949 Returns a hashref of table to class mappings.  In some cases it will
 950 contain multiple entries per table for the original and normalized table
 951 names, as above in L</monikers>.
 952
 953 =head1 SEE ALSO
 954
 955 L<DBIx::Class::Schema::Loader>
 956
 957 =head1 AUTHOR
 958
 959 See L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 960
 961 =head1 LICENSE
 962
 963 This library is free software; you can redistribute it and/or modify it under
 964 the same terms as Perl itself.
 965
 966 =cut
 967
 968 1;