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