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