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     $self->_setup_src_meta($_) for @tables;
 936
 937     if(!$self->skip_relationships) {
 938         # The relationship loader needs a working schema
 939         $self->{quiet} = 1;
 940         local $self->{dump_directory} = $self->{temp_directory};
 941         $self->_reload_classes(\@tables);
 942         $self->_load_relationships($_) for @tables;
 943         $self->{quiet} = 0;
 944
 945         # Remove that temp dir from INC so it doesn't get reloaded
 946         @INC = grep $_ ne $self->dump_directory, @INC;
 947     }
 948
 949     $self->_load_external($_)
 950         for map { $self->classes->{$_} } @tables;
 951
 952     # Reload without unloading first to preserve any symbols from external
 953     # packages.
 954     $self->_reload_classes(\@tables, 0);
 955
 956     # Drop temporary cache
 957     delete $self->{_cache};
 958
 959     return \@tables;
 960 }
 961
 962 sub _reload_classes {
 963     my ($self, $tables, $unload) = @_;
 964
 965     my @tables = @$tables;
 966     $unload = 1 unless defined $unload;
 967
 968     # so that we don't repeat custom sections
 969     @INC = grep $_ ne $self->dump_directory, @INC;
 970
 971     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
 972
 973     unshift @INC, $self->dump_directory;
 974
 975     my @to_register;
 976     my %have_source = map { $_ => $self->schema->source($_) }
 977         $self->schema->sources;
 978
 979     for my $table (@tables) {
 980         my $moniker = $self->monikers->{$table};
 981         my $class = $self->classes->{$table};
 982
 983         {
 984             no warnings 'redefine';
 985             local *Class::C3::reinitialize = sub {};
 986             use warnings;
 987
 988             Class::Unload->unload($class) if $unload;
 989             my ($source, $resultset_class);
 990             if (
 991                 ($source = $have_source{$moniker})
 992                 && ($resultset_class = $source->resultset_class)
 993                 && ($resultset_class ne 'DBIx::Class::ResultSet')
 994             ) {
 995                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
 996                 Class::Unload->unload($resultset_class) if $unload;
 997                 $self->_reload_class($resultset_class) if $has_file;
 998             }
 999             $self->_reload_class($class);
1000         }
1001         push @to_register, [$moniker, $class];
1002     }
1003
1004     Class::C3->reinitialize;
1005     for (@to_register) {
1006         $self->schema->register_class(@$_);
1007     }
1008 }
1009
1010 # We use this instead of ensure_class_loaded when there are package symbols we
1011 # want to preserve.
1012 sub _reload_class {
1013     my ($self, $class) = @_;
1014
1015     my $class_path = $self->_class_path($class);
1016     delete $INC{ $class_path };
1017
1018 # kill redefined warnings
1019     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
1020     local $SIG{__WARN__} = sub {
1021         $warn_handler->(@_)
1022             unless $_[0] =~ /^Subroutine \S+ redefined/;
1023     };
1024     eval "require $class;";
1025 }
1026
1027 sub _get_dump_filename {
1028     my ($self, $class) = (@_);
1029
1030     $class =~ s{::}{/}g;
1031     return $self->dump_directory . q{/} . $class . q{.pm};
1032 }
1033
1034 sub _ensure_dump_subdirs {
1035     my ($self, $class) = (@_);
1036
1037     my @name_parts = split(/::/, $class);
1038     pop @name_parts; # we don't care about the very last element,
1039                      # which is a filename
1040
1041     my $dir = $self->dump_directory;
1042     while (1) {
1043         if(!-d $dir) {
1044             mkdir($dir) or croak "mkdir('$dir') failed: $!";
1045         }
1046         last if !@name_parts;
1047         $dir = File::Spec->catdir($dir, shift @name_parts);
1048     }
1049 }
1050
1051 sub _dump_to_dir {
1052     my ($self, @classes) = @_;
1053
1054     my $schema_class = $self->schema_class;
1055     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1056
1057     my $target_dir = $self->dump_directory;
1058     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1059         unless $self->{dynamic} or $self->{quiet};
1060
1061     my $schema_text =
1062           qq|package $schema_class;\n\n|
1063         . qq|# Created by DBIx::Class::Schema::Loader\n|
1064         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1065         . qq|use strict;\nuse warnings;\n\n|
1066         . qq|use base '$schema_base_class';\n\n|;
1067
1068     if ($self->use_namespaces) {
1069         $schema_text .= qq|__PACKAGE__->load_namespaces|;
1070         my $namespace_options;
1071         for my $attr (qw(result_namespace
1072                          resultset_namespace
1073                          default_resultset_class)) {
1074             if ($self->$attr) {
1075                 $namespace_options .= qq|    $attr => '| . $self->$attr . qq|',\n|
1076             }
1077         }
1078         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1079         $schema_text .= qq|;\n|;
1080     }
1081     else {
1082         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1083     }
1084
1085     {
1086         local $self->{version_to_dump} = $self->schema_version_to_dump;
1087         $self->_write_classfile($schema_class, $schema_text, 1);
1088     }
1089
1090     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1091
1092     foreach my $src_class (@classes) {
1093         my $src_text =
1094               qq|package $src_class;\n\n|
1095             . qq|# Created by DBIx::Class::Schema::Loader\n|
1096             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1097             . qq|use strict;\nuse warnings;\n\n|
1098             . qq|use base '$result_base_class';\n\n|;
1099
1100         $self->_write_classfile($src_class, $src_text);
1101     }
1102
1103     # remove Result dir if downgrading from use_namespaces, and there are no
1104     # files left.
1105     if (my $result_ns = $self->_downgrading_to_load_classes
1106                         || $self->_rewriting_result_namespace) {
1107         my $result_namespace = $self->_result_namespace(
1108             $schema_class,
1109             $result_ns,
1110         );
1111
1112         (my $result_dir = $result_namespace) =~ s{::}{/}g;
1113         $result_dir = $self->dump_directory . '/' . $result_dir;
1114
1115         unless (my @files = glob "$result_dir/*") {
1116             rmdir $result_dir;
1117         }
1118     }
1119
1120     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1121
1122 }
1123
1124 sub _sig_comment {
1125     my ($self, $version, $ts) = @_;
1126     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1127          . qq| v| . $version
1128          . q| @ | . $ts
1129          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1130 }
1131
1132 sub _write_classfile {
1133     my ($self, $class, $text, $is_schema) = @_;
1134
1135     my $filename = $self->_get_dump_filename($class);
1136     $self->_ensure_dump_subdirs($class);
1137
1138     if (-f $filename && $self->really_erase_my_files) {
1139         warn "Deleting existing file '$filename' due to "
1140             . "'really_erase_my_files' setting\n" unless $self->{quiet};
1141         unlink($filename);
1142     }
1143
1144     my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
1145
1146     if (my $old_class = $self->_upgrading_classes->{$class}) {
1147         my $old_filename = $self->_get_dump_filename($old_class);
1148
1149         my ($old_custom_content) = $self->_get_custom_content(
1150             $old_class, $old_filename, 0 # do not add default comment
1151         );
1152
1153         $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
1154
1155         if ($old_custom_content) {
1156             $custom_content =
1157                 "\n" . $old_custom_content . "\n" . $custom_content;
1158         }
1159
1160         unlink $old_filename;
1161     }
1162
1163     $custom_content = $self->_rewrite_old_classnames($custom_content);
1164
1165     $text .= qq|$_\n|
1166         for @{$self->{_dump_storage}->{$class} || []};
1167
1168     # Check and see if the dump is infact differnt
1169
1170     my $compare_to;
1171     if ($old_md5) {
1172       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1173
1174
1175       if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1176         return unless $self->_upgrading_from && $is_schema;
1177       }
1178     }
1179
1180     $text .= $self->_sig_comment(
1181       $self->version_to_dump,
1182       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1183     );
1184
1185     open(my $fh, '>', $filename)
1186         or croak "Cannot open '$filename' for writing: $!";
1187
1188     # Write the top half and its MD5 sum
1189     print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1190
1191     # Write out anything loaded via external partial class file in @INC
1192     print $fh qq|$_\n|
1193         for @{$self->{_ext_storage}->{$class} || []};
1194
1195     # Write out any custom content the user has added
1196     print $fh $custom_content;
1197
1198     close($fh)
1199         or croak "Error closing '$filename': $!";
1200 }
1201
1202 sub _default_custom_content {
1203     return qq|\n\n# You can replace this text with custom|
1204          . qq| content, and it will be preserved on regeneration|
1205          . qq|\n1;\n|;
1206 }
1207
1208 sub _get_custom_content {
1209     my ($self, $class, $filename, $add_default) = @_;
1210
1211     $add_default = 1 unless defined $add_default;
1212
1213     return ($self->_default_custom_content) if ! -f $filename;
1214
1215     open(my $fh, '<', $filename)
1216         or croak "Cannot open '$filename' for reading: $!";
1217
1218     my $mark_re =
1219         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1220
1221     my $buffer = '';
1222     my ($md5, $ts, $ver);
1223     while(<$fh>) {
1224         if(!$md5 && /$mark_re/) {
1225             $md5 = $2;
1226             my $line = $1;
1227
1228             # Pull out the previous version and timestamp
1229             ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
1230
1231             $buffer .= $line;
1232             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"
1233                 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
1234
1235             $buffer = '';
1236         }
1237         else {
1238             $buffer .= $_;
1239         }
1240     }
1241
1242     croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
1243         . " it does not appear to have been generated by Loader"
1244             if !$md5;
1245
1246     # Default custom content:
1247     $buffer ||= $self->_default_custom_content if $add_default;
1248
1249     return ($buffer, $md5, $ver, $ts);
1250 }
1251
1252 sub _use {
1253     my $self = shift;
1254     my $target = shift;
1255
1256     foreach (@_) {
1257         warn "$target: use $_;" if $self->debug;
1258         $self->_raw_stmt($target, "use $_;");
1259     }
1260 }
1261
1262 sub _inject {
1263     my $self = shift;
1264     my $target = shift;
1265     my $schema_class = $self->schema_class;
1266
1267     my $blist = join(q{ }, @_);
1268     warn "$target: use base qw/ $blist /;" if $self->debug && @_;
1269     $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
1270 }
1271
1272 sub _result_namespace {
1273     my ($self, $schema_class, $ns) = @_;
1274     my @result_namespace;
1275
1276     if ($ns =~ /^\+(.*)/) {
1277         # Fully qualified namespace
1278         @result_namespace = ($1)
1279     }
1280     else {
1281         # Relative namespace
1282         @result_namespace = ($schema_class, $ns);
1283     }
1284
1285     return wantarray ? @result_namespace : join '::', @result_namespace;
1286 }
1287
1288 # Create class with applicable bases, setup monikers, etc
1289 sub _make_src_class {
1290     my ($self, $table) = @_;
1291
1292     my $schema       = $self->schema;
1293     my $schema_class = $self->schema_class;
1294
1295     my $table_moniker = $self->_table2moniker($table);
1296     my @result_namespace = ($schema_class);
1297     if ($self->use_namespaces) {
1298         my $result_namespace = $self->result_namespace || 'Result';
1299         @result_namespace = $self->_result_namespace(
1300             $schema_class,
1301             $result_namespace,
1302         );
1303     }
1304     my $table_class = join(q{::}, @result_namespace, $table_moniker);
1305
1306     if ((my $upgrading_v = $self->_upgrading_from)
1307             || $self->_rewriting) {
1308         local $self->naming->{monikers} = $upgrading_v
1309             if $upgrading_v;
1310
1311         my @result_namespace = @result_namespace;
1312         if ($self->_upgrading_from_load_classes) {
1313             @result_namespace = ($schema_class);
1314         }
1315         elsif (my $ns = $self->_downgrading_to_load_classes) {
1316             @result_namespace = $self->_result_namespace(
1317                 $schema_class,
1318                 $ns,
1319             );
1320         }
1321         elsif ($ns = $self->_rewriting_result_namespace) {
1322             @result_namespace = $self->_result_namespace(
1323                 $schema_class,
1324                 $ns,
1325             );
1326         }
1327
1328         my $old_class = join(q{::}, @result_namespace,
1329             $self->_table2moniker($table));
1330
1331         $self->_upgrading_classes->{$table_class} = $old_class
1332             unless $table_class eq $old_class;
1333     }
1334
1335     my $table_normalized = lc $table;
1336     $self->classes->{$table} = $table_class;
1337     $self->classes->{$table_normalized} = $table_class;
1338     $self->monikers->{$table} = $table_moniker;
1339     $self->monikers->{$table_normalized} = $table_moniker;
1340
1341     $self->_use   ($table_class, @{$self->additional_classes});
1342     $self->_inject($table_class, @{$self->left_base_classes});
1343
1344     if (my @components = @{ $self->components }) {
1345         $self->_dbic_stmt($table_class, 'load_components', @components);
1346     }
1347
1348     $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1349         if @{$self->resultset_components};
1350     $self->_inject($table_class, @{$self->additional_base_classes});
1351 }
1352
1353 # Set up metadata (cols, pks, etc)
1354 sub _setup_src_meta {
1355     my ($self, $table) = @_;
1356
1357     my $schema       = $self->schema;
1358     my $schema_class = $self->schema_class;
1359
1360     my $table_class = $self->classes->{$table};
1361     my $table_moniker = $self->monikers->{$table};
1362
1363     my $table_name = $table;
1364     my $name_sep   = $self->schema->storage->sql_maker->name_sep;
1365
1366     if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1367         $table_name = \ $self->_quote_table_name($table_name);
1368     }
1369
1370     $self->_dbic_stmt($table_class,'table',$table_name);
1371
1372     my $cols = $self->_table_columns($table);
1373     my $col_info = $self->__columns_info_for($table);
1374     if ($self->_is_case_sensitive) {
1375         for my $col (keys %$col_info) {
1376             $col_info->{$col}{accessor} = lc $col
1377                 if $col ne lc($col);
1378         }
1379     } else {
1380         $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1381     }
1382
1383     my $fks = $self->_table_fk_info($table);
1384
1385     for my $fkdef (@$fks) {
1386         for my $col (@{ $fkdef->{local_columns} }) {
1387             $col_info->{$col}{is_foreign_key} = 1;
1388         }
1389     }
1390     $self->_dbic_stmt(
1391         $table_class,
1392         'add_columns',
1393         map { $_, ($col_info->{$_}||{}) } @$cols
1394     );
1395
1396     my %uniq_tag; # used to eliminate duplicate uniqs
1397
1398     my $pks = $self->_table_pk_info($table) || [];
1399     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1400           : carp("$table has no primary key");
1401     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1402
1403     my $uniqs = $self->_table_uniq_info($table) || [];
1404     for (@$uniqs) {
1405         my ($name, $cols) = @$_;
1406         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1407         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1408     }
1409
1410 }
1411
1412 sub __columns_info_for {
1413     my ($self, $table) = @_;
1414
1415     my $result = $self->_columns_info_for($table);
1416
1417     while (my ($col, $info) = each %$result) {
1418         $info = { %$info, %{ $self->_custom_column_info  ($table, $col, $info) } };
1419         $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1420
1421         $result->{$col} = $info;
1422     }
1423
1424     return $result;
1425 }
1426
1427 =head2 tables
1428
1429 Returns a sorted list of loaded tables, using the original database table
1430 names.
1431
1432 =cut
1433
1434 sub tables {
1435     my $self = shift;
1436
1437     return keys %{$self->_tables};
1438 }
1439
1440 # Make a moniker from a table
1441 sub _default_table2moniker {
1442     no warnings 'uninitialized';
1443     my ($self, $table) = @_;
1444
1445     if ($self->naming->{monikers} eq 'v4') {
1446         return join '', map ucfirst, split /[\W_]+/, lc $table;
1447     }
1448
1449     return join '', map ucfirst, split /[\W_]+/,
1450         Lingua::EN::Inflect::Number::to_S(lc $table);
1451 }
1452
1453 sub _table2moniker {
1454     my ( $self, $table ) = @_;
1455
1456     my $moniker;
1457
1458     if( ref $self->moniker_map eq 'HASH' ) {
1459         $moniker = $self->moniker_map->{$table};
1460     }
1461     elsif( ref $self->moniker_map eq 'CODE' ) {
1462         $moniker = $self->moniker_map->($table);
1463     }
1464
1465     $moniker ||= $self->_default_table2moniker($table);
1466
1467     return $moniker;
1468 }
1469
1470 sub _load_relationships {
1471     my ($self, $table) = @_;
1472
1473     my $tbl_fk_info = $self->_table_fk_info($table);
1474     foreach my $fkdef (@$tbl_fk_info) {
1475         $fkdef->{remote_source} =
1476             $self->monikers->{delete $fkdef->{remote_table}};
1477     }
1478     my $tbl_uniq_info = $self->_table_uniq_info($table);
1479
1480     my $local_moniker = $self->monikers->{$table};
1481     my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1482
1483     foreach my $src_class (sort keys %$rel_stmts) {
1484         my $src_stmts = $rel_stmts->{$src_class};
1485         foreach my $stmt (@$src_stmts) {
1486             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1487         }
1488     }
1489 }
1490
1491 # Overload these in driver class:
1492
1493 # Returns an arrayref of column names
1494 sub _table_columns { croak "ABSTRACT METHOD" }
1495
1496 # Returns arrayref of pk col names
1497 sub _table_pk_info { croak "ABSTRACT METHOD" }
1498
1499 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1500 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1501
1502 # Returns an arrayref of foreign key constraints, each
1503 #   being a hashref with 3 keys:
1504 #   local_columns (arrayref), remote_columns (arrayref), remote_table
1505 sub _table_fk_info { croak "ABSTRACT METHOD" }
1506
1507 # Returns an array of lower case table names
1508 sub _tables_list { croak "ABSTRACT METHOD" }
1509
1510 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1511 sub _dbic_stmt {
1512     my $self   = shift;
1513     my $class  = shift;
1514     my $method = shift;
1515
1516     # generate the pod for this statement, storing it with $self->_pod
1517     $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
1518
1519     my $args = dump(@_);
1520     $args = '(' . $args . ')' if @_ < 2;
1521     my $stmt = $method . $args . q{;};
1522
1523     warn qq|$class\->$stmt\n| if $self->debug;
1524     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1525     return;
1526 }
1527
1528 # generates the accompanying pod for a DBIC class method statement,
1529 # storing it with $self->_pod
1530 sub _make_pod {
1531     my $self   = shift;
1532     my $class  = shift;
1533     my $method = shift;
1534
1535     if ( $method eq 'table' ) {
1536         my ($table) = @_;
1537         my $pcm = $self->pod_comment_mode;
1538         my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
1539         if ( $self->can('_table_comment') ) {
1540             $comment = $self->_table_comment($table);
1541             $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1542             $comment_in_name   = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1543             $comment_in_desc   = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
1544         }
1545         $self->_pod( $class, "=head1 NAME" );
1546         my $table_descr = $class;
1547         $table_descr .= " - " . $comment if $comment and $comment_in_name;
1548         $self->{_class2table}{ $class } = $table;
1549         $self->_pod( $class, $table_descr );
1550         if ($comment and $comment_in_desc) {
1551             $self->_pod( $class, "=head1 DESCRIPTION" );
1552             $self->_pod( $class, $comment );
1553         }
1554         $self->_pod_cut( $class );
1555     } elsif ( $method eq 'add_columns' ) {
1556         $self->_pod( $class, "=head1 ACCESSORS" );
1557         my $col_counter = 0;
1558         my @cols = @_;
1559         while( my ($name,$attrs) = splice @cols,0,2 ) {
1560             $col_counter++;
1561             $self->_pod( $class, '=head2 ' . $name  );
1562             $self->_pod( $class,
1563                          join "\n", map {
1564                              my $s = $attrs->{$_};
1565                              $s = !defined $s         ? 'undef'          :
1566                                   length($s) == 0     ? '(empty string)' :
1567                                   ref($s) eq 'SCALAR' ? $$s :
1568                                   ref($s)             ? do {
1569                                                         my $dd = Dumper;
1570                                                         $dd->Indent(0);
1571                                                         $dd->Values([$s]);
1572                                                         $dd->Dump;
1573                                                       } :
1574                                   looks_like_number($s) ? $s :
1575                                                         qq{'$s'}
1576                                   ;
1577
1578                              "  $_: $s"
1579                          } sort keys %$attrs,
1580                        );
1581
1582             if( $self->can('_column_comment')
1583                 and my $comment = $self->_column_comment( $self->{_class2table}{$class}, $col_counter)
1584               ) {
1585                 $self->_pod( $class, $comment );
1586             }
1587         }
1588         $self->_pod_cut( $class );
1589     } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1590         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1591         my ( $accessor, $rel_class ) = @_;
1592         $self->_pod( $class, "=head2 $accessor" );
1593         $self->_pod( $class, 'Type: ' . $method );
1594         $self->_pod( $class, "Related object: L<$rel_class>" );
1595         $self->_pod_cut( $class );
1596         $self->{_relations_started} { $class } = 1;
1597     }
1598 }
1599
1600 # Stores a POD documentation
1601 sub _pod {
1602     my ($self, $class, $stmt) = @_;
1603     $self->_raw_stmt( $class, "\n" . $stmt  );
1604 }
1605
1606 sub _pod_cut {
1607     my ($self, $class ) = @_;
1608     $self->_raw_stmt( $class, "\n=cut\n" );
1609 }
1610
1611 # Store a raw source line for a class (for dumping purposes)
1612 sub _raw_stmt {
1613     my ($self, $class, $stmt) = @_;
1614     push(@{$self->{_dump_storage}->{$class}}, $stmt);
1615 }
1616
1617 # Like above, but separately for the externally loaded stuff
1618 sub _ext_stmt {
1619     my ($self, $class, $stmt) = @_;
1620     push(@{$self->{_ext_storage}->{$class}}, $stmt);
1621 }
1622
1623 sub _quote_table_name {
1624     my ($self, $table) = @_;
1625
1626     my $qt = $self->schema->storage->sql_maker->quote_char;
1627
1628     return $table unless $qt;
1629
1630     if (ref $qt) {
1631         return $qt->[0] . $table . $qt->[1];
1632     }
1633
1634     return $qt . $table . $qt;
1635 }
1636
1637 sub _is_case_sensitive { 0 }
1638
1639 sub _custom_column_info {
1640     my ( $self, $table_name, $column_name, $column_info ) = @_;
1641
1642     if (my $code = $self->custom_column_info) {
1643         return $code->($table_name, $column_name, $column_info) || {};
1644     }
1645     return {};
1646 }
1647
1648 sub _datetime_column_info {
1649     my ( $self, $table_name, $column_name, $column_info ) = @_;
1650     my $result = {};
1651     my $type = $column_info->{data_type} || '';
1652     if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
1653             or ($type =~ /date|timestamp/i)) {
1654         $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
1655         $result->{locale}   = $self->datetime_locale   if $self->datetime_locale;
1656     }
1657     return $result;
1658 }
1659
1660 # remove the dump dir from @INC on destruction
1661 sub DESTROY {
1662     my $self = shift;
1663
1664     @INC = grep $_ ne $self->dump_directory, @INC;
1665 }
1666
1667 =head2 monikers
1668
1669 Returns a hashref of loaded table to moniker mappings.  There will
1670 be two entries for each table, the original name and the "normalized"
1671 name, in the case that the two are different (such as databases
1672 that like uppercase table names, or preserve your original mixed-case
1673 definitions, or what-have-you).
1674
1675 =head2 classes
1676
1677 Returns a hashref of table to class mappings.  In some cases it will
1678 contain multiple entries per table for the original and normalized table
1679 names, as above in L</monikers>.
1680
1681 =head1 SEE ALSO
1682
1683 L<DBIx::Class::Schema::Loader>
1684
1685 =head1 AUTHOR
1686
1687 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1688
1689 =head1 LICENSE
1690
1691 This library is free software; you can redistribute it and/or modify it under
1692 the same terms as Perl itself.
1693
1694 =cut
1695
1696 1;