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