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