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