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