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