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