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