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