lib/DBIx/Class/Schema/Loader/Base.pm

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