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