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