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                                 dynamic
  52                              /);
  53
  54 __PACKAGE__->mk_accessors(qw/
  55                                 version_to_dump
  56 /);
  57
  58 =head1 NAME
  59
  60 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
  61
  62 =head1 SYNOPSIS
  63
  64 See L<DBIx::Class::Schema::Loader>
  65
  66 =head1 DESCRIPTION
  67
  68 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
  69 classes, and implements the common functionality between them.
  70
  71 =head1 CONSTRUCTOR OPTIONS
  72
  73 These constructor options are the base options for
  74 L<DBIx::Class::Schema::Loader/loader_options>.  Available constructor options are:
  75
  76 =head2 skip_relationships
  77
  78 Skip setting up relationships.  The default is to attempt the loading
  79 of relationships.
  80
  81 =head2 naming
  82
  83 Static schemas (ones dumped to disk) will, by default, use the new-style 0.05XXX
  84 relationship names and singularized Results, unless you're overwriting an
  85 existing dump made by a 0.04XXX version of L<DBIx::Class::Schema::Loader>, in
  86 which case the backward compatible RelBuilder will be activated, and
  87 singularization will be turned off.
  88
  89 Specifying
  90
  91     naming => 'v5'
  92
  93 will disable the backward-compatible RelBuilder and use
  94 the new-style relationship names along with singularized Results, even when
  95 overwriting a dump made with an earlier version.
  96
  97 The option also takes a hashref:
  98
  99     naming => { relationships => 'v5', results => 'v4' }
 100
 101 The values can be:
 102
 103 =over 4
 104
 105 =item current
 106
 107 Latest default style, whatever that happens to be.
 108
 109 =item v5
 110
 111 Version 0.05XXX style.
 112
 113 =item v4
 114
 115 Version 0.04XXX style.
 116
 117 =back
 118
 119 Dynamic schemas will always default to the 0.04XXX relationship names and won't
 120 singularize Results for backward compatibility, to activate the new RelBuilder
 121 and singularization put this in your C<Schema.pm> file:
 122
 123     __PACKAGE__->naming('current');
 124
 125 Or if you prefer to use 0.05XXX features but insure that nothing breaks in the
 126 next major version upgrade:
 127
 128     __PACKAGE__->naming('v5');
 129
 130 =head2 debug
 131
 132 If set to true, each constructive L<DBIx::Class> statement the loader
 133 decides to execute will be C<warn>-ed before execution.
 134
 135 =head2 db_schema
 136
 137 Set the name of the schema to load (schema in the sense that your database
 138 vendor means it).  Does not currently support loading more than one schema
 139 name.
 140
 141 =head2 constraint
 142
 143 Only load tables matching regex.  Best specified as a qr// regex.
 144
 145 =head2 exclude
 146
 147 Exclude tables matching regex.  Best specified as a qr// regex.
 148
 149 =head2 moniker_map
 150
 151 Overrides the default table name to moniker translation.  Can be either
 152 a hashref of table keys and moniker values, or a coderef for a translator
 153 function taking a single scalar table name argument and returning
 154 a scalar moniker.  If the hash entry does not exist, or the function
 155 returns a false value, the code falls back to default behavior
 156 for that table name.
 157
 158 The default behavior is: C<join '', map ucfirst, split /[\W_]+/, lc $table>,
 159 which is to say: lowercase everything, split up the table name into chunks
 160 anywhere a non-alpha-numeric character occurs, change the case of first letter
 161 of each chunk to upper case, and put the chunks back together.  Examples:
 162
 163     Table Name  | Moniker Name
 164     ---------------------------
 165     luser       | Luser
 166     luser_group | LuserGroup
 167     luser-opts  | LuserOpts
 168
 169 =head2 inflect_plural
 170
 171 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
 172 if hash key does not exist or coderef returns false), but acts as a map
 173 for pluralizing relationship names.  The default behavior is to utilize
 174 L<Lingua::EN::Inflect::Number/to_PL>.
 175
 176 =head2 inflect_singular
 177
 178 As L</inflect_plural> above, but for singularizing relationship names.
 179 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
 180
 181 =head2 schema_base_class
 182
 183 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
 184
 185 =head2 result_base_class
 186
 187 Base class for your table classes (aka result classes). Defaults to 'DBIx::Class'.
 188
 189 =head2 additional_base_classes
 190
 191 List of additional base classes all of your table classes will use.
 192
 193 =head2 left_base_classes
 194
 195 List of additional base classes all of your table classes will use
 196 that need to be leftmost.
 197
 198 =head2 additional_classes
 199
 200 List of additional classes which all of your table classes will use.
 201
 202 =head2 components
 203
 204 List of additional components to be loaded into all of your table
 205 classes.  A good example would be C<ResultSetManager>.
 206
 207 =head2 resultset_components
 208
 209 List of additional ResultSet components to be loaded into your table
 210 classes.  A good example would be C<AlwaysRS>.  Component
 211 C<ResultSetManager> will be automatically added to the above
 212 C<components> list if this option is set.
 213
 214 =head2 use_namespaces
 215
 216 Generate result class names suitable for
 217 L<DBIx::Class::Schema/load_namespaces> and call that instead of
 218 L<DBIx::Class::Schema/load_classes>. When using this option you can also
 219 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
 220 C<resultset_namespace>, C<default_resultset_class>), and they will be added
 221 to the call (and the generated result class names adjusted appropriately).
 222
 223 =head2 dump_directory
 224
 225 This option is designed to be a tool to help you transition from this
 226 loader to a manually-defined schema when you decide it's time to do so.
 227
 228 The value of this option is a perl libdir pathname.  Within
 229 that directory this module will create a baseline manual
 230 L<DBIx::Class::Schema> module set, based on what it creates at runtime
 231 in memory.
 232
 233 The created schema class will have the same classname as the one on
 234 which you are setting this option (and the ResultSource classes will be
 235 based on this name as well).
 236
 237 Normally you wouldn't hard-code this setting in your schema class, as it
 238 is meant for one-time manual usage.
 239
 240 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
 241 recommended way to access this functionality.
 242
 243 =head2 dump_overwrite
 244
 245 Deprecated.  See L</really_erase_my_files> below, which does *not* mean
 246 the same thing as the old C<dump_overwrite> setting from previous releases.
 247
 248 =head2 really_erase_my_files
 249
 250 Default false.  If true, Loader will unconditionally delete any existing
 251 files before creating the new ones from scratch when dumping a schema to disk.
 252
 253 The default behavior is instead to only replace the top portion of the
 254 file, up to and including the final stanza which contains
 255 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
 256 leaving any customizations you placed after that as they were.
 257
 258 When C<really_erase_my_files> is not set, if the output file already exists,
 259 but the aforementioned final stanza is not found, or the checksum
 260 contained there does not match the generated contents, Loader will
 261 croak and not touch the file.
 262
 263 You should really be using version control on your schema classes (and all
 264 of the rest of your code for that matter).  Don't blame me if a bug in this
 265 code wipes something out when it shouldn't have, you've been warned.
 266
 267 =head1 METHODS
 268
 269 None of these methods are intended for direct invocation by regular
 270 users of L<DBIx::Class::Schema::Loader>.  Anything you can find here
 271 can also be found via standard L<DBIx::Class::Schema> methods somehow.
 272
 273 =cut
 274
 275 # ensure that a peice of object data is a valid arrayref, creating
 276 # an empty one or encapsulating whatever's there.
 277 sub _ensure_arrayref {
 278     my $self = shift;
 279
 280     foreach (@_) {
 281         $self->{$_} ||= [];
 282         $self->{$_} = [ $self->{$_} ]
 283             unless ref $self->{$_} eq 'ARRAY';
 284     }
 285 }
 286
 287 =head2 new
 288
 289 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
 290 by L<DBIx::Class::Schema::Loader>.
 291
 292 =cut
 293
 294 sub new {
 295     my ( $class, %args ) = @_;
 296
 297     my $self = { %args };
 298
 299     bless $self => $class;
 300
 301     $self->_ensure_arrayref(qw/additional_classes
 302                                additional_base_classes
 303                                left_base_classes
 304                                components
 305                                resultset_components
 306                               /);
 307
 308     push(@{$self->{components}}, 'ResultSetManager')
 309         if @{$self->{resultset_components}};
 310
 311     $self->{monikers} = {};
 312     $self->{classes} = {};
 313
 314     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
 315     $self->{schema} ||= $self->{schema_class};
 316
 317     croak "dump_overwrite is deprecated.  Please read the"
 318         . " DBIx::Class::Schema::Loader::Base documentation"
 319             if $self->{dump_overwrite};
 320
 321     $self->{dynamic} = ! $self->{dump_directory};
 322     $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
 323                                                      TMPDIR  => 1,
 324                                                      CLEANUP => 1,
 325                                                    );
 326
 327     $self->{dump_directory} ||= $self->{temp_directory};
 328
 329     $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 330
 331     $self->_check_back_compat;
 332
 333     $self;
 334 }
 335
 336 sub _check_back_compat {
 337     my ($self) = @_;
 338
 339 # dynamic schemas will always be in 0.04006 mode
 340     if ($self->dynamic) {
 341         no strict 'refs';
 342         my $class = ref $self || $self;
 343         require DBIx::Class::Schema::Loader::Compat::v0_040;
 344         unshift @{"${class}::ISA"},
 345             'DBIx::Class::Schema::Loader::Compat::v0_040';
 346         Class::C3::reinitialize;
 347 # just in case, though no one is likely to dump a dynamic schema
 348         $self->version_to_dump('0.04006');
 349         return;
 350     }
 351
 352 # otherwise check if we need backcompat mode for a static schema
 353     my $filename = $self->_get_dump_filename($self->schema_class);
 354     return unless -e $filename;
 355
 356     open(my $fh, '<', $filename)
 357         or croak "Cannot open '$filename' for reading: $!";
 358
 359     while (<$fh>) {
 360         if (/^# Created by DBIx::Class::Schema::Loader v((\d+)\.(\d+))/) {
 361             my $real_ver = $1;
 362             my $ver      = "v${2}_${3}";
 363             while (1) {
 364                 my $compat_class = "DBIx::Class::Schema::Loader::Compat::${ver}";
 365                 if ($self->load_optional_class($compat_class)) {
 366                     no strict 'refs';
 367                     my $class = ref $self || $self;
 368                     unshift @{"${class}::ISA"}, $compat_class;
 369                     Class::C3::reinitialize;
 370                     $self->version_to_dump($real_ver);
 371                     last;
 372                 }
 373                 $ver =~ s/\d\z// or last;
 374             }
 375             last;
 376         }
 377     }
 378     close $fh;
 379 }
 380
 381 sub _find_file_in_inc {
 382     my ($self, $file) = @_;
 383
 384     foreach my $prefix (@INC) {
 385         my $fullpath = File::Spec->catfile($prefix, $file);
 386         return $fullpath if -f $fullpath
 387             and Cwd::abs_path($fullpath) ne
 388                 Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || '';
 389     }
 390
 391     return;
 392 }
 393
 394 sub _class_path {
 395     my ($self, $class) = @_;
 396
 397     my $class_path = $class;
 398     $class_path =~ s{::}{/}g;
 399     $class_path .= '.pm';
 400
 401     return $class_path;
 402 }
 403
 404 sub _find_class_in_inc {
 405     my ($self, $class) = @_;
 406
 407     return $self->_find_file_in_inc($self->_class_path($class));
 408 }
 409
 410 sub _load_external {
 411     my ($self, $class) = @_;
 412
 413     my $real_inc_path = $self->_find_class_in_inc($class);
 414
 415     return if !$real_inc_path;
 416
 417     # If we make it to here, we loaded an external definition
 418     warn qq/# Loaded external class definition for '$class'\n/
 419         if $self->debug;
 420
 421     open(my $fh, '<', $real_inc_path)
 422         or croak "Failed to open '$real_inc_path' for reading: $!";
 423     $self->_ext_stmt($class,
 424          qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
 425         .qq|# They are now part of the custom portion of this file\n|
 426         .qq|# for you to hand-edit.  If you do not either delete\n|
 427         .qq|# this section or remove that file from \@INC, this section\n|
 428         .qq|# will be repeated redundantly when you re-create this\n|
 429         .qq|# file again via Loader!\n|
 430     );
 431     while(<$fh>) {
 432         chomp;
 433         $self->_ext_stmt($class, $_);
 434     }
 435     $self->_ext_stmt($class,
 436         qq|# End of lines loaded from '$real_inc_path' |
 437     );
 438     close($fh)
 439         or croak "Failed to close $real_inc_path: $!";
 440
 441     if ($self->dynamic) { # load the class too
 442         # turn off redefined warnings
 443         local $SIG{__WARN__} = sub {};
 444         do $real_inc_path;
 445         die $@ if $@;
 446     }
 447 }
 448
 449 =head2 load
 450
 451 Does the actual schema-construction work.
 452
 453 =cut
 454
 455 sub load {
 456     my $self = shift;
 457
 458     $self->_load_tables($self->_tables_list);
 459 }
 460
 461 =head2 rescan
 462
 463 Arguments: schema
 464
 465 Rescan the database for newly added tables.  Does
 466 not process drops or changes.  Returns a list of
 467 the newly added table monikers.
 468
 469 The schema argument should be the schema class
 470 or object to be affected.  It should probably
 471 be derived from the original schema_class used
 472 during L</load>.
 473
 474 =cut
 475
 476 sub rescan {
 477     my ($self, $schema) = @_;
 478
 479     $self->{schema} = $schema;
 480     $self->_relbuilder->{schema} = $schema;
 481
 482     my @created;
 483     my @current = $self->_tables_list;
 484     foreach my $table ($self->_tables_list) {
 485         if(!exists $self->{_tables}->{$table}) {
 486             push(@created, $table);
 487         }
 488     }
 489
 490     my $loaded = $self->_load_tables(@created);
 491
 492     return map { $self->monikers->{$_} } @$loaded;
 493 }
 494
 495 sub _relbuilder {
 496     my ($self) = @_;
 497
 498     return if $self->{skip_relationships};
 499
 500     $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new(
 501         $self->schema, $self->inflect_plural, $self->inflect_singular
 502     );
 503 }
 504
 505 sub _load_tables {
 506     my ($self, @tables) = @_;
 507
 508     # First, use _tables_list with constraint and exclude
 509     #  to get a list of tables to operate on
 510
 511     my $constraint   = $self->constraint;
 512     my $exclude      = $self->exclude;
 513
 514     @tables = grep { /$constraint/ } @tables if $constraint;
 515     @tables = grep { ! /$exclude/ } @tables if $exclude;
 516
 517     # Save the new tables to the tables list
 518     foreach (@tables) {
 519         $self->{_tables}->{$_} = 1;
 520     }
 521
 522     $self->_make_src_class($_) for @tables;
 523     $self->_setup_src_meta($_) for @tables;
 524
 525     if(!$self->skip_relationships) {
 526         # The relationship loader needs a working schema
 527         $self->{quiet} = 1;
 528         local $self->{dump_directory} = $self->{temp_directory};
 529         $self->_reload_classes(\@tables);
 530         $self->_load_relationships($_) for @tables;
 531         $self->{quiet} = 0;
 532
 533         # Remove that temp dir from INC so it doesn't get reloaded
 534         @INC = grep { $_ ne $self->{dump_directory} } @INC;
 535     }
 536
 537     $self->_load_external($_)
 538         for map { $self->classes->{$_} } @tables;
 539
 540     # Reload without unloading first to preserve any symbols from external
 541     # packages.
 542     $self->_reload_classes(\@tables, 0);
 543
 544     # Drop temporary cache
 545     delete $self->{_cache};
 546
 547     return \@tables;
 548 }
 549
 550 sub _reload_classes {
 551     my ($self, $tables, $unload) = @_;
 552
 553     my @tables = @$tables;
 554     $unload = 1 unless defined $unload;
 555
 556     # so that we don't repeat custom sections
 557     @INC = grep $_ ne $self->dump_directory, @INC;
 558
 559     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
 560
 561     unshift @INC, $self->dump_directory;
 562
 563     my @to_register;
 564     my %have_source = map { $_ => $self->schema->source($_) }
 565         $self->schema->sources;
 566
 567     for my $table (@tables) {
 568         my $moniker = $self->monikers->{$table};
 569         my $class = $self->classes->{$table};
 570
 571         {
 572             no warnings 'redefine';
 573             local *Class::C3::reinitialize = sub {};
 574             use warnings;
 575
 576             Class::Unload->unload($class) if $unload;
 577             my ($source, $resultset_class);
 578             if (
 579                 ($source = $have_source{$moniker})
 580                 && ($resultset_class = $source->resultset_class)
 581                 && ($resultset_class ne 'DBIx::Class::ResultSet')
 582             ) {
 583                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
 584                 Class::Unload->unload($resultset_class) if $unload;
 585                 $self->_reload_class($resultset_class) if $has_file;
 586             }
 587             $self->_reload_class($class);
 588         }
 589         push @to_register, [$moniker, $class];
 590     }
 591
 592     Class::C3->reinitialize;
 593     for (@to_register) {
 594         $self->schema->register_class(@$_);
 595     }
 596 }
 597
 598 # We use this instead of ensure_class_loaded when there are package symbols we
 599 # want to preserve.
 600 sub _reload_class {
 601     my ($self, $class) = @_;
 602
 603     my $class_path = $self->_class_path($class);
 604     delete $INC{ $class_path };
 605     eval "require $class;";
 606 }
 607
 608 sub _get_dump_filename {
 609     my ($self, $class) = (@_);
 610
 611     $class =~ s{::}{/}g;
 612     return $self->dump_directory . q{/} . $class . q{.pm};
 613 }
 614
 615 sub _ensure_dump_subdirs {
 616     my ($self, $class) = (@_);
 617
 618     my @name_parts = split(/::/, $class);
 619     pop @name_parts; # we don't care about the very last element,
 620                      # which is a filename
 621
 622     my $dir = $self->dump_directory;
 623     while (1) {
 624         if(!-d $dir) {
 625             mkdir($dir) or croak "mkdir('$dir') failed: $!";
 626         }
 627         last if !@name_parts;
 628         $dir = File::Spec->catdir($dir, shift @name_parts);
 629     }
 630 }
 631
 632 sub _dump_to_dir {
 633     my ($self, @classes) = @_;
 634
 635     my $schema_class = $self->schema_class;
 636     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
 637
 638     my $target_dir = $self->dump_directory;
 639     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
 640         unless $self->{dynamic} or $self->{quiet};
 641
 642     my $schema_text =
 643           qq|package $schema_class;\n\n|
 644         . qq|# Created by DBIx::Class::Schema::Loader\n|
 645         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
 646         . qq|use strict;\nuse warnings;\n\n|
 647         . qq|use base '$schema_base_class';\n\n|;
 648
 649     if ($self->use_namespaces) {
 650         $schema_text .= qq|__PACKAGE__->load_namespaces|;
 651         my $namespace_options;
 652         for my $attr (qw(result_namespace
 653                          resultset_namespace
 654                          default_resultset_class)) {
 655             if ($self->$attr) {
 656                 $namespace_options .= qq|    $attr => '| . $self->$attr . qq|',\n|
 657             }
 658         }
 659         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
 660         $schema_text .= qq|;\n|;
 661     }
 662     else {
 663         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
 664     }
 665
 666     $self->_write_classfile($schema_class, $schema_text);
 667
 668     my $result_base_class = $self->result_base_class || 'DBIx::Class';
 669
 670     foreach my $src_class (@classes) {
 671         my $src_text =
 672               qq|package $src_class;\n\n|
 673             . qq|# Created by DBIx::Class::Schema::Loader\n|
 674             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
 675             . qq|use strict;\nuse warnings;\n\n|
 676             . qq|use base '$result_base_class';\n\n|;
 677
 678         $self->_write_classfile($src_class, $src_text);
 679     }
 680
 681     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
 682
 683 }
 684
 685 sub _sig_comment {
 686     my ($self, $version, $ts) = @_;
 687     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
 688          . qq| v| . $version
 689          . q| @ | . $ts
 690          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
 691 }
 692
 693 sub _write_classfile {
 694     my ($self, $class, $text) = @_;
 695
 696     my $filename = $self->_get_dump_filename($class);
 697     $self->_ensure_dump_subdirs($class);
 698
 699     if (-f $filename && $self->really_erase_my_files) {
 700         warn "Deleting existing file '$filename' due to "
 701             . "'really_erase_my_files' setting\n" unless $self->{quiet};
 702         unlink($filename);
 703     }
 704
 705     my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
 706
 707     $text .= qq|$_\n|
 708         for @{$self->{_dump_storage}->{$class} || []};
 709
 710     # Check and see if the dump is infact differnt
 711
 712     my $compare_to;
 713     if ($old_md5) {
 714       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
 715
 716
 717       if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
 718         return;
 719       }
 720     }
 721
 722     $text .= $self->_sig_comment(
 723       $self->version_to_dump,
 724       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
 725     );
 726
 727     open(my $fh, '>', $filename)
 728         or croak "Cannot open '$filename' for writing: $!";
 729
 730     # Write the top half and its MD5 sum
 731     print $fh $text . Digest::MD5::md5_base64($text) . "\n";
 732
 733     # Write out anything loaded via external partial class file in @INC
 734     print $fh qq|$_\n|
 735         for @{$self->{_ext_storage}->{$class} || []};
 736
 737     # Write out any custom content the user has added
 738     print $fh $custom_content;
 739
 740     close($fh)
 741         or croak "Error closing '$filename': $!";
 742 }
 743
 744 sub _default_custom_content {
 745     return qq|\n\n# You can replace this text with custom|
 746          . qq| content, and it will be preserved on regeneration|
 747          . qq|\n1;\n|;
 748 }
 749
 750 sub _get_custom_content {
 751     my ($self, $class, $filename) = @_;
 752
 753     return ($self->_default_custom_content) if ! -f $filename;
 754
 755     open(my $fh, '<', $filename)
 756         or croak "Cannot open '$filename' for reading: $!";
 757
 758     my $mark_re =
 759         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
 760
 761     my $buffer = '';
 762     my ($md5, $ts, $ver);
 763     while(<$fh>) {
 764         if(!$md5 && /$mark_re/) {
 765             $md5 = $2;
 766             my $line = $1;
 767
 768             # Pull out the previous version and timestamp
 769             ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
 770
 771             $buffer .= $line;
 772             croak "Checksum mismatch in '$filename'"
 773                 if Digest::MD5::md5_base64($buffer) ne $md5;
 774
 775             $buffer = '';
 776         }
 777         else {
 778             $buffer .= $_;
 779         }
 780     }
 781
 782     croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
 783         . " it does not appear to have been generated by Loader"
 784             if !$md5;
 785
 786     # Default custom content:
 787     $buffer ||= $self->_default_custom_content;
 788
 789     return ($buffer, $md5, $ver, $ts);
 790 }
 791
 792 sub _use {
 793     my $self = shift;
 794     my $target = shift;
 795
 796     foreach (@_) {
 797         warn "$target: use $_;" if $self->debug;
 798         $self->_raw_stmt($target, "use $_;");
 799     }
 800 }
 801
 802 sub _inject {
 803     my $self = shift;
 804     my $target = shift;
 805     my $schema_class = $self->schema_class;
 806
 807     my $blist = join(q{ }, @_);
 808     warn "$target: use base qw/ $blist /;" if $self->debug && @_;
 809     $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
 810 }
 811
 812 # Create class with applicable bases, setup monikers, etc
 813 sub _make_src_class {
 814     my ($self, $table) = @_;
 815
 816     my $schema       = $self->schema;
 817     my $schema_class = $self->schema_class;
 818
 819     my $table_moniker = $self->_table2moniker($table);
 820     my @result_namespace = ($schema_class);
 821     if ($self->use_namespaces) {
 822         my $result_namespace = $self->result_namespace || 'Result';
 823         if ($result_namespace =~ /^\+(.*)/) {
 824             # Fully qualified namespace
 825             @result_namespace =  ($1)
 826         }
 827         else {
 828             # Relative namespace
 829             push @result_namespace, $result_namespace;
 830         }
 831     }
 832     my $table_class = join(q{::}, @result_namespace, $table_moniker);
 833
 834     my $table_normalized = lc $table;
 835     $self->classes->{$table} = $table_class;
 836     $self->classes->{$table_normalized} = $table_class;
 837     $self->monikers->{$table} = $table_moniker;
 838     $self->monikers->{$table_normalized} = $table_moniker;
 839
 840     $self->_use   ($table_class, @{$self->additional_classes});
 841     $self->_inject($table_class, @{$self->left_base_classes});
 842
 843     $self->_dbic_stmt($table_class, 'load_components', @{$self->components}, 'Core');
 844
 845     $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
 846         if @{$self->resultset_components};
 847     $self->_inject($table_class, @{$self->additional_base_classes});
 848 }
 849
 850 # Set up metadata (cols, pks, etc)
 851 sub _setup_src_meta {
 852     my ($self, $table) = @_;
 853
 854     my $schema       = $self->schema;
 855     my $schema_class = $self->schema_class;
 856
 857     my $table_class = $self->classes->{$table};
 858     my $table_moniker = $self->monikers->{$table};
 859
 860     my $table_name = $table;
 861     my $name_sep   = $self->schema->storage->sql_maker->name_sep;
 862
 863     if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
 864         $table_name = \ $self->_quote_table_name($table_name);
 865     }
 866
 867     $self->_dbic_stmt($table_class,'table',$table_name);
 868
 869     my $cols = $self->_table_columns($table);
 870     my $col_info;
 871     eval { $col_info = $self->_columns_info_for($table) };
 872     if($@) {
 873         $self->_dbic_stmt($table_class,'add_columns',@$cols);
 874     }
 875     else {
 876         if ($self->_is_case_sensitive) {
 877             for my $col (keys %$col_info) {
 878                 $col_info->{$col}{accessor} = lc $col
 879                     if $col ne lc($col);
 880             }
 881         } else {
 882             $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
 883         }
 884
 885         my $fks = $self->_table_fk_info($table);
 886
 887         for my $fkdef (@$fks) {
 888             for my $col (@{ $fkdef->{local_columns} }) {
 889                 $col_info->{$col}{is_foreign_key} = 1;
 890             }
 891         }
 892         $self->_dbic_stmt(
 893             $table_class,
 894             'add_columns',
 895             map { $_, ($col_info->{$_}||{}) } @$cols
 896         );
 897     }
 898
 899     my %uniq_tag; # used to eliminate duplicate uniqs
 900
 901     my $pks = $self->_table_pk_info($table) || [];
 902     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
 903           : carp("$table has no primary key");
 904     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
 905
 906     my $uniqs = $self->_table_uniq_info($table) || [];
 907     for (@$uniqs) {
 908         my ($name, $cols) = @$_;
 909         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
 910         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
 911     }
 912
 913 }
 914
 915 =head2 tables
 916
 917 Returns a sorted list of loaded tables, using the original database table
 918 names.
 919
 920 =cut
 921
 922 sub tables {
 923     my $self = shift;
 924
 925     return keys %{$self->_tables};
 926 }
 927
 928 # Make a moniker from a table
 929 sub _default_table2moniker {
 930     my ($self, $table) = @_;
 931
 932     return join '', map ucfirst, split /[\W_]+/,
 933         Lingua::EN::Inflect::Number::to_S(lc $table);
 934 }
 935
 936 sub _table2moniker {
 937     my ( $self, $table ) = @_;
 938
 939     my $moniker;
 940
 941     if( ref $self->moniker_map eq 'HASH' ) {
 942         $moniker = $self->moniker_map->{$table};
 943     }
 944     elsif( ref $self->moniker_map eq 'CODE' ) {
 945         $moniker = $self->moniker_map->($table);
 946     }
 947
 948     $moniker ||= $self->_default_table2moniker($table);
 949
 950     return $moniker;
 951 }
 952
 953 sub _load_relationships {
 954     my ($self, $table) = @_;
 955
 956     my $tbl_fk_info = $self->_table_fk_info($table);
 957     foreach my $fkdef (@$tbl_fk_info) {
 958         $fkdef->{remote_source} =
 959             $self->monikers->{delete $fkdef->{remote_table}};
 960     }
 961     my $tbl_uniq_info = $self->_table_uniq_info($table);
 962
 963     my $local_moniker = $self->monikers->{$table};
 964     my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
 965
 966     foreach my $src_class (sort keys %$rel_stmts) {
 967         my $src_stmts = $rel_stmts->{$src_class};
 968         foreach my $stmt (@$src_stmts) {
 969             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
 970         }
 971     }
 972 }
 973
 974 # Overload these in driver class:
 975
 976 # Returns an arrayref of column names
 977 sub _table_columns { croak "ABSTRACT METHOD" }
 978
 979 # Returns arrayref of pk col names
 980 sub _table_pk_info { croak "ABSTRACT METHOD" }
 981
 982 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
 983 sub _table_uniq_info { croak "ABSTRACT METHOD" }
 984
 985 # Returns an arrayref of foreign key constraints, each
 986 #   being a hashref with 3 keys:
 987 #   local_columns (arrayref), remote_columns (arrayref), remote_table
 988 sub _table_fk_info { croak "ABSTRACT METHOD" }
 989
 990 # Returns an array of lower case table names
 991 sub _tables_list { croak "ABSTRACT METHOD" }
 992
 993 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
 994 sub _dbic_stmt {
 995     my $self = shift;
 996     my $class = shift;
 997     my $method = shift;
 998     if ( $method eq 'table' ) {
 999         my ($table) = @_;
1000         $self->_pod( $class, "=head1 NAME" );
1001         my $table_descr = $class;
1002         if ( $self->can('_table_comment') ) {
1003             my $comment = $self->_table_comment($table);
1004             $table_descr .= " - " . $comment if $comment;
1005         }
1006         $self->{_class2table}{ $class } = $table;
1007         $self->_pod( $class, $table_descr );
1008         $self->_pod_cut( $class );
1009     } elsif ( $method eq 'add_columns' ) {
1010         $self->_pod( $class, "=head1 ACCESSORS" );
1011         my $i = 0;
1012         foreach ( @_ ) {
1013             $i++;
1014             next unless $i % 2;
1015             $self->_pod( $class, '=head2 ' . $_  );
1016             my $comment;
1017             $comment = $self->_column_comment( $self->{_class2table}{$class}, ($i - 1) / 2 + 1  ) if $self->can('_column_comment');
1018             $self->_pod( $class, $comment ) if $comment;
1019         }
1020         $self->_pod_cut( $class );
1021     } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1022         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1023         my ( $accessor, $rel_class ) = @_;
1024         $self->_pod( $class, "=head2 $accessor" );
1025         $self->_pod( $class, 'Type: ' . $method );
1026         $self->_pod( $class, "Related object: L<$rel_class>" );
1027         $self->_pod_cut( $class );
1028         $self->{_relations_started} { $class } = 1;
1029     }
1030     my $args = dump(@_);
1031     $args = '(' . $args . ')' if @_ < 2;
1032     my $stmt = $method . $args . q{;};
1033
1034     warn qq|$class\->$stmt\n| if $self->debug;
1035     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1036     return;
1037 }
1038
1039 # Stores a POD documentation
1040 sub _pod {
1041     my ($self, $class, $stmt) = @_;
1042     $self->_raw_stmt( $class, "\n" . $stmt  );
1043 }
1044
1045 sub _pod_cut {
1046     my ($self, $class ) = @_;
1047     $self->_raw_stmt( $class, "\n=cut\n" );
1048 }
1049
1050
1051 # Store a raw source line for a class (for dumping purposes)
1052 sub _raw_stmt {
1053     my ($self, $class, $stmt) = @_;
1054     push(@{$self->{_dump_storage}->{$class}}, $stmt);
1055 }
1056
1057 # Like above, but separately for the externally loaded stuff
1058 sub _ext_stmt {
1059     my ($self, $class, $stmt) = @_;
1060     push(@{$self->{_ext_storage}->{$class}}, $stmt);
1061 }
1062
1063 sub _quote_table_name {
1064     my ($self, $table) = @_;
1065
1066     my $qt = $self->schema->storage->sql_maker->quote_char;
1067
1068     return $table unless $qt;
1069
1070     if (ref $qt) {
1071         return $qt->[0] . $table . $qt->[1];
1072     }
1073
1074     return $qt . $table . $qt;
1075 }
1076
1077 sub _is_case_sensitive { 0 }
1078
1079 =head2 monikers
1080
1081 Returns a hashref of loaded table to moniker mappings.  There will
1082 be two entries for each table, the original name and the "normalized"
1083 name, in the case that the two are different (such as databases
1084 that like uppercase table names, or preserve your original mixed-case
1085 definitions, or what-have-you).
1086
1087 =head2 classes
1088
1089 Returns a hashref of table to class mappings.  In some cases it will
1090 contain multiple entries per table for the original and normalized table
1091 names, as above in L</monikers>.
1092
1093 =head1 SEE ALSO
1094
1095 L<DBIx::Class::Schema::Loader>
1096
1097 =head1 AUTHOR
1098
1099 See L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1100
1101 =head1 LICENSE
1102
1103 This library is free software; you can redistribute it and/or modify it under
1104 the same terms as Perl itself.
1105
1106 =cut
1107
1108 1;