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