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