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