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