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 mro '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     # don't lose undef options
 525     for (values %$self) {
 526         $_ = 0 unless defined $_;
 527     }
 528
 529     bless $self => $class;
 530
 531     if (my $config_file = $self->config_file) {
 532         my $config_opts = do $config_file;
 533
 534         croak "Error reading config from $config_file: $@" if $@;
 535
 536         croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
 537
 538         while (my ($k, $v) = each %$config_opts) {
 539             $self->{$k} = $v unless exists $self->{$k};
 540         }
 541     }
 542
 543     $self->_ensure_arrayref(qw/additional_classes
 544                                additional_base_classes
 545                                left_base_classes
 546                                components
 547                                resultset_components
 548                               /);
 549
 550     $self->_validate_class_args;
 551
 552     if ($self->use_moose) {
 553         if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
 554             die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\nYou are missing: %s.\n",
 555                 "Moose, MooseX::NonMoose and namespace::autoclean",
 556                 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
 557         }
 558     }
 559
 560     push(@{$self->{components}}, 'ResultSetManager')
 561         if @{$self->{resultset_components}};
 562
 563     $self->{monikers} = {};
 564     $self->{classes} = {};
 565     $self->{_upgrading_classes} = {};
 566
 567     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
 568     $self->{schema} ||= $self->{schema_class};
 569
 570     croak "dump_overwrite is deprecated.  Please read the"
 571         . " DBIx::Class::Schema::Loader::Base documentation"
 572             if $self->{dump_overwrite};
 573
 574     $self->{dynamic} = ! $self->{dump_directory};
 575     $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
 576                                                      TMPDIR  => 1,
 577                                                      CLEANUP => 1,
 578                                                    );
 579
 580     $self->{dump_directory} ||= $self->{temp_directory};
 581
 582     $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 583     $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 584
 585     if ((not ref $self->naming) && defined $self->naming) {
 586         my $naming_ver = $self->naming;
 587         $self->{naming} = {
 588             relationships => $naming_ver,
 589             monikers => $naming_ver,
 590             column_accessors => $naming_ver,
 591         };
 592     }
 593
 594     if ($self->naming) {
 595         for (values %{ $self->naming }) {
 596             $_ = $CURRENT_V if $_ eq 'current';
 597         }
 598     }
 599     $self->{naming} ||= {};
 600
 601     if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
 602         croak 'custom_column_info must be a CODE ref';
 603     }
 604
 605     $self->_check_back_compat;
 606
 607     $self->use_namespaces(1) unless defined $self->use_namespaces;
 608     $self->generate_pod(1)   unless defined $self->generate_pod;
 609     $self->pod_comment_mode('auto')         unless defined $self->pod_comment_mode;
 610     $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
 611
 612     $self;
 613 }
 614
 615 sub _check_back_compat {
 616     my ($self) = @_;
 617
 618 # dynamic schemas will always be in 0.04006 mode, unless overridden
 619     if ($self->dynamic) {
 620 # just in case, though no one is likely to dump a dynamic schema
 621         $self->schema_version_to_dump('0.04006');
 622
 623         if (not %{ $self->naming }) {
 624             warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 625
 626 Dynamic schema detected, will run in 0.04006 mode.
 627
 628 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 629 to disable this warning.
 630
 631 Also consider setting 'use_namespaces => 1' if/when upgrading.
 632
 633 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 634 details.
 635 EOF
 636         }
 637         else {
 638             $self->_upgrading_from('v4');
 639         }
 640
 641         $self->naming->{relationships} ||= 'v4';
 642         $self->naming->{monikers}      ||= 'v4';
 643
 644         if ($self->use_namespaces) {
 645             $self->_upgrading_from_load_classes(1);
 646         }
 647         else {
 648             $self->use_namespaces(0);
 649         }
 650
 651         return;
 652     }
 653
 654 # otherwise check if we need backcompat mode for a static schema
 655     my $filename = $self->_get_dump_filename($self->schema_class);
 656     return unless -e $filename;
 657
 658     my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
 659       $self->_parse_generated_file($filename);
 660
 661     return unless $old_ver;
 662
 663     # determine if the existing schema was dumped with use_moose => 1
 664     if (! defined $self->use_moose) {
 665         $self->use_moose(1) if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
 666     }
 667
 668     my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
 669     my $result_namespace = do { ($old_gen =~ /result_namespace => '([^']+)'/) ? $1 : '' };
 670
 671     if ($load_classes && (not defined $self->use_namespaces)) {
 672         warn <<"EOF"  unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 673
 674 'load_classes;' static schema detected, turning off 'use_namespaces'.
 675
 676 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
 677 variable to disable this warning.
 678
 679 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 680 details.
 681 EOF
 682         $self->use_namespaces(0);
 683     }
 684     elsif ($load_classes && $self->use_namespaces) {
 685         $self->_upgrading_from_load_classes(1);
 686     }
 687     elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
 688         $self->_downgrading_to_load_classes(
 689             $result_namespace || 'Result'
 690         );
 691     }
 692     elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
 693         if (not $self->result_namespace) {
 694             $self->result_namespace($result_namespace || 'Result');
 695         }
 696         elsif ($result_namespace ne $self->result_namespace) {
 697             $self->_rewriting_result_namespace(
 698                 $result_namespace || 'Result'
 699             );
 700         }
 701     }
 702
 703     # XXX when we go past .0 this will need fixing
 704     my ($v) = $old_ver =~ /([1-9])/;
 705     $v = "v$v";
 706
 707     return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
 708
 709     if (not %{ $self->naming }) {
 710         warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 711
 712 Version $old_ver static schema detected, turning on backcompat mode.
 713
 714 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 715 to disable this warning.
 716
 717 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
 718
 719 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
 720 from version 0.04006.
 721 EOF
 722
 723         $self->naming->{relationships}    ||= $v;
 724         $self->naming->{monikers}         ||= $v;
 725         $self->naming->{column_accessors} ||= $v;
 726
 727         $self->schema_version_to_dump($old_ver);
 728     }
 729     else {
 730         $self->_upgrading_from($v);
 731     }
 732 }
 733
 734 sub _validate_class_args {
 735     my $self = shift;
 736     my $args = shift;
 737
 738     foreach my $k (@CLASS_ARGS) {
 739         next unless $self->$k;
 740
 741         my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
 742         foreach my $c (@classes) {
 743             # components default to being under the DBIx::Class namespace unless they
 744             # are preceeded with a '+'
 745             if ( $k =~ m/components$/ && $c !~ s/^\+// ) {
 746                 $c = 'DBIx::Class::' . $c;
 747             }
 748
 749             # 1 == installed, 0 == not installed, undef == invalid classname
 750             my $installed = Class::Inspector->installed($c);
 751             if ( defined($installed) ) {
 752                 if ( $installed == 0 ) {
 753                     croak qq/$c, as specified in the loader option "$k", is not installed/;
 754                 }
 755             } else {
 756                 croak qq/$c, as specified in the loader option "$k", is an invalid class name/;
 757             }
 758         }
 759     }
 760 }
 761
 762 sub _find_file_in_inc {
 763     my ($self, $file) = @_;
 764
 765     foreach my $prefix (@INC) {
 766         my $fullpath = File::Spec->catfile($prefix, $file);
 767         return $fullpath if -f $fullpath
 768             # abs_path throws on Windows for nonexistant files
 769             and eval { Cwd::abs_path($fullpath) } ne
 770                (eval { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) } || '');
 771     }
 772
 773     return;
 774 }
 775
 776 sub _class_path {
 777     my ($self, $class) = @_;
 778
 779     my $class_path = $class;
 780     $class_path =~ s{::}{/}g;
 781     $class_path .= '.pm';
 782
 783     return $class_path;
 784 }
 785
 786 sub _find_class_in_inc {
 787     my ($self, $class) = @_;
 788
 789     return $self->_find_file_in_inc($self->_class_path($class));
 790 }
 791
 792 sub _rewriting {
 793     my $self = shift;
 794
 795     return $self->_upgrading_from
 796         || $self->_upgrading_from_load_classes
 797         || $self->_downgrading_to_load_classes
 798         || $self->_rewriting_result_namespace
 799     ;
 800 }
 801
 802 sub _rewrite_old_classnames {
 803     my ($self, $code) = @_;
 804
 805     return $code unless $self->_rewriting;
 806
 807     my %old_classes = reverse %{ $self->_upgrading_classes };
 808
 809     my $re = join '|', keys %old_classes;
 810     $re = qr/\b($re)\b/;
 811
 812     $code =~ s/$re/$old_classes{$1} || $1/eg;
 813
 814     return $code;
 815 }
 816
 817 sub _load_external {
 818     my ($self, $class) = @_;
 819
 820     return if $self->{skip_load_external};
 821
 822     # so that we don't load our own classes, under any circumstances
 823     local *INC = [ grep $_ ne $self->dump_directory, @INC ];
 824
 825     my $real_inc_path = $self->_find_class_in_inc($class);
 826
 827     my $old_class = $self->_upgrading_classes->{$class}
 828         if $self->_rewriting;
 829
 830     my $old_real_inc_path = $self->_find_class_in_inc($old_class)
 831         if $old_class && $old_class ne $class;
 832
 833     return unless $real_inc_path || $old_real_inc_path;
 834
 835     if ($real_inc_path) {
 836         # If we make it to here, we loaded an external definition
 837         warn qq/# Loaded external class definition for '$class'\n/
 838             if $self->debug;
 839
 840         open(my $fh, '<', $real_inc_path)
 841             or croak "Failed to open '$real_inc_path' for reading: $!";
 842         my $code = do { local $/; <$fh> };
 843         close($fh)
 844             or croak "Failed to close $real_inc_path: $!";
 845         $code = $self->_rewrite_old_classnames($code);
 846
 847         if ($self->dynamic) { # load the class too
 848             # kill redefined warnings
 849             my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 850             local $SIG{__WARN__} = sub {
 851                 $warn_handler->(@_)
 852                     unless $_[0] =~ /^Subroutine \S+ redefined/;
 853             };
 854             eval $code;
 855             die $@ if $@;
 856         }
 857
 858         $self->_ext_stmt($class,
 859           qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
 860          .qq|# They are now part of the custom portion of this file\n|
 861          .qq|# for you to hand-edit.  If you do not either delete\n|
 862          .qq|# this section or remove that file from \@INC, this section\n|
 863          .qq|# will be repeated redundantly when you re-create this\n|
 864          .qq|# file again via Loader!  See skip_load_external to disable\n|
 865          .qq|# this feature.\n|
 866         );
 867         chomp $code;
 868         $self->_ext_stmt($class, $code);
 869         $self->_ext_stmt($class,
 870             qq|# End of lines loaded from '$real_inc_path' |
 871         );
 872     }
 873
 874     if ($old_real_inc_path) {
 875         my $code = slurp $old_real_inc_path;
 876
 877         $self->_ext_stmt($class, <<"EOF");
 878
 879 # These lines were loaded from '$old_real_inc_path',
 880 # based on the Result class name that would have been created by an older
 881 # version of the Loader. For a static schema, this happens only once during
 882 # upgrade. See skip_load_external to disable this feature.
 883 EOF
 884
 885         $code = $self->_rewrite_old_classnames($code);
 886
 887         if ($self->dynamic) {
 888             warn <<"EOF";
 889
 890 Detected external content in '$old_real_inc_path', a class name that would have
 891 been used by an older version of the Loader.
 892
 893 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
 894 new name of the Result.
 895 EOF
 896             # kill redefined warnings
 897             my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 898             local $SIG{__WARN__} = sub {
 899                 $warn_handler->(@_)
 900                     unless $_[0] =~ /^Subroutine \S+ redefined/;
 901             };
 902             eval $code;
 903             die $@ if $@;
 904         }
 905
 906         chomp $code;
 907         $self->_ext_stmt($class, $code);
 908         $self->_ext_stmt($class,
 909             qq|# End of lines loaded from '$old_real_inc_path' |
 910         );
 911     }
 912 }
 913
 914 =head2 load
 915
 916 Does the actual schema-construction work.
 917
 918 =cut
 919
 920 sub load {
 921     my $self = shift;
 922
 923     $self->_load_tables(
 924         $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
 925     );
 926 }
 927
 928 =head2 rescan
 929
 930 Arguments: schema
 931
 932 Rescan the database for changes. Returns a list of the newly added table
 933 monikers.
 934
 935 The schema argument should be the schema class or object to be affected.  It
 936 should probably be derived from the original schema_class used during L</load>.
 937
 938 =cut
 939
 940 sub rescan {
 941     my ($self, $schema) = @_;
 942
 943     $self->{schema} = $schema;
 944     $self->_relbuilder->{schema} = $schema;
 945
 946     my @created;
 947     my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
 948
 949     foreach my $table (@current) {
 950         if(!exists $self->{_tables}->{$table}) {
 951             push(@created, $table);
 952         }
 953     }
 954
 955     my %current;
 956     @current{@current} = ();
 957     foreach my $table (keys %{ $self->{_tables} }) {
 958         if (not exists $current{$table}) {
 959             $self->_unregister_source_for_table($table);
 960         }
 961     }
 962
 963     delete $self->{_dump_storage};
 964     delete $self->{_relations_started};
 965
 966     my $loaded = $self->_load_tables(@current);
 967
 968     return map { $self->monikers->{$_} } @created;
 969 }
 970
 971 sub _relbuilder {
 972     my ($self) = @_;
 973
 974     return if $self->{skip_relationships};
 975
 976     return $self->{relbuilder} ||= do {
 977
 978         no warnings 'uninitialized';
 979         my $relbuilder_suff =
 980             {qw{
 981                 v4  ::Compat::v0_040
 982                 v5  ::Compat::v0_05
 983                 v6  ::Compat::v0_06
 984             }}
 985             ->{ $self->naming->{relationships}};
 986
 987         my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
 988         eval "require $relbuilder_class"; die $@ if $@;
 989         $relbuilder_class->new( $self );
 990
 991     };
 992 }
 993
 994 sub _load_tables {
 995     my ($self, @tables) = @_;
 996
 997     # Save the new tables to the tables list
 998     foreach (@tables) {
 999         $self->{_tables}->{$_} = 1;
1000     }
1001
1002     $self->_make_src_class($_) for @tables;
1003
1004     # sanity-check for moniker clashes
1005     my $inverse_moniker_idx;
1006     for (keys %{$self->monikers}) {
1007       push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1008     }
1009
1010     my @clashes;
1011     for (keys %$inverse_moniker_idx) {
1012       my $tables = $inverse_moniker_idx->{$_};
1013       if (@$tables > 1) {
1014         push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1015           join (', ', map { "'$_'" } @$tables),
1016           $_,
1017         );
1018       }
1019     }
1020
1021     if (@clashes) {
1022       die   'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1023           . 'Either change the naming style, or supply an explicit moniker_map: '
1024           . join ('; ', @clashes)
1025           . "\n"
1026       ;
1027     }
1028
1029
1030     $self->_setup_src_meta($_) for @tables;
1031
1032     if(!$self->skip_relationships) {
1033         # The relationship loader needs a working schema
1034         $self->{quiet} = 1;
1035         local $self->{dump_directory} = $self->{temp_directory};
1036         $self->_reload_classes(\@tables);
1037         $self->_load_relationships($_) for @tables;
1038         $self->{quiet} = 0;
1039
1040         # Remove that temp dir from INC so it doesn't get reloaded
1041         @INC = grep $_ ne $self->dump_directory, @INC;
1042     }
1043
1044     $self->_load_external($_)
1045         for map { $self->classes->{$_} } @tables;
1046
1047     # Reload without unloading first to preserve any symbols from external
1048     # packages.
1049     $self->_reload_classes(\@tables, 0);
1050
1051     # Drop temporary cache
1052     delete $self->{_cache};
1053
1054     return \@tables;
1055 }
1056
1057 sub _reload_classes {
1058     my ($self, $tables, $unload) = @_;
1059
1060     my @tables = @$tables;
1061     $unload = 1 unless defined $unload;
1062
1063     # so that we don't repeat custom sections
1064     @INC = grep $_ ne $self->dump_directory, @INC;
1065
1066     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1067
1068     unshift @INC, $self->dump_directory;
1069
1070     my @to_register;
1071     my %have_source = map { $_ => $self->schema->source($_) }
1072         $self->schema->sources;
1073
1074     for my $table (@tables) {
1075         my $moniker = $self->monikers->{$table};
1076         my $class = $self->classes->{$table};
1077
1078         {
1079             no warnings 'redefine';
1080             local *Class::C3::reinitialize = sub {};  # to speed things up, reinitialized below
1081             use warnings;
1082
1083             if (my $mc = $self->_moose_metaclass($class)) {
1084                 $mc->make_mutable;
1085             }
1086             Class::Unload->unload($class) if $unload;
1087             my ($source, $resultset_class);
1088             if (
1089                 ($source = $have_source{$moniker})
1090                 && ($resultset_class = $source->resultset_class)
1091                 && ($resultset_class ne 'DBIx::Class::ResultSet')
1092             ) {
1093                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1094                 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1095                     $mc->make_mutable;
1096                 }
1097                 Class::Unload->unload($resultset_class) if $unload;
1098                 $self->_reload_class($resultset_class) if $has_file;
1099             }
1100             $self->_reload_class($class);
1101         }
1102         push @to_register, [$moniker, $class];
1103     }
1104
1105     Class::C3->reinitialize;
1106     for (@to_register) {
1107         $self->schema->register_class(@$_);
1108     }
1109 }
1110
1111 sub _moose_metaclass {
1112   return undef unless $INC{'Class/MOP.pm'};   # if CMOP is not loaded the class could not have loaded in the 1st place
1113
1114   my $mc = Class::MOP::class_of($_[1])
1115     or return undef;
1116
1117   return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1118 }
1119
1120 # We use this instead of ensure_class_loaded when there are package symbols we
1121 # want to preserve.
1122 sub _reload_class {
1123     my ($self, $class) = @_;
1124
1125     my $class_path = $self->_class_path($class);
1126     delete $INC{ $class_path };
1127
1128 # kill redefined warnings
1129     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
1130     local $SIG{__WARN__} = sub {
1131         $warn_handler->(@_)
1132             unless $_[0] =~ /^Subroutine \S+ redefined/;
1133     };
1134     eval "require $class;";
1135     die "Failed to reload class $class: $@" if $@;
1136 }
1137
1138 sub _get_dump_filename {
1139     my ($self, $class) = (@_);
1140
1141     $class =~ s{::}{/}g;
1142     return $self->dump_directory . q{/} . $class . q{.pm};
1143 }
1144
1145 sub _ensure_dump_subdirs {
1146     my ($self, $class) = (@_);
1147
1148     my @name_parts = split(/::/, $class);
1149     pop @name_parts; # we don't care about the very last element,
1150                      # which is a filename
1151
1152     my $dir = $self->dump_directory;
1153     while (1) {
1154         if(!-d $dir) {
1155             mkdir($dir) or croak "mkdir('$dir') failed: $!";
1156         }
1157         last if !@name_parts;
1158         $dir = File::Spec->catdir($dir, shift @name_parts);
1159     }
1160 }
1161
1162 sub _dump_to_dir {
1163     my ($self, @classes) = @_;
1164
1165     my $schema_class = $self->schema_class;
1166     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1167
1168     my $target_dir = $self->dump_directory;
1169     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1170         unless $self->{dynamic} or $self->{quiet};
1171
1172     my $schema_text =
1173           qq|package $schema_class;\n\n|
1174         . qq|# Created by DBIx::Class::Schema::Loader\n|
1175         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1176         . qq|use strict;\nuse warnings;\n\n|;
1177     if ($self->use_moose) {
1178         $schema_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1179     }
1180     else {
1181         $schema_text .= qq|use base '$schema_base_class';\n\n|;
1182     }
1183
1184     if ($self->use_namespaces) {
1185         $schema_text .= qq|__PACKAGE__->load_namespaces|;
1186         my $namespace_options;
1187
1188         my @attr = qw/resultset_namespace default_resultset_class/;
1189
1190         unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1191
1192         for my $attr (@attr) {
1193             if ($self->$attr) {
1194                 $namespace_options .= qq|    $attr => '| . $self->$attr . qq|',\n|
1195             }
1196         }
1197         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1198         $schema_text .= qq|;\n|;
1199     }
1200     else {
1201         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1202     }
1203
1204     {
1205         local $self->{version_to_dump} = $self->schema_version_to_dump;
1206         $self->_write_classfile($schema_class, $schema_text, 1);
1207     }
1208
1209     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1210
1211     foreach my $src_class (@classes) {
1212         my $src_text =
1213               qq|package $src_class;\n\n|
1214             . qq|# Created by DBIx::Class::Schema::Loader\n|
1215             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1216             . qq|use strict;\nuse warnings;\n\n|;
1217         if ($self->use_moose) {
1218             $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1219
1220             # these options 'use base' which is compile time
1221             if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1222                 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n\n|;
1223             }
1224             else {
1225                 $src_text .= qq|\nextends '$result_base_class';\n\n|;
1226             }
1227         }
1228         else {
1229              $src_text .= qq|use base '$result_base_class';\n\n|;
1230         }
1231         $self->_write_classfile($src_class, $src_text);
1232     }
1233
1234     # remove Result dir if downgrading from use_namespaces, and there are no
1235     # files left.
1236     if (my $result_ns = $self->_downgrading_to_load_classes
1237                         || $self->_rewriting_result_namespace) {
1238         my $result_namespace = $self->_result_namespace(
1239             $schema_class,
1240             $result_ns,
1241         );
1242
1243         (my $result_dir = $result_namespace) =~ s{::}{/}g;
1244         $result_dir = $self->dump_directory . '/' . $result_dir;
1245
1246         unless (my @files = glob "$result_dir/*") {
1247             rmdir $result_dir;
1248         }
1249     }
1250
1251     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1252
1253 }
1254
1255 sub _sig_comment {
1256     my ($self, $version, $ts) = @_;
1257     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1258          . qq| v| . $version
1259          . q| @ | . $ts
1260          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1261 }
1262
1263 sub _write_classfile {
1264     my ($self, $class, $text, $is_schema) = @_;
1265
1266     my $filename = $self->_get_dump_filename($class);
1267     $self->_ensure_dump_subdirs($class);
1268
1269     if (-f $filename && $self->really_erase_my_files) {
1270         warn "Deleting existing file '$filename' due to "
1271             . "'really_erase_my_files' setting\n" unless $self->{quiet};
1272         unlink($filename);
1273     }
1274
1275     my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1276         = $self->_parse_generated_file($filename);
1277
1278     if (! $old_gen && -f $filename) {
1279         croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1280             . " it does not appear to have been generated by Loader"
1281     }
1282
1283     my $custom_content = $old_custom || '';
1284
1285     # prepend extra custom content from a *renamed* class (singularization effect)
1286     if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1287         my $old_filename = $self->_get_dump_filename($renamed_class);
1288
1289         if (-f $old_filename) {
1290             my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1291
1292             $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1293
1294             $custom_content = join ("\n", '', $extra_custom, $custom_content)
1295                 if $extra_custom;
1296
1297             unlink $old_filename;
1298         }
1299     }
1300
1301     $custom_content ||= $self->_default_custom_content;
1302
1303     # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1304     # If there is already custom content, which does not have the Moose content, add it.
1305     if ($self->use_moose) {
1306
1307         my $non_moose_custom_content = do {
1308             local $self->{use_moose} = 0;
1309             $self->_default_custom_content;
1310         };
1311
1312         if ($custom_content eq $non_moose_custom_content) {
1313             $custom_content = $self->_default_custom_content;
1314         }
1315         elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content]}\E/) {
1316             $custom_content .= $self->_default_custom_content;
1317         }
1318     }
1319
1320     $custom_content = $self->_rewrite_old_classnames($custom_content);
1321
1322     $text .= qq|$_\n|
1323         for @{$self->{_dump_storage}->{$class} || []};
1324
1325     # Check and see if the dump is infact differnt
1326
1327     my $compare_to;
1328     if ($old_md5) {
1329       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1330       if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1331         return unless $self->_upgrading_from && $is_schema;
1332       }
1333     }
1334
1335     $text .= $self->_sig_comment(
1336       $self->version_to_dump,
1337       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1338     );
1339
1340     open(my $fh, '>', $filename)
1341         or croak "Cannot open '$filename' for writing: $!";
1342
1343     # Write the top half and its MD5 sum
1344     print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1345
1346     # Write out anything loaded via external partial class file in @INC
1347     print $fh qq|$_\n|
1348         for @{$self->{_ext_storage}->{$class} || []};
1349
1350     # Write out any custom content the user has added
1351     print $fh $custom_content;
1352
1353     close($fh)
1354         or croak "Error closing '$filename': $!";
1355 }
1356
1357 sub _default_moose_custom_content {
1358     return qq|\n__PACKAGE__->meta->make_immutable;|;
1359 }
1360
1361 sub _default_custom_content {
1362     my $self = shift;
1363     my $default = qq|\n\n# You can replace this text with custom|
1364          . qq| content, and it will be preserved on regeneration|;
1365     if ($self->use_moose) {
1366         $default .= $self->_default_moose_custom_content;
1367     }
1368     $default .= qq|\n1;\n|;
1369     return $default;
1370 }
1371
1372 sub _parse_generated_file {
1373     my ($self, $fn) = @_;
1374
1375     return unless -f $fn;
1376
1377     open(my $fh, '<', $fn)
1378         or croak "Cannot open '$fn' for reading: $!";
1379
1380     my $mark_re =
1381         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1382
1383     my ($md5, $ts, $ver, $gen);
1384     while(<$fh>) {
1385         if(/$mark_re/) {
1386             my $pre_md5 = $1;
1387             $md5 = $2;
1388
1389             # Pull out the version and timestamp from the line above
1390             ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1391
1392             $gen .= $pre_md5;
1393             croak "Checksum mismatch in '$fn', 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"
1394                 if !$self->overwrite_modifications && Digest::MD5::md5_base64($gen) ne $md5;
1395
1396             last;
1397         }
1398         else {
1399             $gen .= $_;
1400         }
1401     }
1402
1403     my $custom = do { local $/; <$fh> }
1404         if $md5;
1405
1406     close ($fh);
1407
1408     return ($gen, $md5, $ver, $ts, $custom);
1409 }
1410
1411 sub _use {
1412     my $self = shift;
1413     my $target = shift;
1414
1415     foreach (@_) {
1416         warn "$target: use $_;" if $self->debug;
1417         $self->_raw_stmt($target, "use $_;");
1418     }
1419 }
1420
1421 sub _inject {
1422     my $self = shift;
1423     my $target = shift;
1424
1425     my $blist = join(q{ }, @_);
1426
1427     return unless $blist;
1428
1429     warn "$target: use base qw/$blist/;" if $self->debug;
1430     $self->_raw_stmt($target, "use base qw/$blist/;");
1431 }
1432
1433 sub _result_namespace {
1434     my ($self, $schema_class, $ns) = @_;
1435     my @result_namespace;
1436
1437     if ($ns =~ /^\+(.*)/) {
1438         # Fully qualified namespace
1439         @result_namespace = ($1)
1440     }
1441     else {
1442         # Relative namespace
1443         @result_namespace = ($schema_class, $ns);
1444     }
1445
1446     return wantarray ? @result_namespace : join '::', @result_namespace;
1447 }
1448
1449 # Create class with applicable bases, setup monikers, etc
1450 sub _make_src_class {
1451     my ($self, $table) = @_;
1452
1453     my $schema       = $self->schema;
1454     my $schema_class = $self->schema_class;
1455
1456     my $table_moniker = $self->_table2moniker($table);
1457     my @result_namespace = ($schema_class);
1458     if ($self->use_namespaces) {
1459         my $result_namespace = $self->result_namespace || 'Result';
1460         @result_namespace = $self->_result_namespace(
1461             $schema_class,
1462             $result_namespace,
1463         );
1464     }
1465     my $table_class = join(q{::}, @result_namespace, $table_moniker);
1466
1467     if ((my $upgrading_v = $self->_upgrading_from)
1468             || $self->_rewriting) {
1469         local $self->naming->{monikers} = $upgrading_v
1470             if $upgrading_v;
1471
1472         my @result_namespace = @result_namespace;
1473         if ($self->_upgrading_from_load_classes) {
1474             @result_namespace = ($schema_class);
1475         }
1476         elsif (my $ns = $self->_downgrading_to_load_classes) {
1477             @result_namespace = $self->_result_namespace(
1478                 $schema_class,
1479                 $ns,
1480             );
1481         }
1482         elsif ($ns = $self->_rewriting_result_namespace) {
1483             @result_namespace = $self->_result_namespace(
1484                 $schema_class,
1485                 $ns,
1486             );
1487         }
1488
1489         my $old_class = join(q{::}, @result_namespace,
1490             $self->_table2moniker($table));
1491
1492         $self->_upgrading_classes->{$table_class} = $old_class
1493             unless $table_class eq $old_class;
1494     }
1495
1496 # this was a bad idea, should be ok now without it
1497 #    my $table_normalized = lc $table;
1498 #    $self->classes->{$table_normalized} = $table_class;
1499 #    $self->monikers->{$table_normalized} = $table_moniker;
1500
1501     $self->classes->{$table} = $table_class;
1502     $self->monikers->{$table} = $table_moniker;
1503
1504     $self->_use   ($table_class, @{$self->additional_classes});
1505     $self->_inject($table_class, @{$self->left_base_classes});
1506
1507     if (my @components = @{ $self->components }) {
1508         $self->_dbic_stmt($table_class, 'load_components', @components);
1509     }
1510
1511     $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1512         if @{$self->resultset_components};
1513     $self->_inject($table_class, @{$self->additional_base_classes});
1514 }
1515
1516 sub _resolve_col_accessor_collisions {
1517     my ($self, $col_info) = @_;
1518
1519     my $base       = $self->result_base_class || 'DBIx::Class::Core';
1520     my @components = map "DBIx::Class::$_", @{ $self->components || [] };
1521
1522     my @methods;
1523
1524     for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) {
1525         eval "require ${class};";
1526         die $@ if $@;
1527
1528         push @methods, @{ Class::Inspector->methods($class) || [] };
1529     }
1530
1531     my %methods;
1532     @methods{@methods} = ();
1533
1534     # futureproof meta
1535     $methods{meta} = undef;
1536
1537     while (my ($col, $info) = each %$col_info) {
1538         my $accessor = $info->{accessor} || $col;
1539
1540         next if $accessor eq 'id'; # special case (very common column)
1541
1542         if (exists $methods{$accessor}) {
1543             $info->{accessor} = undef;
1544         }
1545     }
1546 }
1547
1548 sub _make_column_accessor_name {
1549     my ($self, $column_name) = @_;
1550
1551     return join '_', map lc, split_name $column_name;
1552 }
1553
1554 # Set up metadata (cols, pks, etc)
1555 sub _setup_src_meta {
1556     my ($self, $table) = @_;
1557
1558     my $schema       = $self->schema;
1559     my $schema_class = $self->schema_class;
1560
1561     my $table_class = $self->classes->{$table};
1562     my $table_moniker = $self->monikers->{$table};
1563
1564     my $table_name = $table;
1565     my $name_sep   = $self->schema->storage->sql_maker->name_sep;
1566
1567     if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1568         $table_name = \ $self->_quote_table_name($table_name);
1569     }
1570
1571     my $full_table_name = ($self->qualify_objects ? ($self->db_schema . '.') : '') . (ref $table_name ? $$table_name : $table_name);
1572
1573     # be careful to not create refs Data::Dump can "optimize"
1574     $full_table_name    = \do {"".$full_table_name} if ref $table_name;
1575
1576     $self->_dbic_stmt($table_class, 'table', $full_table_name);
1577
1578     my $cols = $self->_table_columns($table);
1579     my $col_info = $self->__columns_info_for($table);
1580
1581     while (my ($col, $info) = each %$col_info) {
1582         if ($col =~ /\W/) {
1583             ($info->{accessor} = $col) =~ s/\W+/_/g;
1584         }
1585     }
1586
1587     if ($self->preserve_case) {
1588         while (my ($col, $info) = each %$col_info) {
1589             if ($col ne lc($col)) {
1590                 if ((not exists $self->naming->{column_accessors}) || (($self->naming->{column_accessors} =~ /(\d+)/)[0] >= 7)) {
1591                     $info->{accessor} = $self->_make_column_accessor_name($info->{accessor} || $col);
1592                 }
1593                 else {
1594                     $info->{accessor} = lc($info->{accessor} || $col);
1595                 }
1596             }
1597         }
1598     }
1599     else {
1600         # XXX this needs to go away
1601         $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1602     }
1603
1604     $self->_resolve_col_accessor_collisions($col_info);
1605
1606     my $fks = $self->_table_fk_info($table);
1607
1608     foreach my $fkdef (@$fks) {
1609         for my $col (@{ $fkdef->{local_columns} }) {
1610             $col_info->{$col}{is_foreign_key} = 1;
1611         }
1612     }
1613
1614     my $pks = $self->_table_pk_info($table) || [];
1615
1616     foreach my $pkcol (@$pks) {
1617         $col_info->{$pkcol}{is_nullable} = 0;
1618     }
1619
1620     $self->_dbic_stmt(
1621         $table_class,
1622         'add_columns',
1623         map { $_, ($col_info->{$_}||{}) } @$cols
1624     );
1625
1626     my %uniq_tag; # used to eliminate duplicate uniqs
1627
1628     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1629           : carp("$table has no primary key");
1630     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1631
1632     my $uniqs = $self->_table_uniq_info($table) || [];
1633     for (@$uniqs) {
1634         my ($name, $cols) = @$_;
1635         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1636         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1637     }
1638
1639 }
1640
1641 sub __columns_info_for {
1642     my ($self, $table) = @_;
1643
1644     my $result = $self->_columns_info_for($table);
1645
1646     while (my ($col, $info) = each %$result) {
1647         $info = { %$info, %{ $self->_custom_column_info  ($table, $col, $info) } };
1648         $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1649
1650         $result->{$col} = $info;
1651     }
1652
1653     return $result;
1654 }
1655
1656 =head2 tables
1657
1658 Returns a sorted list of loaded tables, using the original database table
1659 names.
1660
1661 =cut
1662
1663 sub tables {
1664     my $self = shift;
1665
1666     return keys %{$self->_tables};
1667 }
1668
1669 # Make a moniker from a table
1670 sub _default_table2moniker {
1671     no warnings 'uninitialized';
1672     my ($self, $table) = @_;
1673
1674     if ($self->naming->{monikers} eq 'v4') {
1675         return join '', map ucfirst, split /[\W_]+/, lc $table;
1676     }
1677     elsif ($self->naming->{monikers} eq 'v5') {
1678         return join '', map ucfirst, split /[\W_]+/,
1679             Lingua::EN::Inflect::Number::to_S(lc $table);
1680     }
1681     elsif ($self->naming->{monikers} eq 'v6') {
1682         (my $as_phrase = lc $table) =~ s/_+/ /g;
1683         my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1684
1685         return join '', map ucfirst, split /\W+/, $inflected;
1686     }
1687
1688     my @words = map lc, split_name $table;
1689     my $as_phrase = join ' ', @words;
1690
1691     my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1692
1693     return join '', map ucfirst, split /\W+/, $inflected;
1694 }
1695
1696 sub _table2moniker {
1697     my ( $self, $table ) = @_;
1698
1699     my $moniker;
1700
1701     if( ref $self->moniker_map eq 'HASH' ) {
1702         $moniker = $self->moniker_map->{$table};
1703     }
1704     elsif( ref $self->moniker_map eq 'CODE' ) {
1705         $moniker = $self->moniker_map->($table);
1706     }
1707
1708     $moniker ||= $self->_default_table2moniker($table);
1709
1710     return $moniker;
1711 }
1712
1713 sub _load_relationships {
1714     my ($self, $table) = @_;
1715
1716     my $tbl_fk_info = $self->_table_fk_info($table);
1717     foreach my $fkdef (@$tbl_fk_info) {
1718         $fkdef->{remote_source} =
1719             $self->monikers->{delete $fkdef->{remote_table}};
1720     }
1721     my $tbl_uniq_info = $self->_table_uniq_info($table);
1722
1723     my $local_moniker = $self->monikers->{$table};
1724     my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1725
1726     foreach my $src_class (sort keys %$rel_stmts) {
1727         my $src_stmts = $rel_stmts->{$src_class};
1728         foreach my $stmt (@$src_stmts) {
1729             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1730         }
1731     }
1732 }
1733
1734 # Overload these in driver class:
1735
1736 # Returns an arrayref of column names
1737 sub _table_columns { croak "ABSTRACT METHOD" }
1738
1739 # Returns arrayref of pk col names
1740 sub _table_pk_info { croak "ABSTRACT METHOD" }
1741
1742 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1743 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1744
1745 # Returns an arrayref of foreign key constraints, each
1746 #   being a hashref with 3 keys:
1747 #   local_columns (arrayref), remote_columns (arrayref), remote_table
1748 sub _table_fk_info { croak "ABSTRACT METHOD" }
1749
1750 # Returns an array of lower case table names
1751 sub _tables_list { croak "ABSTRACT METHOD" }
1752
1753 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1754 sub _dbic_stmt {
1755     my $self   = shift;
1756     my $class  = shift;
1757     my $method = shift;
1758
1759     # generate the pod for this statement, storing it with $self->_pod
1760     $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
1761
1762     my $args = dump(@_);
1763     $args = '(' . $args . ')' if @_ < 2;
1764     my $stmt = $method . $args . q{;};
1765
1766     warn qq|$class\->$stmt\n| if $self->debug;
1767     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1768     return;
1769 }
1770
1771 # generates the accompanying pod for a DBIC class method statement,
1772 # storing it with $self->_pod
1773 sub _make_pod {
1774     my $self   = shift;
1775     my $class  = shift;
1776     my $method = shift;
1777
1778     if ( $method eq 'table' ) {
1779         my ($table) = @_;
1780         my $pcm = $self->pod_comment_mode;
1781         my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
1782         $comment = $self->__table_comment($table);
1783         $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1784         $comment_in_name   = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1785         $comment_in_desc   = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
1786         $self->_pod( $class, "=head1 NAME" );
1787         my $table_descr = $class;
1788         $table_descr .= " - " . $comment if $comment and $comment_in_name;
1789         $self->{_class2table}{ $class } = $table;
1790         $self->_pod( $class, $table_descr );
1791         if ($comment and $comment_in_desc) {
1792             $self->_pod( $class, "=head1 DESCRIPTION" );
1793             $self->_pod( $class, $comment );
1794         }
1795         $self->_pod_cut( $class );
1796     } elsif ( $method eq 'add_columns' ) {
1797         $self->_pod( $class, "=head1 ACCESSORS" );
1798         my $col_counter = 0;
1799         my @cols = @_;
1800         while( my ($name,$attrs) = splice @cols,0,2 ) {
1801             $col_counter++;
1802             $self->_pod( $class, '=head2 ' . $name  );
1803             $self->_pod( $class,
1804                          join "\n", map {
1805                              my $s = $attrs->{$_};
1806                              $s = !defined $s         ? 'undef'          :
1807                                   length($s) == 0     ? '(empty string)' :
1808                                   ref($s) eq 'SCALAR' ? $$s :
1809                                   ref($s)             ? dumper_squashed $s :
1810                                   looks_like_number($s) ? $s :
1811                                                         qq{'$s'}
1812                                   ;
1813
1814                              "  $_: $s"
1815                          } sort keys %$attrs,
1816                        );
1817
1818             if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter)) {
1819                 $self->_pod( $class, $comment );
1820             }
1821         }
1822         $self->_pod_cut( $class );
1823     } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1824         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1825         my ( $accessor, $rel_class ) = @_;
1826         $self->_pod( $class, "=head2 $accessor" );
1827         $self->_pod( $class, 'Type: ' . $method );
1828         $self->_pod( $class, "Related object: L<$rel_class>" );
1829         $self->_pod_cut( $class );
1830         $self->{_relations_started} { $class } = 1;
1831     }
1832 }
1833
1834 sub _filter_comment {
1835     my ($self, $txt) = @_;
1836
1837     $txt = '' if not defined $txt;
1838
1839     $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
1840
1841     return $txt;
1842 }
1843
1844 sub __table_comment {
1845     my $self = shift;
1846
1847     if (my $code = $self->can('_table_comment')) {
1848         return $self->_filter_comment($self->$code(@_));
1849     }
1850
1851     return '';
1852 }
1853
1854 sub __column_comment {
1855     my $self = shift;
1856
1857     if (my $code = $self->can('_column_comment')) {
1858         return $self->_filter_comment($self->$code(@_));
1859     }
1860
1861     return '';
1862 }
1863
1864 # Stores a POD documentation
1865 sub _pod {
1866     my ($self, $class, $stmt) = @_;
1867     $self->_raw_stmt( $class, "\n" . $stmt  );
1868 }
1869
1870 sub _pod_cut {
1871     my ($self, $class ) = @_;
1872     $self->_raw_stmt( $class, "\n=cut\n" );
1873 }
1874
1875 # Store a raw source line for a class (for dumping purposes)
1876 sub _raw_stmt {
1877     my ($self, $class, $stmt) = @_;
1878     push(@{$self->{_dump_storage}->{$class}}, $stmt);
1879 }
1880
1881 # Like above, but separately for the externally loaded stuff
1882 sub _ext_stmt {
1883     my ($self, $class, $stmt) = @_;
1884     push(@{$self->{_ext_storage}->{$class}}, $stmt);
1885 }
1886
1887 sub _quote_table_name {
1888     my ($self, $table) = @_;
1889
1890     my $qt = $self->schema->storage->sql_maker->quote_char;
1891
1892     return $table unless $qt;
1893
1894     if (ref $qt) {
1895         return $qt->[0] . $table . $qt->[1];
1896     }
1897
1898     return $qt . $table . $qt;
1899 }
1900
1901 sub _custom_column_info {
1902     my ( $self, $table_name, $column_name, $column_info ) = @_;
1903
1904     if (my $code = $self->custom_column_info) {
1905         return $code->($table_name, $column_name, $column_info) || {};
1906     }
1907     return {};
1908 }
1909
1910 sub _datetime_column_info {
1911     my ( $self, $table_name, $column_name, $column_info ) = @_;
1912     my $result = {};
1913     my $type = $column_info->{data_type} || '';
1914     if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
1915             or ($type =~ /date|timestamp/i)) {
1916         $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
1917         $result->{locale}   = $self->datetime_locale   if $self->datetime_locale;
1918     }
1919     return $result;
1920 }
1921
1922 sub _lc {
1923     my ($self, $name) = @_;
1924
1925     return $self->preserve_case ? $name : lc($name);
1926 }
1927
1928 sub _uc {
1929     my ($self, $name) = @_;
1930
1931     return $self->preserve_case ? $name : uc($name);
1932 }
1933
1934 sub _unregister_source_for_table {
1935     my ($self, $table) = @_;
1936
1937     eval {
1938         local $@;
1939         my $schema = $self->schema;
1940         # in older DBIC it's a private method
1941         my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
1942         $schema->$unregister($self->_table2moniker($table));
1943         delete $self->monikers->{$table};
1944         delete $self->classes->{$table};
1945         delete $self->_upgrading_classes->{$table};
1946         delete $self->{_tables}{$table};
1947     };
1948 }
1949
1950 # remove the dump dir from @INC on destruction
1951 sub DESTROY {
1952     my $self = shift;
1953
1954     @INC = grep $_ ne $self->dump_directory, @INC;
1955 }
1956
1957 =head2 monikers
1958
1959 Returns a hashref of loaded table to moniker mappings.  There will
1960 be two entries for each table, the original name and the "normalized"
1961 name, in the case that the two are different (such as databases
1962 that like uppercase table names, or preserve your original mixed-case
1963 definitions, or what-have-you).
1964
1965 =head2 classes
1966
1967 Returns a hashref of table to class mappings.  In some cases it will
1968 contain multiple entries per table for the original and normalized table
1969 names, as above in L</monikers>.
1970
1971 =head1 SEE ALSO
1972
1973 L<DBIx::Class::Schema::Loader>
1974
1975 =head1 AUTHOR
1976
1977 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1978
1979 =head1 LICENSE
1980
1981 This library is free software; you can redistribute it and/or modify it under
1982 the same terms as Perl itself.
1983
1984 =cut
1985
1986 1;
1987 # vim:et sts=4 sw=4 tw=0: