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