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