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.07015';
  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 $table (values %{ $self->_tables }) {
1487         push @{ $inverse_moniker_idx->{$self->monikers->{$table->sql_name}} }, $table;
1488     }
1489
1490     my @clashes;
1491     foreach my $moniker (keys %$inverse_moniker_idx) {
1492         my $tables = $inverse_moniker_idx->{$moniker};
1493         if (@$tables > 1) {
1494             my $different_databases =
1495                 $tables->[0]->can('database') && (uniq map $_->database||'', @$tables) > 1;
1496
1497             my $different_schemas =
1498                 (uniq map $_->schema||'', @$tables) > 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, @$tables;
1510                     $use_schema = any { $_ > 1 } values %db_counts;
1511                 }
1512
1513                 delete $self->monikers->{$_->sql_name} for @$tables;
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                 $new_monikers{$_->sql_name} = $self->_table2moniker($_) for @$tables;
1528
1529                 $self->monikers->{$_} = $new_monikers{$_} for map $_->sql_name, @$tables;
1530
1531                 # check if there are still clashes
1532                 my %by_moniker;
1533
1534                 while (my ($t, $m) = each %new_monikers) {
1535                     push @{ $by_moniker{$m} }, $t;
1536                 }
1537
1538                 foreach my $m (grep @{ $by_moniker{$_} } > 1, keys %by_moniker) {
1539                     push @clashes, sprintf ("tried disambiguating by moniker_parts, but tables %s still reduced to the same source moniker '%s'",
1540                         join (', ', @{ $by_moniker{$m} }),
1541                         $m,
1542                     );
1543                 }
1544             }
1545             else {
1546                 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1547                     join (', ', map $_->sql_name, @$tables),
1548                     $moniker,
1549                 );
1550             }
1551         }
1552     }
1553
1554     if (@clashes) {
1555         die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1556         . 'Change the naming style, or supply an explicit moniker_map: '
1557         . join ('; ', @clashes)
1558         . "\n"
1559         ;
1560     }
1561
1562     $self->_make_src_class($_) for @tables;
1563
1564     $self->_setup_src_meta($_) for @tables;
1565
1566     if(!$self->skip_relationships) {
1567         # The relationship loader needs a working schema
1568         local $self->{quiet} = 1;
1569         local $self->{dump_directory} = $self->{temp_directory};
1570         $self->_reload_classes(\@tables);
1571         $self->_load_relationships(\@tables);
1572
1573         # Remove that temp dir from INC so it doesn't get reloaded
1574         @INC = grep $_ ne $self->dump_directory, @INC;
1575     }
1576
1577     $self->_load_roles($_) for @tables;
1578
1579     $self->_load_external($_)
1580         for map { $self->classes->{$_->sql_name} } @tables;
1581
1582     # Reload without unloading first to preserve any symbols from external
1583     # packages.
1584     $self->_reload_classes(\@tables, { unload => 0 });
1585
1586     # Drop temporary cache
1587     delete $self->{_cache};
1588
1589     return \@tables;
1590 }
1591
1592 sub _reload_classes {
1593     my ($self, $tables, $opts) = @_;
1594
1595     my @tables = @$tables;
1596
1597     my $unload = $opts->{unload};
1598     $unload = 1 unless defined $unload;
1599
1600     # so that we don't repeat custom sections
1601     @INC = grep $_ ne $self->dump_directory, @INC;
1602
1603     $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables);
1604
1605     unshift @INC, $self->dump_directory;
1606
1607     my @to_register;
1608     my %have_source = map { $_ => $self->schema->source($_) }
1609         $self->schema->sources;
1610
1611     for my $table (@tables) {
1612         my $moniker = $self->monikers->{$table->sql_name};
1613         my $class = $self->classes->{$table->sql_name};
1614
1615         {
1616             no warnings 'redefine';
1617             local *Class::C3::reinitialize = sub {};  # to speed things up, reinitialized below
1618             use warnings;
1619
1620             if (my $mc = $self->_moose_metaclass($class)) {
1621                 $mc->make_mutable;
1622             }
1623             Class::Unload->unload($class) if $unload;
1624             my ($source, $resultset_class);
1625             if (
1626                 ($source = $have_source{$moniker})
1627                 && ($resultset_class = $source->resultset_class)
1628                 && ($resultset_class ne 'DBIx::Class::ResultSet')
1629             ) {
1630                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1631                 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1632                     $mc->make_mutable;
1633                 }
1634                 Class::Unload->unload($resultset_class) if $unload;
1635                 $self->_reload_class($resultset_class) if $has_file;
1636             }
1637             $self->_reload_class($class);
1638         }
1639         push @to_register, [$moniker, $class];
1640     }
1641
1642     Class::C3->reinitialize;
1643     for (@to_register) {
1644         $self->schema->register_class(@$_);
1645     }
1646 }
1647
1648 sub _moose_metaclass {
1649   return undef unless $INC{'Class/MOP.pm'};   # if CMOP is not loaded the class could not have loaded in the 1st place
1650
1651   my $class = $_[1];
1652
1653   my $mc = try { Class::MOP::class_of($class) }
1654     or return undef;
1655
1656   return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1657 }
1658
1659 # We use this instead of ensure_class_loaded when there are package symbols we
1660 # want to preserve.
1661 sub _reload_class {
1662     my ($self, $class) = @_;
1663
1664     delete $INC{ +class_path($class) };
1665
1666     try {
1667         eval_package_without_redefine_warnings ($class, "require $class");
1668     }
1669     catch {
1670         my $source = slurp_file $self->_get_dump_filename($class);
1671         die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1672     };
1673 }
1674
1675 sub _get_dump_filename {
1676     my ($self, $class) = (@_);
1677
1678     $class =~ s{::}{/}g;
1679     return $self->dump_directory . q{/} . $class . q{.pm};
1680 }
1681
1682 =head2 get_dump_filename
1683
1684 Arguments: class
1685
1686 Returns the full path to the file for a class that the class has been or will
1687 be dumped to. This is a file in a temp dir for a dynamic schema.
1688
1689 =cut
1690
1691 sub get_dump_filename {
1692     my ($self, $class) = (@_);
1693
1694     local $self->{dump_directory} = $self->real_dump_directory;
1695
1696     return $self->_get_dump_filename($class);
1697 }
1698
1699 sub _ensure_dump_subdirs {
1700     my ($self, $class) = (@_);
1701
1702     my @name_parts = split(/::/, $class);
1703     pop @name_parts; # we don't care about the very last element,
1704                      # which is a filename
1705
1706     my $dir = $self->dump_directory;
1707     while (1) {
1708         if(!-d $dir) {
1709             mkdir($dir) or croak "mkdir('$dir') failed: $!";
1710         }
1711         last if !@name_parts;
1712         $dir = File::Spec->catdir($dir, shift @name_parts);
1713     }
1714 }
1715
1716 sub _dump_to_dir {
1717     my ($self, @classes) = @_;
1718
1719     my $schema_class = $self->schema_class;
1720     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1721
1722     my $target_dir = $self->dump_directory;
1723     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1724         unless $self->dynamic or $self->quiet;
1725
1726     my $schema_text =
1727           qq|use utf8;\n|
1728         . qq|package $schema_class;\n\n|
1729         . qq|# Created by DBIx::Class::Schema::Loader\n|
1730         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1731
1732     my $autoclean
1733         = $self->only_autoclean
1734         ? 'namespace::autoclean'
1735         : 'MooseX::MarkAsMethods autoclean => 1'
1736         ;
1737
1738     if ($self->use_moose) {
1739
1740         $schema_text.= qq|use Moose;\nuse $autoclean;\nextends '$schema_base_class';\n\n|;
1741     }
1742     else {
1743         $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1744     }
1745
1746     my @schema_components = @{ $self->schema_components || [] };
1747
1748     if (@schema_components) {
1749         my $schema_components = dump @schema_components;
1750         $schema_components = "($schema_components)" if @schema_components == 1;
1751
1752         $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1753     }
1754
1755     if ($self->use_namespaces) {
1756         $schema_text .= qq|__PACKAGE__->load_namespaces|;
1757         my $namespace_options;
1758
1759         my @attr = qw/resultset_namespace default_resultset_class/;
1760
1761         unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1762
1763         for my $attr (@attr) {
1764             if ($self->$attr) {
1765                 my $code = dumper_squashed $self->$attr;
1766                 $namespace_options .= qq|    $attr => $code,\n|
1767             }
1768         }
1769         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1770         $schema_text .= qq|;\n|;
1771     }
1772     else {
1773         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1774     }
1775
1776     {
1777         local $self->{version_to_dump} = $self->schema_version_to_dump;
1778         $self->_write_classfile($schema_class, $schema_text, 1);
1779     }
1780
1781     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1782
1783     foreach my $src_class (@classes) {
1784         my $src_text =
1785               qq|use utf8;\n|
1786             . qq|package $src_class;\n\n|
1787             . qq|# Created by DBIx::Class::Schema::Loader\n|
1788             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1789
1790         $src_text .= $self->_make_pod_heading($src_class);
1791
1792         $src_text .= qq|use strict;\nuse warnings;\n\n|;
1793
1794         $src_text .= $self->_base_class_pod($result_base_class)
1795             unless $result_base_class eq 'DBIx::Class::Core';
1796
1797         if ($self->use_moose) {
1798             $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse $autoclean;|;
1799
1800             # these options 'use base' which is compile time
1801             if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1802                 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1803             }
1804             else {
1805                 $src_text .= qq|\nextends '$result_base_class';\n|;
1806             }
1807         }
1808         else {
1809              $src_text .= qq|use base '$result_base_class';\n|;
1810         }
1811
1812         $self->_write_classfile($src_class, $src_text);
1813     }
1814
1815     # remove Result dir if downgrading from use_namespaces, and there are no
1816     # files left.
1817     if (my $result_ns = $self->_downgrading_to_load_classes
1818                         || $self->_rewriting_result_namespace) {
1819         my $result_namespace = $self->_result_namespace(
1820             $schema_class,
1821             $result_ns,
1822         );
1823
1824         (my $result_dir = $result_namespace) =~ s{::}{/}g;
1825         $result_dir = $self->dump_directory . '/' . $result_dir;
1826
1827         unless (my @files = glob "$result_dir/*") {
1828             rmdir $result_dir;
1829         }
1830     }
1831
1832     warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
1833 }
1834
1835 sub _sig_comment {
1836     my ($self, $version, $ts) = @_;
1837     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1838          . qq| v| . $version
1839          . q| @ | . $ts
1840          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1841 }
1842
1843 sub _write_classfile {
1844     my ($self, $class, $text, $is_schema) = @_;
1845
1846     my $filename = $self->_get_dump_filename($class);
1847     $self->_ensure_dump_subdirs($class);
1848
1849     if (-f $filename && $self->really_erase_my_files) {
1850         warn "Deleting existing file '$filename' due to "
1851             . "'really_erase_my_files' setting\n" unless $self->quiet;
1852         unlink($filename);
1853     }
1854
1855     my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1856         = $self->_parse_generated_file($filename);
1857
1858     if (! $old_gen && -f $filename) {
1859         croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1860             . " it does not appear to have been generated by Loader"
1861     }
1862
1863     my $custom_content = $old_custom || '';
1864
1865     # Use custom content from a renamed class, the class names in it are
1866     # rewritten below.
1867     if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1868         my $old_filename = $self->_get_dump_filename($renamed_class);
1869
1870         if (-f $old_filename) {
1871             $custom_content = ($self->_parse_generated_file ($old_filename))[4];
1872
1873             unlink $old_filename;
1874         }
1875     }
1876
1877     $custom_content ||= $self->_default_custom_content($is_schema);
1878
1879     # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1880     # If there is already custom content, which does not have the Moose content, add it.
1881     if ($self->use_moose) {
1882
1883         my $non_moose_custom_content = do {
1884             local $self->{use_moose} = 0;
1885             $self->_default_custom_content;
1886         };
1887
1888         if ($custom_content eq $non_moose_custom_content) {
1889             $custom_content = $self->_default_custom_content($is_schema);
1890         }
1891         elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1892             $custom_content .= $self->_default_custom_content($is_schema);
1893         }
1894     }
1895     elsif (defined $self->use_moose && $old_gen) {
1896         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'
1897             if $old_gen =~ /use \s+ MooseX?\b/x;
1898     }
1899
1900     $custom_content = $self->_rewrite_old_classnames($custom_content);
1901
1902     $text .= qq|$_\n|
1903         for @{$self->{_dump_storage}->{$class} || []};
1904
1905     if ($self->filter_generated_code) {
1906         my $filter = $self->filter_generated_code;
1907
1908         if (ref $filter eq 'CODE') {
1909             $text = $filter->(
1910                 ($is_schema ? 'schema' : 'result'),
1911                 $class,
1912                 $text
1913             );
1914         }
1915         else {
1916             my ($fh, $temp_file) = tempfile();
1917
1918             binmode $fh, ':encoding(UTF-8)';
1919             print $fh $text;
1920             close $fh;
1921
1922             open my $out, qq{$filter < "$temp_file"|}
1923                 or croak "Could not open pipe to $filter: $!";
1924
1925             $text = decode('UTF-8', do { local $/; <$out> });
1926
1927             $text =~ s/$CR?$LF/\n/g;
1928
1929             close $out;
1930
1931             my $exit_code = $? >> 8;
1932
1933             unlink $temp_file
1934                 or croak "Could not remove temporary file '$temp_file': $!";
1935
1936             if ($exit_code != 0) {
1937                 croak "filter '$filter' exited non-zero: $exit_code";
1938             }
1939         }
1940         if (not $text or not $text =~ /\bpackage\b/) {
1941             warn("$class skipped due to filter") if $self->debug;
1942             return;
1943         }
1944     }
1945
1946     # Check and see if the dump is in fact different
1947
1948     my $compare_to;
1949     if ($old_md5) {
1950       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1951       if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1952         return unless $self->_upgrading_from && $is_schema;
1953       }
1954     }
1955
1956     $text .= $self->_sig_comment(
1957       $self->version_to_dump,
1958       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1959     );
1960
1961     open(my $fh, '>:encoding(UTF-8)', $filename)
1962         or croak "Cannot open '$filename' for writing: $!";
1963
1964     # Write the top half and its MD5 sum
1965     print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1966
1967     # Write out anything loaded via external partial class file in @INC
1968     print $fh qq|$_\n|
1969         for @{$self->{_ext_storage}->{$class} || []};
1970
1971     # Write out any custom content the user has added
1972     print $fh $custom_content;
1973
1974     close($fh)
1975         or croak "Error closing '$filename': $!";
1976 }
1977
1978 sub _default_moose_custom_content {
1979     my ($self, $is_schema) = @_;
1980
1981     if (not $is_schema) {
1982         return qq|\n__PACKAGE__->meta->make_immutable;|;
1983     }
1984
1985     return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1986 }
1987
1988 sub _default_custom_content {
1989     my ($self, $is_schema) = @_;
1990     my $default = qq|\n\n# You can replace this text with custom|
1991          . qq| code or comments, and it will be preserved on regeneration|;
1992     if ($self->use_moose) {
1993         $default .= $self->_default_moose_custom_content($is_schema);
1994     }
1995     $default .= qq|\n1;\n|;
1996     return $default;
1997 }
1998
1999 sub _parse_generated_file {
2000     my ($self, $fn) = @_;
2001
2002     return unless -f $fn;
2003
2004     open(my $fh, '<:encoding(UTF-8)', $fn)
2005         or croak "Cannot open '$fn' for reading: $!";
2006
2007     my $mark_re =
2008         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
2009
2010     my ($md5, $ts, $ver, $gen);
2011     while(<$fh>) {
2012         if(/$mark_re/) {
2013             my $pre_md5 = $1;
2014             $md5 = $2;
2015
2016             # Pull out the version and timestamp from the line above
2017             ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m;
2018
2019             $gen .= $pre_md5;
2020             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"
2021                 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
2022
2023             last;
2024         }
2025         else {
2026             $gen .= $_;
2027         }
2028     }
2029
2030     my $custom = do { local $/; <$fh> }
2031         if $md5;
2032
2033     $custom ||= '';
2034     $custom =~ s/$CRLF|$LF/\n/g;
2035
2036     close $fh;
2037
2038     return ($gen, $md5, $ver, $ts, $custom);
2039 }
2040
2041 sub _use {
2042     my $self = shift;
2043     my $target = shift;
2044
2045     foreach (@_) {
2046         warn "$target: use $_;" if $self->debug;
2047         $self->_raw_stmt($target, "use $_;");
2048     }
2049 }
2050
2051 sub _inject {
2052     my $self = shift;
2053     my $target = shift;
2054
2055     my $blist = join(q{ }, @_);
2056
2057     return unless $blist;
2058
2059     warn "$target: use base qw/$blist/;" if $self->debug;
2060     $self->_raw_stmt($target, "use base qw/$blist/;");
2061 }
2062
2063 sub _with {
2064     my $self = shift;
2065     my $target = shift;
2066
2067     my $rlist = join(q{, }, map { qq{'$_'} } @_);
2068
2069     return unless $rlist;
2070
2071     warn "$target: with $rlist;" if $self->debug;
2072     $self->_raw_stmt($target, "\nwith $rlist;");
2073 }
2074
2075 sub _result_namespace {
2076     my ($self, $schema_class, $ns) = @_;
2077     my @result_namespace;
2078
2079     $ns = $ns->[0] if ref $ns;
2080
2081     if ($ns =~ /^\+(.*)/) {
2082         # Fully qualified namespace
2083         @result_namespace = ($1)
2084     }
2085     else {
2086         # Relative namespace
2087         @result_namespace = ($schema_class, $ns);
2088     }
2089
2090     return wantarray ? @result_namespace : join '::', @result_namespace;
2091 }
2092
2093 # Create class with applicable bases, setup monikers, etc
2094 sub _make_src_class {
2095     my ($self, $table) = @_;
2096
2097     my $schema       = $self->schema;
2098     my $schema_class = $self->schema_class;
2099
2100     my $table_moniker = $self->monikers->{$table->sql_name};
2101     my @result_namespace = ($schema_class);
2102     if ($self->use_namespaces) {
2103         my $result_namespace = $self->result_namespace || 'Result';
2104         @result_namespace = $self->_result_namespace(
2105             $schema_class,
2106             $result_namespace,
2107         );
2108     }
2109     my $table_class = join(q{::}, @result_namespace, $table_moniker);
2110
2111     if ((my $upgrading_v = $self->_upgrading_from)
2112             || $self->_rewriting) {
2113         local $self->naming->{monikers} = $upgrading_v
2114             if $upgrading_v;
2115
2116         my @result_namespace = @result_namespace;
2117         if ($self->_upgrading_from_load_classes) {
2118             @result_namespace = ($schema_class);
2119         }
2120         elsif (my $ns = $self->_downgrading_to_load_classes) {
2121             @result_namespace = $self->_result_namespace(
2122                 $schema_class,
2123                 $ns,
2124             );
2125         }
2126         elsif ($ns = $self->_rewriting_result_namespace) {
2127             @result_namespace = $self->_result_namespace(
2128                 $schema_class,
2129                 $ns,
2130             );
2131         }
2132
2133         my $old_table_moniker = do {
2134             local $self->naming->{monikers} = $upgrading_v;
2135             $self->_table2moniker($table);
2136         };
2137
2138         my $old_class = join(q{::}, @result_namespace, $old_table_moniker);
2139
2140         $self->_upgrading_classes->{$table_class} = $old_class
2141             unless $table_class eq $old_class;
2142     }
2143
2144     $self->classes->{$table->sql_name}  = $table_class;
2145     $self->moniker_to_table->{$table_moniker} = $table;
2146     $self->class_to_table->{$table_class} = $table;
2147
2148     $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
2149
2150     $self->_use   ($table_class, @{$self->additional_classes});
2151
2152     $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
2153
2154     $self->_inject($table_class, @{$self->left_base_classes});
2155
2156     my @components = @{ $self->components || [] };
2157
2158     push @components, @{ $self->result_components_map->{$table_moniker} }
2159         if exists $self->result_components_map->{$table_moniker};
2160
2161     my @fq_components = @components;
2162     foreach my $component (@fq_components) {
2163         if ($component !~ s/^\+//) {
2164             $component = "DBIx::Class::$component";
2165         }
2166     }
2167
2168     $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
2169
2170     $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
2171
2172     $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
2173
2174     $self->_inject($table_class, @{$self->additional_base_classes});
2175 }
2176
2177 sub _is_result_class_method {
2178     my ($self, $name, $table) = @_;
2179
2180     my $table_moniker = $table ? $self->monikers->{$table->sql_name} : '';
2181
2182     $self->_result_class_methods({})
2183         if not defined $self->_result_class_methods;
2184
2185     if (not exists $self->_result_class_methods->{$table_moniker}) {
2186         my (@methods, %methods);
2187         my $base       = $self->result_base_class || 'DBIx::Class::Core';
2188
2189         my @components = @{ $self->components || [] };
2190
2191         push @components, @{ $self->result_components_map->{$table_moniker} }
2192             if exists $self->result_components_map->{$table_moniker};
2193
2194         for my $c (@components) {
2195             $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
2196         }
2197
2198         my @roles = @{ $self->result_roles || [] };
2199
2200         push @roles, @{ $self->result_roles_map->{$table_moniker} }
2201             if exists $self->result_roles_map->{$table_moniker};
2202
2203         for my $class ($base, @components,
2204                        ($self->use_moose ? 'Moose::Object' : ()), @roles) {
2205             $self->ensure_class_loaded($class);
2206
2207             push @methods, @{ Class::Inspector->methods($class) || [] };
2208         }
2209
2210         push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
2211
2212         @methods{@methods} = ();
2213
2214         $self->_result_class_methods->{$table_moniker} = \%methods;
2215     }
2216     my $result_methods = $self->_result_class_methods->{$table_moniker};
2217
2218     return exists $result_methods->{$name};
2219 }
2220
2221 sub _resolve_col_accessor_collisions {
2222     my ($self, $table, $col_info) = @_;
2223
2224     while (my ($col, $info) = each %$col_info) {
2225         my $accessor = $info->{accessor} || $col;
2226
2227         next if $accessor eq 'id'; # special case (very common column)
2228
2229         if ($self->_is_result_class_method($accessor, $table)) {
2230             my $mapped = 0;
2231
2232             if (my $map = $self->col_collision_map) {
2233                 for my $re (keys %$map) {
2234                     if (my @matches = $col =~ /$re/) {
2235                         $info->{accessor} = sprintf $map->{$re}, @matches;
2236                         $mapped = 1;
2237                     }
2238                 }
2239             }
2240
2241             if (not $mapped) {
2242                 warn <<"EOF";
2243 Column '$col' in table '$table' collides with an inherited method.
2244 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
2245 EOF
2246                 $info->{accessor} = undef;
2247             }
2248         }
2249     }
2250 }
2251
2252 # use the same logic to run moniker_map, col_accessor_map
2253 sub _run_user_map {
2254     my ( $self, $map, $default_code, $ident, @extra ) = @_;
2255
2256     my $default_ident = $default_code->( $ident, @extra );
2257     my $new_ident;
2258     if( $map && ref $map eq 'HASH' ) {
2259         $new_ident = $map->{ $ident };
2260     }
2261     elsif( $map && ref $map eq 'CODE' ) {
2262         $new_ident = $map->( $ident, $default_ident, @extra );
2263     }
2264
2265     $new_ident ||= $default_ident;
2266
2267     return $new_ident;
2268 }
2269
2270 sub _default_column_accessor_name {
2271     my ( $self, $column_name ) = @_;
2272
2273     my $preserve = ($self->naming->{column_accessors}||'') eq 'preserve';
2274
2275     my $v = $self->_get_naming_v('column_accessors');
2276
2277     my $accessor_name = $preserve ?
2278         $self->_to_identifier('column_accessors', $column_name) # assume CamelCase
2279         :
2280         $self->_to_identifier('column_accessors', $column_name, '_');
2281
2282     $accessor_name =~ s/\W+/_/g; # only if naming < v8, otherwise to_identifier
2283                                  # takes care of it
2284
2285     if ($preserve) {
2286         return $accessor_name;
2287     }
2288     elsif ($v < 7 || (not $self->preserve_case)) {
2289         # older naming just lc'd the col accessor and that's all.
2290         return lc $accessor_name;
2291     }
2292
2293     return join '_', map lc, split_name $column_name, $v;
2294 }
2295
2296 sub _make_column_accessor_name {
2297     my ($self, $column_name, $column_context_info ) = @_;
2298
2299     my $accessor = $self->_run_user_map(
2300         $self->col_accessor_map,
2301         sub { $self->_default_column_accessor_name( shift ) },
2302         $column_name,
2303         $column_context_info,
2304        );
2305
2306     return $accessor;
2307 }
2308
2309 # Set up metadata (cols, pks, etc)
2310 sub _setup_src_meta {
2311     my ($self, $table) = @_;
2312
2313     my $schema       = $self->schema;
2314     my $schema_class = $self->schema_class;
2315
2316     my $table_class   = $self->classes->{$table->sql_name};
2317     my $table_moniker = $self->monikers->{$table->sql_name};
2318
2319     $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
2320
2321     my $cols     = $self->_table_columns($table);
2322     my $col_info = $self->__columns_info_for($table);
2323
2324     ### generate all the column accessor names
2325     while (my ($col, $info) = each %$col_info) {
2326         # hashref of other info that could be used by
2327         # user-defined accessor map functions
2328         my $context = {
2329             table_class     => $table_class,
2330             table_moniker   => $table_moniker,
2331             table_name      => $table,
2332             full_table_name => $table->dbic_name,
2333             schema_class    => $schema_class,
2334             column_info     => $info,
2335         };
2336
2337         $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2338     }
2339
2340     $self->_resolve_col_accessor_collisions($table, $col_info);
2341
2342     # prune any redundant accessor names
2343     while (my ($col, $info) = each %$col_info) {
2344         no warnings 'uninitialized';
2345         delete $info->{accessor} if $info->{accessor} eq $col;
2346     }
2347
2348     my $fks = $self->_table_fk_info($table);
2349
2350     foreach my $fkdef (@$fks) {
2351         for my $col (@{ $fkdef->{local_columns} }) {
2352             $col_info->{$col}{is_foreign_key} = 1;
2353         }
2354     }
2355
2356     my $pks = $self->_table_pk_info($table) || [];
2357
2358     my %uniq_tag; # used to eliminate duplicate uniqs
2359
2360     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2361
2362     my $uniqs = $self->_table_uniq_info($table) || [];
2363     my @uniqs;
2364
2365     foreach my $uniq (@$uniqs) {
2366         my ($name, $cols) = @$uniq;
2367         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2368         push @uniqs, [$name, $cols];
2369     }
2370
2371     my @non_nullable_uniqs = grep {
2372         all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2373     } @uniqs;
2374
2375     if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2376         my @by_colnum = sort { $b->[0] <=> $a->[0] }
2377             map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2378
2379         if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2380             my @keys = map $_->[1], @by_colnum;
2381
2382             my $pk = $keys[0];
2383
2384             # remove the uniq from list
2385             @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2386
2387             $pks = $pk->[1];
2388         }
2389     }
2390
2391     foreach my $pkcol (@$pks) {
2392         $col_info->{$pkcol}{is_nullable} = 0;
2393     }
2394
2395     $self->_dbic_stmt(
2396         $table_class,
2397         'add_columns',
2398         map { $_, ($col_info->{$_}||{}) } @$cols
2399     );
2400
2401     $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2402         if @$pks;
2403
2404     # Sort unique constraints by constraint name for repeatable results (rels
2405     # are sorted as well elsewhere.)
2406     @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs;
2407
2408     foreach my $uniq (@uniqs) {
2409         my ($name, $cols) = @$uniq;
2410         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2411     }
2412 }
2413
2414 sub __columns_info_for {
2415     my ($self, $table) = @_;
2416
2417     my $result = $self->_columns_info_for($table);
2418
2419     while (my ($col, $info) = each %$result) {
2420         $info = { %$info, %{ $self->_custom_column_info  ($table, $col, $info) } };
2421         $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2422
2423         $result->{$col} = $info;
2424     }
2425
2426     return $result;
2427 }
2428
2429 =head2 tables
2430
2431 Returns a sorted list of loaded tables, using the original database table
2432 names.
2433
2434 =cut
2435
2436 sub tables {
2437     my $self = shift;
2438
2439     return values %{$self->_tables};
2440 }
2441
2442 sub _get_naming_v {
2443     my ($self, $naming_key) = @_;
2444
2445     my $v;
2446
2447     if (($self->naming->{$naming_key}||'') =~ /^v(\d+)\z/) {
2448         $v = $1;
2449     }
2450     else {
2451         ($v) = $CURRENT_V =~ /^v(\d+)\z/;
2452     }
2453
2454     return $v;
2455 }
2456
2457 sub _to_identifier {
2458     my ($self, $naming_key, $name, $sep_char, $force) = @_;
2459
2460     my $v = $self->_get_naming_v($naming_key);
2461
2462     my $to_identifier = $self->naming->{force_ascii} ?
2463         \&String::ToIdentifier::EN::to_identifier
2464         : \&String::ToIdentifier::EN::Unicode::to_identifier;
2465
2466     return $v >= 8 || $force ? $to_identifier->($name, $sep_char) : $name;
2467 }
2468
2469 # Make a moniker from a table
2470 sub _default_table2moniker {
2471     my ($self, $table) = @_;
2472
2473     my $v = $self->_get_naming_v('monikers');
2474
2475     my @name_parts = map $table->$_, @{ $self->moniker_parts };
2476
2477     my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
2478
2479     my @all_parts;
2480
2481     foreach my $i (0 .. $#name_parts) {
2482         my $part = $name_parts[$i];
2483
2484         if ($i != $name_idx || $v >= 8) {
2485             $part = $self->_to_identifier('monikers', $part, '_', 1);
2486         }
2487
2488         if ($i == $name_idx && $v == 5) {
2489             $part = Lingua::EN::Inflect::Number::to_S($part);
2490         }
2491
2492         my @part_parts = map lc, $v > 6 ?
2493             # use v8 semantics for all moniker parts except name
2494             ($i == $name_idx ? split_name $part, $v : split_name $part)
2495             : split /[\W_]+/, $part;
2496
2497         if ($i == $name_idx && $v >= 6) {
2498             my $as_phrase = join ' ', @part_parts;
2499
2500             my $inflected = ($self->naming->{monikers}||'') eq 'plural' ?
2501                 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2502                 :
2503                 ($self->naming->{monikers}||'') eq 'preserve' ?
2504                     $as_phrase
2505                     :
2506                     Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2507
2508             @part_parts = split /\s+/, $inflected;
2509         }
2510
2511         push @all_parts, map ucfirst, @part_parts;
2512     }
2513
2514     return join '', @all_parts;
2515 }
2516
2517 sub _table2moniker {
2518     my ( $self, $table ) = @_;
2519
2520     $self->_run_user_map(
2521         $self->moniker_map,
2522         sub { $self->_default_table2moniker( shift ) },
2523         $table
2524        );
2525 }
2526
2527 sub _load_relationships {
2528     my ($self, $tables) = @_;
2529
2530     my @tables;
2531
2532     foreach my $table (@$tables) {
2533         my $local_moniker = $self->monikers->{$table->sql_name};
2534
2535         my $tbl_fk_info = $self->_table_fk_info($table);
2536
2537         foreach my $fkdef (@$tbl_fk_info) {
2538             $fkdef->{local_table}   = $table;
2539             $fkdef->{local_moniker} = $local_moniker;
2540             $fkdef->{remote_source} =
2541                 $self->monikers->{$fkdef->{remote_table}->sql_name};
2542         }
2543         my $tbl_uniq_info = $self->_table_uniq_info($table);
2544
2545         push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2546     }
2547
2548     my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2549
2550     foreach my $src_class (sort keys %$rel_stmts) {
2551         # sort by rel name
2552         my @src_stmts = map $_->[2],
2553             sort {
2554                 $a->[0] <=> $b->[0]
2555                 ||
2556                 $a->[1] cmp $b->[1]
2557             } map [
2558                 ($_->{method} eq 'many_to_many' ? 1 : 0),
2559                 $_->{args}[0],
2560                 $_,
2561             ], @{ $rel_stmts->{$src_class} };
2562
2563         foreach my $stmt (@src_stmts) {
2564             $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2565         }
2566     }
2567 }
2568
2569 sub _load_roles {
2570     my ($self, $table) = @_;
2571
2572     my $table_moniker = $self->monikers->{$table->sql_name};
2573     my $table_class   = $self->classes->{$table->sql_name};
2574
2575     my @roles = @{ $self->result_roles || [] };
2576     push @roles, @{ $self->result_roles_map->{$table_moniker} }
2577         if exists $self->result_roles_map->{$table_moniker};
2578
2579     if (@roles) {
2580         $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2581
2582         $self->_with($table_class, @roles);
2583     }
2584 }
2585
2586 # Overload these in driver class:
2587
2588 # Returns an arrayref of column names
2589 sub _table_columns { croak "ABSTRACT METHOD" }
2590
2591 # Returns arrayref of pk col names
2592 sub _table_pk_info { croak "ABSTRACT METHOD" }
2593
2594 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2595 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2596
2597 # Returns an arrayref of foreign key constraints, each
2598 #   being a hashref with 3 keys:
2599 #   local_columns (arrayref), remote_columns (arrayref), remote_table
2600 sub _table_fk_info { croak "ABSTRACT METHOD" }
2601
2602 # Returns an array of lower case table names
2603 sub _tables_list { croak "ABSTRACT METHOD" }
2604
2605 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2606 sub _dbic_stmt {
2607     my $self   = shift;
2608     my $class  = shift;
2609     my $method = shift;
2610
2611     # generate the pod for this statement, storing it with $self->_pod
2612     $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2613
2614     my $args = dump(@_);
2615     $args = '(' . $args . ')' if @_ < 2;
2616     my $stmt = $method . $args . q{;};
2617
2618     warn qq|$class\->$stmt\n| if $self->debug;
2619     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2620     return;
2621 }
2622
2623 sub _make_pod_heading {
2624     my ($self, $class) = @_;
2625
2626     return '' if not $self->generate_pod;
2627
2628     my $table = $self->class_to_table->{$class};
2629     my $pod;
2630
2631     my $pcm = $self->pod_comment_mode;
2632     my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2633     $comment = $self->__table_comment($table);
2634     $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2635     $comment_in_name   = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2636     $comment_in_desc   = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2637
2638     $pod .= "=head1 NAME\n\n";
2639
2640     my $table_descr = $class;
2641     $table_descr .= " - " . $comment if $comment and $comment_in_name;
2642
2643     $pod .= "$table_descr\n\n";
2644
2645     if ($comment and $comment_in_desc) {
2646         $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2647     }
2648     $pod .= "=cut\n\n";
2649
2650     return $pod;
2651 }
2652
2653 # generates the accompanying pod for a DBIC class method statement,
2654 # storing it with $self->_pod
2655 sub _make_pod {
2656     my $self   = shift;
2657     my $class  = shift;
2658     my $method = shift;
2659
2660     if ($method eq 'table') {
2661         my $table = $_[0];
2662         $table = $$table if ref $table eq 'SCALAR';
2663         $self->_pod($class, "=head1 TABLE: C<$table>");
2664         $self->_pod_cut($class);
2665     }
2666     elsif ( $method eq 'add_columns' ) {
2667         $self->_pod( $class, "=head1 ACCESSORS" );
2668         my $col_counter = 0;
2669         my @cols = @_;
2670         while( my ($name,$attrs) = splice @cols,0,2 ) {
2671             $col_counter++;
2672             $self->_pod( $class, '=head2 ' . $name  );
2673             $self->_pod( $class,
2674                 join "\n", map {
2675                     my $s = $attrs->{$_};
2676                     $s = !defined $s          ? 'undef'             :
2677                         length($s) == 0       ? '(empty string)'    :
2678                         ref($s) eq 'SCALAR'   ? $$s                 :
2679                         ref($s)               ? dumper_squashed $s  :
2680                         looks_like_number($s) ? $s                  : qq{'$s'};
2681
2682                     "  $_: $s"
2683                  } sort keys %$attrs,
2684             );
2685             if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2686                 $self->_pod( $class, $comment );
2687             }
2688         }
2689         $self->_pod_cut( $class );
2690     } elsif ( $method =~ /^(?:belongs_to|has_many|might_have)\z/ ) {
2691         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2692         my ( $accessor, $rel_class ) = @_;
2693         $self->_pod( $class, "=head2 $accessor" );
2694         $self->_pod( $class, 'Type: ' . $method );
2695         $self->_pod( $class, "Related object: L<$rel_class>" );
2696         $self->_pod_cut( $class );
2697         $self->{_relations_started} { $class } = 1;
2698     } elsif ( $method eq 'many_to_many' ) {
2699         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2700         my ( $accessor, $rel1, $rel2 ) = @_;
2701         $self->_pod( $class, "=head2 $accessor" );
2702         $self->_pod( $class, 'Type: many_to_many' );
2703         $self->_pod( $class, "Composing rels: L</$rel1> -> $rel2" );
2704         $self->_pod_cut( $class );
2705         $self->{_relations_started} { $class } = 1;
2706     }
2707     elsif ($method eq 'add_unique_constraint') {
2708         $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2709             unless $self->{_uniqs_started}{$class};
2710
2711         my ($name, $cols) = @_;
2712
2713         $self->_pod($class, "=head2 C<$name>");
2714         $self->_pod($class, '=over 4');
2715
2716         foreach my $col (@$cols) {
2717             $self->_pod($class, "=item \* L</$col>");
2718         }
2719
2720         $self->_pod($class, '=back');
2721         $self->_pod_cut($class);
2722
2723         $self->{_uniqs_started}{$class} = 1;
2724     }
2725     elsif ($method eq 'set_primary_key') {
2726         $self->_pod($class, "=head1 PRIMARY KEY");
2727         $self->_pod($class, '=over 4');
2728
2729         foreach my $col (@_) {
2730             $self->_pod($class, "=item \* L</$col>");
2731         }
2732
2733         $self->_pod($class, '=back');
2734         $self->_pod_cut($class);
2735     }
2736 }
2737
2738 sub _pod_class_list {
2739     my ($self, $class, $title, @classes) = @_;
2740
2741     return unless @classes && $self->generate_pod;
2742
2743     $self->_pod($class, "=head1 $title");
2744     $self->_pod($class, '=over 4');
2745
2746     foreach my $link (@classes) {
2747         $self->_pod($class, "=item * L<$link>");
2748     }
2749
2750     $self->_pod($class, '=back');
2751     $self->_pod_cut($class);
2752 }
2753
2754 sub _base_class_pod {
2755     my ($self, $base_class) = @_;
2756
2757     return '' unless $self->generate_pod;
2758
2759     return <<"EOF"
2760 =head1 BASE CLASS: L<$base_class>
2761
2762 =cut
2763
2764 EOF
2765 }
2766
2767 sub _filter_comment {
2768     my ($self, $txt) = @_;
2769
2770     $txt = '' if not defined $txt;
2771
2772     $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2773
2774     return $txt;
2775 }
2776
2777 sub __table_comment {
2778     my $self = shift;
2779
2780     if (my $code = $self->can('_table_comment')) {
2781         return $self->_filter_comment($self->$code(@_));
2782     }
2783
2784     return '';
2785 }
2786
2787 sub __column_comment {
2788     my $self = shift;
2789
2790     if (my $code = $self->can('_column_comment')) {
2791         return $self->_filter_comment($self->$code(@_));
2792     }
2793
2794     return '';
2795 }
2796
2797 # Stores a POD documentation
2798 sub _pod {
2799     my ($self, $class, $stmt) = @_;
2800     $self->_raw_stmt( $class, "\n" . $stmt  );
2801 }
2802
2803 sub _pod_cut {
2804     my ($self, $class ) = @_;
2805     $self->_raw_stmt( $class, "\n=cut\n" );
2806 }
2807
2808 # Store a raw source line for a class (for dumping purposes)
2809 sub _raw_stmt {
2810     my ($self, $class, $stmt) = @_;
2811     push(@{$self->{_dump_storage}->{$class}}, $stmt);
2812 }
2813
2814 # Like above, but separately for the externally loaded stuff
2815 sub _ext_stmt {
2816     my ($self, $class, $stmt) = @_;
2817     push(@{$self->{_ext_storage}->{$class}}, $stmt);
2818 }
2819
2820 sub _custom_column_info {
2821     my ( $self, $table_name, $column_name, $column_info ) = @_;
2822
2823     if (my $code = $self->custom_column_info) {
2824         return $code->($table_name, $column_name, $column_info) || {};
2825     }
2826     return {};
2827 }
2828
2829 sub _datetime_column_info {
2830     my ( $self, $table_name, $column_name, $column_info ) = @_;
2831     my $result = {};
2832     my $type = $column_info->{data_type} || '';
2833     if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2834             or ($type =~ /date|timestamp/i)) {
2835         $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2836         $result->{locale}   = $self->datetime_locale   if $self->datetime_locale;
2837     }
2838     return $result;
2839 }
2840
2841 sub _lc {
2842     my ($self, $name) = @_;
2843
2844     return $self->preserve_case ? $name : lc($name);
2845 }
2846
2847 sub _uc {
2848     my ($self, $name) = @_;
2849
2850     return $self->preserve_case ? $name : uc($name);
2851 }
2852
2853 sub _remove_table {
2854     my ($self, $table) = @_;
2855
2856     try {
2857         my $schema = $self->schema;
2858         # in older DBIC it's a private method
2859         my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2860         $schema->$unregister(delete $self->monikers->{$table->sql_name});
2861         delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}};
2862         delete $self->_tables->{$table->sql_name};
2863     };
2864 }
2865
2866 # remove the dump dir from @INC on destruction
2867 sub DESTROY {
2868     my $self = shift;
2869
2870     @INC = grep $_ ne $self->dump_directory, @INC;
2871 }
2872
2873 =head2 monikers
2874
2875 Returns a hashref of loaded table to moniker mappings.  There will
2876 be two entries for each table, the original name and the "normalized"
2877 name, in the case that the two are different (such as databases
2878 that like uppercase table names, or preserve your original mixed-case
2879 definitions, or what-have-you).
2880
2881 =head2 classes
2882
2883 Returns a hashref of table to class mappings.  In some cases it will
2884 contain multiple entries per table for the original and normalized table
2885 names, as above in L</monikers>.
2886
2887 =head1 NON-ENGLISH DATABASES
2888
2889 If you use the loader on a database with table and column names in a language
2890 other than English, you will want to turn off the English language specific
2891 heuristics.
2892
2893 To do so, use something like this in your loader options:
2894
2895     naming           => { monikers => 'v4' },
2896     inflect_singular => sub { "$_[0]_rel" },
2897     inflect_plural   => sub { "$_[0]_rel" },
2898
2899 =head1 COLUMN ACCESSOR COLLISIONS
2900
2901 Occasionally you may have a column name that collides with a perl method, such
2902 as C<can>. In such cases, the default action is to set the C<accessor> of the
2903 column spec to C<undef>.
2904
2905 You can then name the accessor yourself by placing code such as the following
2906 below the md5:
2907
2908     __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2909
2910 Another option is to use the L</col_collision_map> option.
2911
2912 =head1 RELATIONSHIP NAME COLLISIONS
2913
2914 In very rare cases, you may get a collision between a generated relationship
2915 name and a method in your Result class, for example if you have a foreign key
2916 called C<belongs_to>.
2917
2918 This is a problem because relationship names are also relationship accessor
2919 methods in L<DBIx::Class>.
2920
2921 The default behavior is to append C<_rel> to the relationship name and print
2922 out a warning that refers to this text.
2923
2924 You can also control the renaming with the L</rel_collision_map> option.
2925
2926 =head1 SEE ALSO
2927
2928 L<DBIx::Class::Schema::Loader>, L<dbicdump>
2929
2930 =head1 AUTHOR
2931
2932 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2933
2934 =head1 LICENSE
2935
2936 This library is free software; you can redistribute it and/or modify it under
2937 the same terms as Perl itself.
2938
2939 =cut
2940
2941 1;
2942 # vim:et sts=4 sw=4 tw=0: