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                                 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     my $result_namespace = do { ($old_gen =~ /result_namespace => '([^']+)'/) ? $1 : '' };
 839
 840     if ($load_classes && (not defined $self->use_namespaces)) {
 841         warn <<"EOF"  unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 842
 843 'load_classes;' static schema detected, turning off 'use_namespaces'.
 844
 845 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
 846 variable to disable this warning.
 847
 848 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 849 details.
 850 EOF
 851         $self->use_namespaces(0);
 852     }
 853     elsif ($load_classes && $self->use_namespaces) {
 854         $self->_upgrading_from_load_classes(1);
 855     }
 856     elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
 857         $self->_downgrading_to_load_classes(
 858             $result_namespace || 'Result'
 859         );
 860     }
 861     elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
 862         if (not $self->result_namespace) {
 863             $self->result_namespace($result_namespace || 'Result');
 864         }
 865         elsif ($result_namespace ne $self->result_namespace) {
 866             $self->_rewriting_result_namespace(
 867                 $result_namespace || 'Result'
 868             );
 869         }
 870     }
 871
 872     # XXX when we go past .0 this will need fixing
 873     my ($v) = $old_ver =~ /([1-9])/;
 874     $v = "v$v";
 875
 876     return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
 877
 878     if (not %{ $self->naming }) {
 879         warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 880
 881 Version $old_ver static schema detected, turning on backcompat mode.
 882
 883 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 884 to disable this warning.
 885
 886 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
 887
 888 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
 889 from version 0.04006.
 890 EOF
 891
 892         $self->naming->{relationships}    ||= $v;
 893         $self->naming->{monikers}         ||= $v;
 894         $self->naming->{column_accessors} ||= $v;
 895
 896         $self->schema_version_to_dump($old_ver);
 897     }
 898     else {
 899         $self->_upgrading_from($v);
 900     }
 901 }
 902
 903 sub _validate_class_args {
 904     my $self = shift;
 905
 906     foreach my $k (@CLASS_ARGS) {
 907         next unless $self->$k;
 908
 909         my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
 910         $self->_validate_classes($k, \@classes);
 911     }
 912 }
 913
 914 sub _validate_result_components_map {
 915     my $self = shift;
 916
 917     foreach my $classes (values %{ $self->result_components_map }) {
 918         $self->_validate_classes('result_components_map', $classes);
 919     }
 920 }
 921
 922 sub _validate_result_roles_map {
 923     my $self = shift;
 924
 925     foreach my $classes (values %{ $self->result_roles_map }) {
 926         $self->_validate_classes('result_roles_map', $classes);
 927     }
 928 }
 929
 930 sub _validate_classes {
 931     my $self = shift;
 932     my $key  = shift;
 933     my $classes = shift;
 934
 935     # make a copy to not destroy original
 936     my @classes = @$classes;
 937
 938     foreach my $c (@classes) {
 939         # components default to being under the DBIx::Class namespace unless they
 940         # are preceeded with a '+'
 941         if ( $key =~ m/component/ && $c !~ s/^\+// ) {
 942             $c = 'DBIx::Class::' . $c;
 943         }
 944
 945         # 1 == installed, 0 == not installed, undef == invalid classname
 946         my $installed = Class::Inspector->installed($c);
 947         if ( defined($installed) ) {
 948             if ( $installed == 0 ) {
 949                 croak qq/$c, as specified in the loader option "$key", is not installed/;
 950             }
 951         } else {
 952             croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
 953         }
 954     }
 955 }
 956
 957
 958 sub _find_file_in_inc {
 959     my ($self, $file) = @_;
 960
 961     foreach my $prefix (@INC) {
 962         my $fullpath = File::Spec->catfile($prefix, $file);
 963         return $fullpath if -f $fullpath
 964             # abs_path throws on Windows for nonexistant files
 965             and (try { Cwd::abs_path($fullpath) }) ne
 966                ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
 967     }
 968
 969     return;
 970 }
 971
 972 sub _find_class_in_inc {
 973     my ($self, $class) = @_;
 974
 975     return $self->_find_file_in_inc(class_path($class));
 976 }
 977
 978 sub _rewriting {
 979     my $self = shift;
 980
 981     return $self->_upgrading_from
 982         || $self->_upgrading_from_load_classes
 983         || $self->_downgrading_to_load_classes
 984         || $self->_rewriting_result_namespace
 985     ;
 986 }
 987
 988 sub _rewrite_old_classnames {
 989     my ($self, $code) = @_;
 990
 991     return $code unless $self->_rewriting;
 992
 993     my %old_classes = reverse %{ $self->_upgrading_classes };
 994
 995     my $re = join '|', keys %old_classes;
 996     $re = qr/\b($re)\b/;
 997
 998     $code =~ s/$re/$old_classes{$1} || $1/eg;
 999
1000     return $code;
1001 }
1002
1003 sub _load_external {
1004     my ($self, $class) = @_;
1005
1006     return if $self->{skip_load_external};
1007
1008     # so that we don't load our own classes, under any circumstances
1009     local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1010
1011     my $real_inc_path = $self->_find_class_in_inc($class);
1012
1013     my $old_class = $self->_upgrading_classes->{$class}
1014         if $self->_rewriting;
1015
1016     my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1017         if $old_class && $old_class ne $class;
1018
1019     return unless $real_inc_path || $old_real_inc_path;
1020
1021     if ($real_inc_path) {
1022         # If we make it to here, we loaded an external definition
1023         warn qq/# Loaded external class definition for '$class'\n/
1024             if $self->debug;
1025
1026         my $code = $self->_rewrite_old_classnames(decode 'UTF-8', scalar slurp $real_inc_path);
1027
1028         if ($self->dynamic) { # load the class too
1029             eval_package_without_redefine_warnings($class, $code);
1030         }
1031
1032         $self->_ext_stmt($class,
1033           qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1034          .qq|# They are now part of the custom portion of this file\n|
1035          .qq|# for you to hand-edit.  If you do not either delete\n|
1036          .qq|# this section or remove that file from \@INC, this section\n|
1037          .qq|# will be repeated redundantly when you re-create this\n|
1038          .qq|# file again via Loader!  See skip_load_external to disable\n|
1039          .qq|# this feature.\n|
1040         );
1041         chomp $code;
1042         $self->_ext_stmt($class, $code);
1043         $self->_ext_stmt($class,
1044             qq|# End of lines loaded from '$real_inc_path' |
1045         );
1046     }
1047
1048     if ($old_real_inc_path) {
1049         my $code = decode 'UTF-8', scalar slurp $old_real_inc_path;
1050
1051         $self->_ext_stmt($class, <<"EOF");
1052
1053 # These lines were loaded from '$old_real_inc_path',
1054 # based on the Result class name that would have been created by an older
1055 # version of the Loader. For a static schema, this happens only once during
1056 # upgrade. See skip_load_external to disable this feature.
1057 EOF
1058
1059         $code = $self->_rewrite_old_classnames($code);
1060
1061         if ($self->dynamic) {
1062             warn <<"EOF";
1063
1064 Detected external content in '$old_real_inc_path', a class name that would have
1065 been used by an older version of the Loader.
1066
1067 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1068 new name of the Result.
1069 EOF
1070             eval_package_without_redefine_warnings($class, $code);
1071         }
1072
1073         chomp $code;
1074         $self->_ext_stmt($class, $code);
1075         $self->_ext_stmt($class,
1076             qq|# End of lines loaded from '$old_real_inc_path' |
1077         );
1078     }
1079 }
1080
1081 =head2 load
1082
1083 Does the actual schema-construction work.
1084
1085 =cut
1086
1087 sub load {
1088     my $self = shift;
1089
1090     $self->_load_tables(
1091         $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1092     );
1093 }
1094
1095 =head2 rescan
1096
1097 Arguments: schema
1098
1099 Rescan the database for changes. Returns a list of the newly added table
1100 monikers.
1101
1102 The schema argument should be the schema class or object to be affected.  It
1103 should probably be derived from the original schema_class used during L</load>.
1104
1105 =cut
1106
1107 sub rescan {
1108     my ($self, $schema) = @_;
1109
1110     $self->{schema} = $schema;
1111     $self->_relbuilder->{schema} = $schema;
1112
1113     my @created;
1114     my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1115
1116     foreach my $table (@current) {
1117         if(!exists $self->{_tables}->{$table}) {
1118             push(@created, $table);
1119         }
1120     }
1121
1122     my %current;
1123     @current{@current} = ();
1124     foreach my $table (keys %{ $self->{_tables} }) {
1125         if (not exists $current{$table}) {
1126             $self->_unregister_source_for_table($table);
1127         }
1128     }
1129
1130     delete $self->{_dump_storage};
1131     delete $self->{_relations_started};
1132
1133     my $loaded = $self->_load_tables(@current);
1134
1135     return map { $self->monikers->{$_} } @created;
1136 }
1137
1138 sub _relbuilder {
1139     my ($self) = @_;
1140
1141     return if $self->{skip_relationships};
1142
1143     return $self->{relbuilder} ||= do {
1144
1145         no warnings 'uninitialized';
1146         my $relbuilder_suff =
1147             {qw{
1148                 v4  ::Compat::v0_040
1149                 v5  ::Compat::v0_05
1150                 v6  ::Compat::v0_06
1151             }}
1152             ->{ $self->naming->{relationships}};
1153
1154         my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1155         $self->ensure_class_loaded($relbuilder_class);
1156         $relbuilder_class->new( $self );
1157
1158     };
1159 }
1160
1161 sub _load_tables {
1162     my ($self, @tables) = @_;
1163
1164     # Save the new tables to the tables list
1165     foreach (@tables) {
1166         $self->{_tables}->{$_} = 1;
1167     }
1168
1169     $self->_make_src_class($_) for @tables;
1170
1171     # sanity-check for moniker clashes
1172     my $inverse_moniker_idx;
1173     for (keys %{$self->monikers}) {
1174       push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1175     }
1176
1177     my @clashes;
1178     for (keys %$inverse_moniker_idx) {
1179       my $tables = $inverse_moniker_idx->{$_};
1180       if (@$tables > 1) {
1181         push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1182           join (', ', map { "'$_'" } @$tables),
1183           $_,
1184         );
1185       }
1186     }
1187
1188     if (@clashes) {
1189       die   'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1190           . 'Either change the naming style, or supply an explicit moniker_map: '
1191           . join ('; ', @clashes)
1192           . "\n"
1193       ;
1194     }
1195
1196
1197     $self->_setup_src_meta($_) for @tables;
1198
1199     if(!$self->skip_relationships) {
1200         # The relationship loader needs a working schema
1201         $self->{quiet} = 1;
1202         local $self->{dump_directory} = $self->{temp_directory};
1203         $self->_reload_classes(\@tables);
1204         $self->_load_relationships(\@tables);
1205         $self->{quiet} = 0;
1206
1207         # Remove that temp dir from INC so it doesn't get reloaded
1208         @INC = grep $_ ne $self->dump_directory, @INC;
1209     }
1210
1211     $self->_load_roles($_) for @tables;
1212
1213     $self->_load_external($_)
1214         for map { $self->classes->{$_} } @tables;
1215
1216     # Reload without unloading first to preserve any symbols from external
1217     # packages.
1218     $self->_reload_classes(\@tables, { unload => 0 });
1219
1220     # Drop temporary cache
1221     delete $self->{_cache};
1222
1223     return \@tables;
1224 }
1225
1226 sub _reload_classes {
1227     my ($self, $tables, $opts) = @_;
1228
1229     my @tables = @$tables;
1230
1231     my $unload = $opts->{unload};
1232     $unload = 1 unless defined $unload;
1233
1234     # so that we don't repeat custom sections
1235     @INC = grep $_ ne $self->dump_directory, @INC;
1236
1237     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1238
1239     unshift @INC, $self->dump_directory;
1240
1241     my @to_register;
1242     my %have_source = map { $_ => $self->schema->source($_) }
1243         $self->schema->sources;
1244
1245     for my $table (@tables) {
1246         my $moniker = $self->monikers->{$table};
1247         my $class = $self->classes->{$table};
1248
1249         {
1250             no warnings 'redefine';
1251             local *Class::C3::reinitialize = sub {};  # to speed things up, reinitialized below
1252             use warnings;
1253
1254             if (my $mc = $self->_moose_metaclass($class)) {
1255                 $mc->make_mutable;
1256             }
1257             Class::Unload->unload($class) if $unload;
1258             my ($source, $resultset_class);
1259             if (
1260                 ($source = $have_source{$moniker})
1261                 && ($resultset_class = $source->resultset_class)
1262                 && ($resultset_class ne 'DBIx::Class::ResultSet')
1263             ) {
1264                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1265                 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1266                     $mc->make_mutable;
1267                 }
1268                 Class::Unload->unload($resultset_class) if $unload;
1269                 $self->_reload_class($resultset_class) if $has_file;
1270             }
1271             $self->_reload_class($class);
1272         }
1273         push @to_register, [$moniker, $class];
1274     }
1275
1276     Class::C3->reinitialize;
1277     for (@to_register) {
1278         $self->schema->register_class(@$_);
1279     }
1280 }
1281
1282 sub _moose_metaclass {
1283   return undef unless $INC{'Class/MOP.pm'};   # if CMOP is not loaded the class could not have loaded in the 1st place
1284
1285   my $class = $_[1];
1286
1287   my $mc = try { Class::MOP::class_of($class) }
1288     or return undef;
1289
1290   return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1291 }
1292
1293 # We use this instead of ensure_class_loaded when there are package symbols we
1294 # want to preserve.
1295 sub _reload_class {
1296     my ($self, $class) = @_;
1297
1298     delete $INC{ +class_path($class) };
1299
1300     try {
1301         eval_package_without_redefine_warnings ($class, "require $class");
1302     }
1303     catch {
1304         my $source = decode 'UTF-8', scalar slurp $self->_get_dump_filename($class);
1305         die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1306     };
1307 }
1308
1309 sub _get_dump_filename {
1310     my ($self, $class) = (@_);
1311
1312     $class =~ s{::}{/}g;
1313     return $self->dump_directory . q{/} . $class . q{.pm};
1314 }
1315
1316 =head2 get_dump_filename
1317
1318 Arguments: class
1319
1320 Returns the full path to the file for a class that the class has been or will
1321 be dumped to. This is a file in a temp dir for a dynamic schema.
1322
1323 =cut
1324
1325 sub get_dump_filename {
1326     my ($self, $class) = (@_);
1327
1328     local $self->{dump_directory} = $self->real_dump_directory;
1329
1330     return $self->_get_dump_filename($class);
1331 }
1332
1333 sub _ensure_dump_subdirs {
1334     my ($self, $class) = (@_);
1335
1336     my @name_parts = split(/::/, $class);
1337     pop @name_parts; # we don't care about the very last element,
1338                      # which is a filename
1339
1340     my $dir = $self->dump_directory;
1341     while (1) {
1342         if(!-d $dir) {
1343             mkdir($dir) or croak "mkdir('$dir') failed: $!";
1344         }
1345         last if !@name_parts;
1346         $dir = File::Spec->catdir($dir, shift @name_parts);
1347     }
1348 }
1349
1350 sub _dump_to_dir {
1351     my ($self, @classes) = @_;
1352
1353     my $schema_class = $self->schema_class;
1354     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1355
1356     my $target_dir = $self->dump_directory;
1357     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1358         unless $self->{dynamic} or $self->{quiet};
1359
1360     my $schema_text =
1361           qq|package $schema_class;\n\n|
1362         . qq|# Created by DBIx::Class::Schema::Loader\n|
1363         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1364
1365     if ($self->use_moose) {
1366         $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1367     }
1368     else {
1369         $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1370     }
1371
1372     if ($self->use_namespaces) {
1373         $schema_text .= qq|__PACKAGE__->load_namespaces|;
1374         my $namespace_options;
1375
1376         my @attr = qw/resultset_namespace default_resultset_class/;
1377
1378         unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1379
1380         for my $attr (@attr) {
1381             if ($self->$attr) {
1382                 $namespace_options .= qq|    $attr => '| . $self->$attr . qq|',\n|
1383             }
1384         }
1385         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1386         $schema_text .= qq|;\n|;
1387     }
1388     else {
1389         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1390     }
1391
1392     {
1393         local $self->{version_to_dump} = $self->schema_version_to_dump;
1394         $self->_write_classfile($schema_class, $schema_text, 1);
1395     }
1396
1397     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1398
1399     foreach my $src_class (@classes) {
1400         my $src_text =
1401               qq|package $src_class;\n\n|
1402             . qq|# Created by DBIx::Class::Schema::Loader\n|
1403             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1404
1405         $src_text .= $self->_make_pod_heading($src_class);
1406
1407         $src_text .= qq|use strict;\nuse warnings;\n\n|;
1408
1409         $src_text .= $self->_base_class_pod($result_base_class)
1410             unless $result_base_class eq 'DBIx::Class::Core';
1411
1412         if ($self->use_moose) {
1413             $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1414
1415             # these options 'use base' which is compile time
1416             if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1417                 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1418             }
1419             else {
1420                 $src_text .= qq|\nextends '$result_base_class';\n|;
1421             }
1422         }
1423         else {
1424              $src_text .= qq|use base '$result_base_class';\n|;
1425         }
1426
1427         $self->_write_classfile($src_class, $src_text);
1428     }
1429
1430     # remove Result dir if downgrading from use_namespaces, and there are no
1431     # files left.
1432     if (my $result_ns = $self->_downgrading_to_load_classes
1433                         || $self->_rewriting_result_namespace) {
1434         my $result_namespace = $self->_result_namespace(
1435             $schema_class,
1436             $result_ns,
1437         );
1438
1439         (my $result_dir = $result_namespace) =~ s{::}{/}g;
1440         $result_dir = $self->dump_directory . '/' . $result_dir;
1441
1442         unless (my @files = glob "$result_dir/*") {
1443             rmdir $result_dir;
1444         }
1445     }
1446
1447     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1448
1449 }
1450
1451 sub _sig_comment {
1452     my ($self, $version, $ts) = @_;
1453     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1454          . qq| v| . $version
1455          . q| @ | . $ts
1456          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1457 }
1458
1459 sub _write_classfile {
1460     my ($self, $class, $text, $is_schema) = @_;
1461
1462     my $filename = $self->_get_dump_filename($class);
1463     $self->_ensure_dump_subdirs($class);
1464
1465     if (-f $filename && $self->really_erase_my_files) {
1466         warn "Deleting existing file '$filename' due to "
1467             . "'really_erase_my_files' setting\n" unless $self->{quiet};
1468         unlink($filename);
1469     }
1470
1471     my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1472         = $self->_parse_generated_file($filename);
1473
1474     if (! $old_gen && -f $filename) {
1475         croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1476             . " it does not appear to have been generated by Loader"
1477     }
1478
1479     my $custom_content = $old_custom || '';
1480
1481     # prepend extra custom content from a *renamed* class (singularization effect)
1482     if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1483         my $old_filename = $self->_get_dump_filename($renamed_class);
1484
1485         if (-f $old_filename) {
1486             my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1487
1488             $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1489
1490             $custom_content = join ("\n", '', $extra_custom, $custom_content)
1491                 if $extra_custom;
1492
1493             unlink $old_filename;
1494         }
1495     }
1496
1497     $custom_content ||= $self->_default_custom_content($is_schema);
1498
1499     # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1500     # If there is already custom content, which does not have the Moose content, add it.
1501     if ($self->use_moose) {
1502
1503         my $non_moose_custom_content = do {
1504             local $self->{use_moose} = 0;
1505             $self->_default_custom_content;
1506         };
1507
1508         if ($custom_content eq $non_moose_custom_content) {
1509             $custom_content = $self->_default_custom_content($is_schema);
1510         }
1511         elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1512             $custom_content .= $self->_default_custom_content($is_schema);
1513         }
1514     }
1515     elsif (defined $self->use_moose && $old_gen) {
1516         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'
1517             if $old_gen =~ /use \s+ MooseX?\b/x;
1518     }
1519
1520     $custom_content = $self->_rewrite_old_classnames($custom_content);
1521
1522     $text .= qq|$_\n|
1523         for @{$self->{_dump_storage}->{$class} || []};
1524
1525     # Check and see if the dump is infact differnt
1526
1527     my $compare_to;
1528     if ($old_md5) {
1529       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1530       if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1531         return unless $self->_upgrading_from && $is_schema;
1532       }
1533     }
1534
1535     $text .= $self->_sig_comment(
1536       $self->version_to_dump,
1537       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1538     );
1539
1540     open(my $fh, '>:encoding(UTF-8)', $filename)
1541         or croak "Cannot open '$filename' for writing: $!";
1542
1543     # Write the top half and its MD5 sum
1544     print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1545
1546     # Write out anything loaded via external partial class file in @INC
1547     print $fh qq|$_\n|
1548         for @{$self->{_ext_storage}->{$class} || []};
1549
1550     # Write out any custom content the user has added
1551     print $fh $custom_content;
1552
1553     close($fh)
1554         or croak "Error closing '$filename': $!";
1555 }
1556
1557 sub _default_moose_custom_content {
1558     my ($self, $is_schema) = @_;
1559
1560     if (not $is_schema) {
1561         return qq|\n__PACKAGE__->meta->make_immutable;|;
1562     }
1563
1564     return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1565 }
1566
1567 sub _default_custom_content {
1568     my ($self, $is_schema) = @_;
1569     my $default = qq|\n\n# You can replace this text with custom|
1570          . qq| code or comments, and it will be preserved on regeneration|;
1571     if ($self->use_moose) {
1572         $default .= $self->_default_moose_custom_content($is_schema);
1573     }
1574     $default .= qq|\n1;\n|;
1575     return $default;
1576 }
1577
1578 sub _parse_generated_file {
1579     my ($self, $fn) = @_;
1580
1581     return unless -f $fn;
1582
1583     open(my $fh, '<:encoding(UTF-8)', $fn)
1584         or croak "Cannot open '$fn' for reading: $!";
1585
1586     my $mark_re =
1587         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1588
1589     my ($md5, $ts, $ver, $gen);
1590     while(<$fh>) {
1591         if(/$mark_re/) {
1592             my $pre_md5 = $1;
1593             $md5 = $2;
1594
1595             # Pull out the version and timestamp from the line above
1596             ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1597
1598             $gen .= $pre_md5;
1599             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"
1600                 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
1601
1602             last;
1603         }
1604         else {
1605             $gen .= $_;
1606         }
1607     }
1608
1609     my $custom = do { local $/; <$fh> }
1610         if $md5;
1611
1612     close ($fh);
1613
1614     return ($gen, $md5, $ver, $ts, $custom);
1615 }
1616
1617 sub _use {
1618     my $self = shift;
1619     my $target = shift;
1620
1621     foreach (@_) {
1622         warn "$target: use $_;" if $self->debug;
1623         $self->_raw_stmt($target, "use $_;");
1624     }
1625 }
1626
1627 sub _inject {
1628     my $self = shift;
1629     my $target = shift;
1630
1631     my $blist = join(q{ }, @_);
1632
1633     return unless $blist;
1634
1635     warn "$target: use base qw/$blist/;" if $self->debug;
1636     $self->_raw_stmt($target, "use base qw/$blist/;");
1637 }
1638
1639 sub _with {
1640     my $self = shift;
1641     my $target = shift;
1642
1643     my $rlist = join(q{, }, map { qq{'$_'} } @_);
1644
1645     return unless $rlist;
1646
1647     warn "$target: with $rlist;" if $self->debug;
1648     $self->_raw_stmt($target, "\nwith $rlist;");
1649 }
1650
1651 sub _result_namespace {
1652     my ($self, $schema_class, $ns) = @_;
1653     my @result_namespace;
1654
1655     if ($ns =~ /^\+(.*)/) {
1656         # Fully qualified namespace
1657         @result_namespace = ($1)
1658     }
1659     else {
1660         # Relative namespace
1661         @result_namespace = ($schema_class, $ns);
1662     }
1663
1664     return wantarray ? @result_namespace : join '::', @result_namespace;
1665 }
1666
1667 # Create class with applicable bases, setup monikers, etc
1668 sub _make_src_class {
1669     my ($self, $table) = @_;
1670
1671     my $schema       = $self->schema;
1672     my $schema_class = $self->schema_class;
1673
1674     my $table_moniker = $self->_table2moniker($table);
1675     my @result_namespace = ($schema_class);
1676     if ($self->use_namespaces) {
1677         my $result_namespace = $self->result_namespace || 'Result';
1678         @result_namespace = $self->_result_namespace(
1679             $schema_class,
1680             $result_namespace,
1681         );
1682     }
1683     my $table_class = join(q{::}, @result_namespace, $table_moniker);
1684
1685     if ((my $upgrading_v = $self->_upgrading_from)
1686             || $self->_rewriting) {
1687         local $self->naming->{monikers} = $upgrading_v
1688             if $upgrading_v;
1689
1690         my @result_namespace = @result_namespace;
1691         if ($self->_upgrading_from_load_classes) {
1692             @result_namespace = ($schema_class);
1693         }
1694         elsif (my $ns = $self->_downgrading_to_load_classes) {
1695             @result_namespace = $self->_result_namespace(
1696                 $schema_class,
1697                 $ns,
1698             );
1699         }
1700         elsif ($ns = $self->_rewriting_result_namespace) {
1701             @result_namespace = $self->_result_namespace(
1702                 $schema_class,
1703                 $ns,
1704             );
1705         }
1706
1707         my $old_class = join(q{::}, @result_namespace,
1708             $self->_table2moniker($table));
1709
1710         $self->_upgrading_classes->{$table_class} = $old_class
1711             unless $table_class eq $old_class;
1712     }
1713
1714     $self->classes->{$table}  = $table_class;
1715     $self->monikers->{$table} = $table_moniker;
1716     $self->tables->{$table_moniker} = $table;
1717     $self->class_to_table->{$table_class} = $table;
1718
1719     $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
1720
1721     $self->_use   ($table_class, @{$self->additional_classes});
1722
1723     $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
1724
1725     $self->_inject($table_class, @{$self->left_base_classes});
1726
1727     my @components = @{ $self->components || [] };
1728
1729     push @components, @{ $self->result_components_map->{$table_moniker} }
1730         if exists $self->result_components_map->{$table_moniker};
1731
1732     my @fq_components = @components;
1733     foreach my $component (@fq_components) {
1734         if ($component !~ s/^\+//) {
1735             $component = "DBIx::Class::$component";
1736         }
1737     }
1738
1739     $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
1740
1741     $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
1742
1743     $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
1744
1745     $self->_inject($table_class, @{$self->additional_base_classes});
1746 }
1747
1748 sub _is_result_class_method {
1749     my ($self, $name, $table_name) = @_;
1750
1751     my $table_moniker = $table_name ? $self->monikers->{$table_name} : '';
1752
1753     $self->_result_class_methods({})
1754         if not defined $self->_result_class_methods;
1755
1756     if (not exists $self->_result_class_methods->{$table_moniker}) {
1757         my (@methods, %methods);
1758         my $base       = $self->result_base_class || 'DBIx::Class::Core';
1759
1760         my @components = @{ $self->components || [] };
1761
1762         push @components, @{ $self->result_components_map->{$table_moniker} }
1763             if exists $self->result_components_map->{$table_moniker};
1764
1765         for my $c (@components) {
1766             $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
1767         }
1768
1769         my @roles = @{ $self->result_roles || [] };
1770
1771         push @roles, @{ $self->result_roles_map->{$table_moniker} }
1772             if exists $self->result_roles_map->{$table_moniker};
1773
1774         for my $class ($base, @components,
1775                        ($self->use_moose ? 'Moose::Object' : ()), @roles) {
1776             $self->ensure_class_loaded($class);
1777
1778             push @methods, @{ Class::Inspector->methods($class) || [] };
1779         }
1780
1781         push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1782
1783         @methods{@methods} = ();
1784
1785         $self->_result_class_methods->{$table_moniker} = \%methods;
1786     }
1787     my $result_methods = $self->_result_class_methods->{$table_moniker};
1788
1789     return exists $result_methods->{$name};
1790 }
1791
1792 sub _resolve_col_accessor_collisions {
1793     my ($self, $table, $col_info) = @_;
1794
1795     my $table_name = ref $table ? $$table : $table;
1796
1797     while (my ($col, $info) = each %$col_info) {
1798         my $accessor = $info->{accessor} || $col;
1799
1800         next if $accessor eq 'id'; # special case (very common column)
1801
1802         if ($self->_is_result_class_method($accessor, $table_name)) {
1803             my $mapped = 0;
1804
1805             if (my $map = $self->col_collision_map) {
1806                 for my $re (keys %$map) {
1807                     if (my @matches = $col =~ /$re/) {
1808                         $info->{accessor} = sprintf $map->{$re}, @matches;
1809                         $mapped = 1;
1810                     }
1811                 }
1812             }
1813
1814             if (not $mapped) {
1815                 warn <<"EOF";
1816 Column '$col' in table '$table_name' collides with an inherited method.
1817 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1818 EOF
1819                 $info->{accessor} = undef;
1820             }
1821         }
1822     }
1823 }
1824
1825 # use the same logic to run moniker_map, col_accessor_map, and
1826 # relationship_name_map
1827 sub _run_user_map {
1828     my ( $self, $map, $default_code, $ident, @extra ) = @_;
1829
1830     my $default_ident = $default_code->( $ident, @extra );
1831     my $new_ident;
1832     if( $map && ref $map eq 'HASH' ) {
1833         $new_ident = $map->{ $ident };
1834     }
1835     elsif( $map && ref $map eq 'CODE' ) {
1836         $new_ident = $map->( $ident, $default_ident, @extra );
1837     }
1838
1839     $new_ident ||= $default_ident;
1840
1841     return $new_ident;
1842 }
1843
1844 sub _default_column_accessor_name {
1845     my ( $self, $column_name ) = @_;
1846
1847     my $accessor_name = $column_name;
1848     $accessor_name =~ s/\W+/_/g;
1849
1850     if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
1851         # older naming just lc'd the col accessor and that's all.
1852         return lc $accessor_name;
1853     }
1854     elsif (($self->naming->{column_accessors}||'') eq 'preserve') {
1855         return $accessor_name;
1856     }
1857
1858     return join '_', map lc, split_name $column_name;
1859 }
1860
1861 sub _make_column_accessor_name {
1862     my ($self, $column_name, $column_context_info ) = @_;
1863
1864     my $accessor = $self->_run_user_map(
1865         $self->col_accessor_map,
1866         sub { $self->_default_column_accessor_name( shift ) },
1867         $column_name,
1868         $column_context_info,
1869        );
1870
1871     return $accessor;
1872 }
1873
1874 sub _quote {
1875     my ($self, $identifier) = @_;
1876
1877     my $qt = $self->schema->storage->sql_maker->quote_char || '';
1878
1879     if (ref $qt) {
1880         return $qt->[0] . $identifier . $qt->[1];
1881     }
1882
1883     return "${qt}${identifier}${qt}";
1884 }
1885
1886 # Set up metadata (cols, pks, etc)
1887 sub _setup_src_meta {
1888     my ($self, $table) = @_;
1889
1890     my $schema       = $self->schema;
1891     my $schema_class = $self->schema_class;
1892
1893     my $table_class   = $self->classes->{$table};
1894     my $table_moniker = $self->monikers->{$table};
1895
1896     my $table_name = $table;
1897
1898     my $sql_maker  = $self->schema->storage->sql_maker;
1899     my $name_sep   = $sql_maker->name_sep;
1900
1901     if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1902         $table_name = \ $self->_quote($table_name);
1903     }
1904
1905     my $full_table_name = ($self->qualify_objects ?
1906         ($self->_quote($self->db_schema) . '.') : '')
1907         . (ref $table_name ? $$table_name : $table_name);
1908
1909     # be careful to not create refs Data::Dump can "optimize"
1910     $full_table_name = \do {"".$full_table_name} if ref $table_name;
1911
1912     $self->_raw_stmt($table_class, ''); # add a blank line
1913
1914     $self->_dbic_stmt($table_class, 'table', $full_table_name);
1915
1916     my $cols     = $self->_table_columns($table);
1917     my $col_info = $self->__columns_info_for($table);
1918
1919     ### generate all the column accessor names
1920     while (my ($col, $info) = each %$col_info) {
1921         # hashref of other info that could be used by
1922         # user-defined accessor map functions
1923         my $context = {
1924             table_class     => $table_class,
1925             table_moniker   => $table_moniker,
1926             table_name      => $table_name,
1927             full_table_name => $full_table_name,
1928             schema_class    => $schema_class,
1929             column_info     => $info,
1930         };
1931
1932         $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
1933     }
1934
1935     $self->_resolve_col_accessor_collisions($table, $col_info);
1936
1937     # prune any redundant accessor names
1938     while (my ($col, $info) = each %$col_info) {
1939         no warnings 'uninitialized';
1940         delete $info->{accessor} if $info->{accessor} eq $col;
1941     }
1942
1943     my $fks = $self->_table_fk_info($table);
1944
1945     foreach my $fkdef (@$fks) {
1946         for my $col (@{ $fkdef->{local_columns} }) {
1947             $col_info->{$col}{is_foreign_key} = 1;
1948         }
1949     }
1950
1951     my $pks = $self->_table_pk_info($table) || [];
1952
1953     foreach my $pkcol (@$pks) {
1954         $col_info->{$pkcol}{is_nullable} = 0;
1955     }
1956
1957     $self->_dbic_stmt(
1958         $table_class,
1959         'add_columns',
1960         map { $_, ($col_info->{$_}||{}) } @$cols
1961     );
1962
1963     my %uniq_tag; # used to eliminate duplicate uniqs
1964
1965     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1966           : carp("$table has no primary key");
1967     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1968
1969     my $uniqs = $self->_table_uniq_info($table) || [];
1970     for (@$uniqs) {
1971         my ($name, $cols) = @$_;
1972         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1973         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1974     }
1975
1976 }
1977
1978 sub __columns_info_for {
1979     my ($self, $table) = @_;
1980
1981     my $result = $self->_columns_info_for($table);
1982
1983     while (my ($col, $info) = each %$result) {
1984         $info = { %$info, %{ $self->_custom_column_info  ($table, $col, $info) } };
1985         $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1986
1987         $result->{$col} = $info;
1988     }
1989
1990     return $result;
1991 }
1992
1993 =head2 tables
1994
1995 Returns a sorted list of loaded tables, using the original database table
1996 names.
1997
1998 =cut
1999
2000 sub tables {
2001     my $self = shift;
2002
2003     return keys %{$self->_tables};
2004 }
2005
2006 # Make a moniker from a table
2007 sub _default_table2moniker {
2008     no warnings 'uninitialized';
2009     my ($self, $table) = @_;
2010
2011     if ($self->naming->{monikers} eq 'v4') {
2012         return join '', map ucfirst, split /[\W_]+/, lc $table;
2013     }
2014     elsif ($self->naming->{monikers} eq 'v5') {
2015         return join '', map ucfirst, split /[\W_]+/,
2016             Lingua::EN::Inflect::Number::to_S(lc $table);
2017     }
2018     elsif ($self->naming->{monikers} eq 'v6') {
2019         (my $as_phrase = lc $table) =~ s/_+/ /g;
2020         my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2021
2022         return join '', map ucfirst, split /\W+/, $inflected;
2023     }
2024
2025     my @words = map lc, split_name $table;
2026     my $as_phrase = join ' ', @words;
2027
2028     my $inflected = $self->naming->{monikers} eq 'plural' ?
2029         Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2030         :
2031         $self->naming->{monikers} eq 'preserve' ?
2032             $as_phrase
2033             :
2034             Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2035
2036     return join '', map ucfirst, split /\W+/, $inflected;
2037 }
2038
2039 sub _table2moniker {
2040     my ( $self, $table ) = @_;
2041
2042     $self->_run_user_map(
2043         $self->moniker_map,
2044         sub { $self->_default_table2moniker( shift ) },
2045         $table
2046        );
2047 }
2048
2049 sub _load_relationships {
2050     my ($self, $tables) = @_;
2051
2052     my @tables;
2053
2054     foreach my $table (@$tables) {
2055         my $tbl_fk_info = $self->_table_fk_info($table);
2056         foreach my $fkdef (@$tbl_fk_info) {
2057             $fkdef->{remote_source} =
2058                 $self->monikers->{delete $fkdef->{remote_table}};
2059         }
2060         my $tbl_uniq_info = $self->_table_uniq_info($table);
2061
2062         my $local_moniker = $self->monikers->{$table};
2063
2064         push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2065     }
2066
2067     my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2068
2069     foreach my $src_class (sort keys %$rel_stmts) {
2070         my $src_stmts = $rel_stmts->{$src_class};
2071         foreach my $stmt (@$src_stmts) {
2072             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
2073         }
2074     }
2075 }
2076
2077 sub _load_roles {
2078     my ($self, $table) = @_;
2079
2080     my $table_moniker = $self->monikers->{$table};
2081     my $table_class   = $self->classes->{$table};
2082
2083     my @roles = @{ $self->result_roles || [] };
2084     push @roles, @{ $self->result_roles_map->{$table_moniker} }
2085         if exists $self->result_roles_map->{$table_moniker};
2086
2087     if (@roles) {
2088         $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2089
2090         $self->_with($table_class, @roles);
2091     }
2092 }
2093
2094 # Overload these in driver class:
2095
2096 # Returns an arrayref of column names
2097 sub _table_columns { croak "ABSTRACT METHOD" }
2098
2099 # Returns arrayref of pk col names
2100 sub _table_pk_info { croak "ABSTRACT METHOD" }
2101
2102 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2103 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2104
2105 # Returns an arrayref of foreign key constraints, each
2106 #   being a hashref with 3 keys:
2107 #   local_columns (arrayref), remote_columns (arrayref), remote_table
2108 sub _table_fk_info { croak "ABSTRACT METHOD" }
2109
2110 # Returns an array of lower case table names
2111 sub _tables_list { croak "ABSTRACT METHOD" }
2112
2113 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2114 sub _dbic_stmt {
2115     my $self   = shift;
2116     my $class  = shift;
2117     my $method = shift;
2118
2119     # generate the pod for this statement, storing it with $self->_pod
2120     $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2121
2122     my $args = dump(@_);
2123     $args = '(' . $args . ')' if @_ < 2;
2124     my $stmt = $method . $args . q{;};
2125
2126     warn qq|$class\->$stmt\n| if $self->debug;
2127     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2128     return;
2129 }
2130
2131 sub _make_pod_heading {
2132     my ($self, $class) = @_;
2133
2134     return '' if not $self->generate_pod;
2135
2136     my $table = $self->class_to_table->{$class};
2137     my $pod;
2138
2139     my $pcm = $self->pod_comment_mode;
2140     my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2141     $comment = $self->__table_comment($table);
2142     $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2143     $comment_in_name   = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2144     $comment_in_desc   = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2145
2146     $pod .= "=head1 NAME\n\n";
2147
2148     my $table_descr = $class;
2149     $table_descr .= " - " . $comment if $comment and $comment_in_name;
2150
2151     $pod .= "$table_descr\n\n";
2152
2153     if ($comment and $comment_in_desc) {
2154         $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2155     }
2156     $pod .= "=cut\n\n";
2157
2158     return $pod;
2159 }
2160
2161 # generates the accompanying pod for a DBIC class method statement,
2162 # storing it with $self->_pod
2163 sub _make_pod {
2164     my $self   = shift;
2165     my $class  = shift;
2166     my $method = shift;
2167
2168     if ( $method eq 'add_columns' ) {
2169         $self->_pod( $class, "=head1 ACCESSORS" );
2170         my $col_counter = 0;
2171         my @cols = @_;
2172         while( my ($name,$attrs) = splice @cols,0,2 ) {
2173             $col_counter++;
2174             $self->_pod( $class, '=head2 ' . $name  );
2175             $self->_pod( $class,
2176                 join "\n", map {
2177                     my $s = $attrs->{$_};
2178                     $s = !defined $s          ? 'undef'             :
2179                         length($s) == 0       ? '(empty string)'    :
2180                         ref($s) eq 'SCALAR'   ? $$s                 :
2181                         ref($s)               ? dumper_squashed $s  :
2182                         looks_like_number($s) ? $s                  : qq{'$s'};
2183
2184                     "  $_: $s"
2185                  } sort keys %$attrs,
2186             );
2187             if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2188                 $self->_pod( $class, $comment );
2189             }
2190         }
2191         $self->_pod_cut( $class );
2192     } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2193         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2194         my ( $accessor, $rel_class ) = @_;
2195         $self->_pod( $class, "=head2 $accessor" );
2196         $self->_pod( $class, 'Type: ' . $method );
2197         $self->_pod( $class, "Related object: L<$rel_class>" );
2198         $self->_pod_cut( $class );
2199         $self->{_relations_started} { $class } = 1;
2200     }
2201 }
2202
2203 sub _pod_class_list {
2204     my ($self, $class, $title, @classes) = @_;
2205
2206     return unless @classes && $self->generate_pod;
2207
2208     $self->_pod($class, "=head1 $title");
2209     $self->_pod($class, '=over 4');
2210
2211     foreach my $link (@classes) {
2212         $self->_pod($class, "=item * L<$link>");
2213     }
2214
2215     $self->_pod($class, '=back');
2216     $self->_pod_cut($class);
2217 }
2218
2219 sub _base_class_pod {
2220     my ($self, $base_class) = @_;
2221
2222     return unless $self->generate_pod;
2223
2224     return <<"EOF"
2225 =head1 BASE CLASS: L<$base_class>
2226
2227 =cut
2228
2229 EOF
2230 }
2231
2232 sub _filter_comment {
2233     my ($self, $txt) = @_;
2234
2235     $txt = '' if not defined $txt;
2236
2237     $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2238
2239     return $txt;
2240 }
2241
2242 sub __table_comment {
2243     my $self = shift;
2244
2245     if (my $code = $self->can('_table_comment')) {
2246         return $self->_filter_comment($self->$code(@_));
2247     }
2248
2249     return '';
2250 }
2251
2252 sub __column_comment {
2253     my $self = shift;
2254
2255     if (my $code = $self->can('_column_comment')) {
2256         return $self->_filter_comment($self->$code(@_));
2257     }
2258
2259     return '';
2260 }
2261
2262 # Stores a POD documentation
2263 sub _pod {
2264     my ($self, $class, $stmt) = @_;
2265     $self->_raw_stmt( $class, "\n" . $stmt  );
2266 }
2267
2268 sub _pod_cut {
2269     my ($self, $class ) = @_;
2270     $self->_raw_stmt( $class, "\n=cut\n" );
2271 }
2272
2273 # Store a raw source line for a class (for dumping purposes)
2274 sub _raw_stmt {
2275     my ($self, $class, $stmt) = @_;
2276     push(@{$self->{_dump_storage}->{$class}}, $stmt);
2277 }
2278
2279 # Like above, but separately for the externally loaded stuff
2280 sub _ext_stmt {
2281     my ($self, $class, $stmt) = @_;
2282     push(@{$self->{_ext_storage}->{$class}}, $stmt);
2283 }
2284
2285 sub _custom_column_info {
2286     my ( $self, $table_name, $column_name, $column_info ) = @_;
2287
2288     if (my $code = $self->custom_column_info) {
2289         return $code->($table_name, $column_name, $column_info) || {};
2290     }
2291     return {};
2292 }
2293
2294 sub _datetime_column_info {
2295     my ( $self, $table_name, $column_name, $column_info ) = @_;
2296     my $result = {};
2297     my $type = $column_info->{data_type} || '';
2298     if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2299             or ($type =~ /date|timestamp/i)) {
2300         $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2301         $result->{locale}   = $self->datetime_locale   if $self->datetime_locale;
2302     }
2303     return $result;
2304 }
2305
2306 sub _lc {
2307     my ($self, $name) = @_;
2308
2309     return $self->preserve_case ? $name : lc($name);
2310 }
2311
2312 sub _uc {
2313     my ($self, $name) = @_;
2314
2315     return $self->preserve_case ? $name : uc($name);
2316 }
2317
2318 sub _unregister_source_for_table {
2319     my ($self, $table) = @_;
2320
2321     try {
2322         local $@;
2323         my $schema = $self->schema;
2324         # in older DBIC it's a private method
2325         my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2326         $schema->$unregister($self->_table2moniker($table));
2327         delete $self->monikers->{$table};
2328         delete $self->classes->{$table};
2329         delete $self->_upgrading_classes->{$table};
2330         delete $self->{_tables}{$table};
2331     };
2332 }
2333
2334 # remove the dump dir from @INC on destruction
2335 sub DESTROY {
2336     my $self = shift;
2337
2338     @INC = grep $_ ne $self->dump_directory, @INC;
2339 }
2340
2341 =head2 monikers
2342
2343 Returns a hashref of loaded table to moniker mappings.  There will
2344 be two entries for each table, the original name and the "normalized"
2345 name, in the case that the two are different (such as databases
2346 that like uppercase table names, or preserve your original mixed-case
2347 definitions, or what-have-you).
2348
2349 =head2 classes
2350
2351 Returns a hashref of table to class mappings.  In some cases it will
2352 contain multiple entries per table for the original and normalized table
2353 names, as above in L</monikers>.
2354
2355 =head1 COLUMN ACCESSOR COLLISIONS
2356
2357 Occasionally you may have a column name that collides with a perl method, such
2358 as C<can>. In such cases, the default action is to set the C<accessor> of the
2359 column spec to C<undef>.
2360
2361 You can then name the accessor yourself by placing code such as the following
2362 below the md5:
2363
2364     __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2365
2366 Another option is to use the L</col_collision_map> option.
2367
2368 =head1 RELATIONSHIP NAME COLLISIONS
2369
2370 In very rare cases, you may get a collision between a generated relationship
2371 name and a method in your Result class, for example if you have a foreign key
2372 called C<belongs_to>.
2373
2374 This is a problem because relationship names are also relationship accessor
2375 methods in L<DBIx::Class>.
2376
2377 The default behavior is to append C<_rel> to the relationship name and print
2378 out a warning that refers to this text.
2379
2380 You can also control the renaming with the L</rel_collision_map> option.
2381
2382 =head1 SEE ALSO
2383
2384 L<DBIx::Class::Schema::Loader>
2385
2386 =head1 AUTHOR
2387
2388 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2389
2390 =head1 LICENSE
2391
2392 This library is free software; you can redistribute it and/or modify it under
2393 the same terms as Perl itself.
2394
2395 =cut
2396
2397 1;
2398 # vim:et sts=4 sw=4 tw=0: