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.07029';
  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 unless explicitly set to false by the user.
 752
 753 =head2 use_moose
 754
 755 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
 756 L<MooseX::MarkAsMethods> (or L<namespace::autoclean>, see below). The default
 757 content after the md5 sum also makes the classes immutable.
 758
 759 It is safe to upgrade your existing Schema to this option.
 760
 761 =head2 only_autoclean
 762
 763 By default, we use L<MooseX::MarkAsMethods> to remove imported functions from
 764 your generated classes.  It uses L<namespace::autoclean> to do this, after
 765 telling your object's metaclass that any operator L<overload>s in your class
 766 are methods, which will cause namespace::autoclean to spare them from removal.
 767
 768 This prevents the "Hey, where'd my overloads go?!" effect.
 769
 770 If you don't care about operator overloads, enabling this option falls back to
 771 just using L<namespace::autoclean> itself.
 772
 773 If none of the above made any sense, or you don't have some pressing need to
 774 only use L<namespace::autoclean>, leaving this set to the default is
 775 recommended.
 776
 777 =head2 col_collision_map
 778
 779 This option controls how accessors for column names which collide with perl
 780 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
 781
 782 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
 783 strings which are compiled to regular expressions that map to
 784 L<sprintf|perlfunc/sprintf> formats.
 785
 786 Examples:
 787
 788     col_collision_map => 'column_%s'
 789
 790     col_collision_map => { '(.*)' => 'column_%s' }
 791
 792     col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
 793
 794 =head2 rel_collision_map
 795
 796 Works just like L</col_collision_map>, but for relationship names/accessors
 797 rather than column names/accessors.
 798
 799 The default is to just append C<_rel> to the relationship name, see
 800 L</RELATIONSHIP NAME COLLISIONS>.
 801
 802 =head2 uniq_to_primary
 803
 804 Automatically promotes the largest unique constraints with non-nullable columns
 805 on tables to primary keys, assuming there is only one largest unique
 806 constraint.
 807
 808 =head2 filter_generated_code
 809
 810 An optional hook that lets you filter the generated text for various classes
 811 through a function that change it in any way that you want.  The function will
 812 receive the type of file, C<schema> or C<result>, class and code; and returns
 813 the new code to use instead.  For instance you could add custom comments, or do
 814 anything else that you want.
 815
 816 The option can also be set to a string, which is then used as a filter program,
 817 e.g. C<perltidy>.
 818
 819 If this exists but fails to return text matching C</\bpackage\b/>, no file will
 820 be generated.
 821
 822     filter_generated_code => sub {
 823         my ($type, $class, $text) = @_;
 824         ...
 825         return $new_code;
 826     }
 827
 828 =head1 METHODS
 829
 830 None of these methods are intended for direct invocation by regular
 831 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
 832 L<DBIx::Class::Schema::Loader>.
 833
 834 =cut
 835
 836 # ensure that a peice of object data is a valid arrayref, creating
 837 # an empty one or encapsulating whatever's there.
 838 sub _ensure_arrayref {
 839     my $self = shift;
 840
 841     foreach (@_) {
 842         $self->{$_} ||= [];
 843         $self->{$_} = [ $self->{$_} ]
 844             unless ref $self->{$_} eq 'ARRAY';
 845     }
 846 }
 847
 848 =head2 new
 849
 850 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
 851 by L<DBIx::Class::Schema::Loader>.
 852
 853 =cut
 854
 855 sub new {
 856     my ( $class, %args ) = @_;
 857
 858     if (exists $args{column_accessor_map}) {
 859         $args{col_accessor_map} = delete $args{column_accessor_map};
 860     }
 861
 862     my $self = { %args };
 863
 864     # don't lose undef options
 865     for (values %$self) {
 866         $_ = 0 unless defined $_;
 867     }
 868
 869     bless $self => $class;
 870
 871     if (my $config_file = $self->config_file) {
 872         my $config_opts = do $config_file;
 873
 874         croak "Error reading config from $config_file: $@" if $@;
 875
 876         croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
 877
 878         while (my ($k, $v) = each %$config_opts) {
 879             $self->{$k} = $v unless exists $self->{$k};
 880         }
 881     }
 882
 883     if (defined $self->{result_component_map}) {
 884         if (defined $self->result_components_map) {
 885             croak "Specify only one of result_components_map or result_component_map";
 886         }
 887         $self->result_components_map($self->{result_component_map})
 888     }
 889
 890     if (defined $self->{result_role_map}) {
 891         if (defined $self->result_roles_map) {
 892             croak "Specify only one of result_roles_map or result_role_map";
 893         }
 894         $self->result_roles_map($self->{result_role_map})
 895     }
 896
 897     croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
 898         if ((not defined $self->use_moose) || (not $self->use_moose))
 899             && ((defined $self->result_roles) || (defined $self->result_roles_map));
 900
 901     $self->_ensure_arrayref(qw/schema_components
 902                                additional_classes
 903                                additional_base_classes
 904                                left_base_classes
 905                                components
 906                                result_roles
 907                               /);
 908
 909     $self->_validate_class_args;
 910
 911     croak "result_components_map must be a hash"
 912         if defined $self->result_components_map
 913             && ref $self->result_components_map ne 'HASH';
 914
 915     if ($self->result_components_map) {
 916         my %rc_map = %{ $self->result_components_map };
 917         foreach my $moniker (keys %rc_map) {
 918             $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
 919         }
 920         $self->result_components_map(\%rc_map);
 921     }
 922     else {
 923         $self->result_components_map({});
 924     }
 925     $self->_validate_result_components_map;
 926
 927     croak "result_roles_map must be a hash"
 928         if defined $self->result_roles_map
 929             && ref $self->result_roles_map ne 'HASH';
 930
 931     if ($self->result_roles_map) {
 932         my %rr_map = %{ $self->result_roles_map };
 933         foreach my $moniker (keys %rr_map) {
 934             $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
 935         }
 936         $self->result_roles_map(\%rr_map);
 937     } else {
 938         $self->result_roles_map({});
 939     }
 940     $self->_validate_result_roles_map;
 941
 942     if ($self->use_moose) {
 943         if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
 944             die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
 945                 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
 946         }
 947     }
 948
 949     $self->{_tables} = {};
 950     $self->{monikers} = {};
 951     $self->{moniker_to_table} = {};
 952     $self->{class_to_table} = {};
 953     $self->{classes}  = {};
 954     $self->{_upgrading_classes} = {};
 955
 956     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
 957     $self->{schema} ||= $self->{schema_class};
 958     $self->{table_comments_table} ||= 'table_comments';
 959     $self->{column_comments_table} ||= 'column_comments';
 960
 961     croak "dump_overwrite is deprecated.  Please read the"
 962         . " DBIx::Class::Schema::Loader::Base documentation"
 963             if $self->{dump_overwrite};
 964
 965     $self->{dynamic} = ! $self->{dump_directory};
 966     $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
 967                                                      TMPDIR  => 1,
 968                                                      CLEANUP => 1,
 969                                                    );
 970
 971     $self->{dump_directory} ||= $self->{temp_directory};
 972
 973     $self->real_dump_directory($self->{dump_directory});
 974
 975     $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 976     $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 977
 978     if (not defined $self->naming) {
 979         $self->naming_set(0);
 980     }
 981     else {
 982         $self->naming_set(1);
 983     }
 984
 985     if ((not ref $self->naming) && defined $self->naming) {
 986         my $naming_ver = $self->naming;
 987         $self->{naming} = {
 988             relationships => $naming_ver,
 989             monikers => $naming_ver,
 990             column_accessors => $naming_ver,
 991         };
 992     }
 993     elsif (ref $self->naming eq 'HASH' && exists $self->naming->{ALL}) {
 994         my $val = delete $self->naming->{ALL};
 995
 996         $self->naming->{$_} = $val
 997             foreach qw/relationships monikers column_accessors/;
 998     }
 999
1000     if ($self->naming) {
1001         foreach my $key (qw/relationships monikers column_accessors/) {
1002             $self->naming->{$key} = $CURRENT_V if ($self->naming->{$key}||'') eq 'current';
1003         }
1004     }
1005     $self->{naming} ||= {};
1006
1007     if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
1008         croak 'custom_column_info must be a CODE ref';
1009     }
1010
1011     $self->_check_back_compat;
1012
1013     $self->use_namespaces(1) unless defined $self->use_namespaces;
1014     $self->generate_pod(1)   unless defined $self->generate_pod;
1015     $self->pod_comment_mode('auto')         unless defined $self->pod_comment_mode;
1016     $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
1017
1018     if (my $col_collision_map = $self->col_collision_map) {
1019         if (my $reftype = ref $col_collision_map) {
1020             if ($reftype ne 'HASH') {
1021                 croak "Invalid type $reftype for option 'col_collision_map'";
1022             }
1023         }
1024         else {
1025             $self->col_collision_map({ '(.*)' => $col_collision_map });
1026         }
1027     }
1028
1029     if (my $rel_collision_map = $self->rel_collision_map) {
1030         if (my $reftype = ref $rel_collision_map) {
1031             if ($reftype ne 'HASH') {
1032                 croak "Invalid type $reftype for option 'rel_collision_map'";
1033             }
1034         }
1035         else {
1036             $self->rel_collision_map({ '(.*)' => $rel_collision_map });
1037         }
1038     }
1039
1040     if (defined(my $rel_name_map = $self->rel_name_map)) {
1041         my $reftype = ref $rel_name_map;
1042         if ($reftype ne 'HASH' && $reftype ne 'CODE') {
1043             croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
1044         }
1045     }
1046
1047     if (defined(my $filter = $self->filter_generated_code)) {
1048         my $reftype = ref $filter;
1049         if ($reftype && $reftype ne 'CODE') {
1050             croak "Invalid type $reftype for option 'filter_generated_code, must be a scalar or a CODE reference";
1051         }
1052     }
1053
1054     if (defined $self->db_schema) {
1055         if (ref $self->db_schema eq 'ARRAY') {
1056             if (@{ $self->db_schema } > 1 && not defined $self->{qualify_objects}) {
1057                 $self->{qualify_objects} = 1;
1058             }
1059             elsif (@{ $self->db_schema } == 0) {
1060                 $self->{db_schema} = undef;
1061             }
1062         }
1063         elsif (not ref $self->db_schema) {
1064             if ($self->db_schema eq '%' && not defined $self->{qualify_objects}) {
1065                 $self->{qualify_objects} = 1;
1066             }
1067
1068             $self->{db_schema} = [ $self->db_schema ];
1069         }
1070     }
1071
1072     if (not $self->moniker_parts) {
1073         $self->moniker_parts(['name']);
1074     }
1075     else {
1076         if (not ref $self->moniker_parts) {
1077             $self->moniker_parts([ $self->moniker_parts ]);
1078         }
1079         if (ref $self->moniker_parts ne 'ARRAY') {
1080             croak 'moniker_parts must be an arrayref';
1081         }
1082         if ((firstidx { $_ eq 'name' } @{ $self->moniker_parts }) == -1) {
1083             croak "moniker_parts option *must* contain 'name'";
1084         }
1085     }
1086
1087     return $self;
1088 }
1089
1090 sub _check_back_compat {
1091     my ($self) = @_;
1092
1093 # dynamic schemas will always be in 0.04006 mode, unless overridden
1094     if ($self->dynamic) {
1095 # just in case, though no one is likely to dump a dynamic schema
1096         $self->schema_version_to_dump('0.04006');
1097
1098         if (not $self->naming_set) {
1099             warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1100
1101 Dynamic schema detected, will run in 0.04006 mode.
1102
1103 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1104 to disable this warning.
1105
1106 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1107 details.
1108 EOF
1109         }
1110         else {
1111             $self->_upgrading_from('v4');
1112         }
1113
1114         if ((not defined $self->use_namespaces) && ($self->naming_set)) {
1115             $self->use_namespaces(1);
1116         }
1117
1118         $self->naming->{relationships} ||= 'v4';
1119         $self->naming->{monikers}      ||= 'v4';
1120
1121         if ($self->use_namespaces) {
1122             $self->_upgrading_from_load_classes(1);
1123         }
1124         else {
1125             $self->use_namespaces(0);
1126         }
1127
1128         return;
1129     }
1130
1131 # otherwise check if we need backcompat mode for a static schema
1132     my $filename = $self->get_dump_filename($self->schema_class);
1133     return unless -e $filename;
1134
1135     my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
1136       $self->_parse_generated_file($filename);
1137
1138     return unless $old_ver;
1139
1140     # determine if the existing schema was dumped with use_moose => 1
1141     if (! defined $self->use_moose) {
1142         $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
1143     }
1144
1145     my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
1146
1147     my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
1148     my $ds = eval $result_namespace;
1149     die <<"EOF" if $@;
1150 Could not eval expression '$result_namespace' for result_namespace from
1151 $filename: $@
1152 EOF
1153     $result_namespace = $ds || '';
1154
1155     if ($load_classes && (not defined $self->use_namespaces)) {
1156         warn <<"EOF"  unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1157
1158 'load_classes;' static schema detected, turning off 'use_namespaces'.
1159
1160 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
1161 variable to disable this warning.
1162
1163 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1164 details.
1165 EOF
1166         $self->use_namespaces(0);
1167     }
1168     elsif ($load_classes && $self->use_namespaces) {
1169         $self->_upgrading_from_load_classes(1);
1170     }
1171     elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
1172         $self->_downgrading_to_load_classes(
1173             $result_namespace || 'Result'
1174         );
1175     }
1176     elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
1177         if (not $self->result_namespace) {
1178             $self->result_namespace($result_namespace || 'Result');
1179         }
1180         elsif ($result_namespace ne $self->result_namespace) {
1181             $self->_rewriting_result_namespace(
1182                 $result_namespace || 'Result'
1183             );
1184         }
1185     }
1186
1187     # XXX when we go past .0 this will need fixing
1188     my ($v) = $old_ver =~ /([1-9])/;
1189     $v = "v$v";
1190
1191     return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
1192
1193     if (not %{ $self->naming }) {
1194         warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1195
1196 Version $old_ver static schema detected, turning on backcompat mode.
1197
1198 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1199 to disable this warning.
1200
1201 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
1202
1203 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
1204 from version 0.04006.
1205 EOF
1206
1207         $self->naming->{relationships}    ||= $v;
1208         $self->naming->{monikers}         ||= $v;
1209         $self->naming->{column_accessors} ||= $v;
1210
1211         $self->schema_version_to_dump($old_ver);
1212     }
1213     else {
1214         $self->_upgrading_from($v);
1215     }
1216 }
1217
1218 sub _validate_class_args {
1219     my $self = shift;
1220
1221     foreach my $k (@CLASS_ARGS) {
1222         next unless $self->$k;
1223
1224         my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
1225         $self->_validate_classes($k, \@classes);
1226     }
1227 }
1228
1229 sub _validate_result_components_map {
1230     my $self = shift;
1231
1232     foreach my $classes (values %{ $self->result_components_map }) {
1233         $self->_validate_classes('result_components_map', $classes);
1234     }
1235 }
1236
1237 sub _validate_result_roles_map {
1238     my $self = shift;
1239
1240     foreach my $classes (values %{ $self->result_roles_map }) {
1241         $self->_validate_classes('result_roles_map', $classes);
1242     }
1243 }
1244
1245 sub _validate_classes {
1246     my $self = shift;
1247     my $key  = shift;
1248     my $classes = shift;
1249
1250     # make a copy to not destroy original
1251     my @classes = @$classes;
1252
1253     foreach my $c (@classes) {
1254         # components default to being under the DBIx::Class namespace unless they
1255         # are preceeded with a '+'
1256         if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1257             $c = 'DBIx::Class::' . $c;
1258         }
1259
1260         # 1 == installed, 0 == not installed, undef == invalid classname
1261         my $installed = Class::Inspector->installed($c);
1262         if ( defined($installed) ) {
1263             if ( $installed == 0 ) {
1264                 croak qq/$c, as specified in the loader option "$key", is not installed/;
1265             }
1266         } else {
1267             croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1268         }
1269     }
1270 }
1271
1272
1273 sub _find_file_in_inc {
1274     my ($self, $file) = @_;
1275
1276     foreach my $prefix (@INC) {
1277         my $fullpath = File::Spec->catfile($prefix, $file);
1278         return $fullpath if -f $fullpath
1279             # abs_path throws on Windows for nonexistant files
1280             and (try { Cwd::abs_path($fullpath) }) ne
1281                ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1282     }
1283
1284     return;
1285 }
1286
1287 sub _find_class_in_inc {
1288     my ($self, $class) = @_;
1289
1290     return $self->_find_file_in_inc(class_path($class));
1291 }
1292
1293 sub _rewriting {
1294     my $self = shift;
1295
1296     return $self->_upgrading_from
1297         || $self->_upgrading_from_load_classes
1298         || $self->_downgrading_to_load_classes
1299         || $self->_rewriting_result_namespace
1300     ;
1301 }
1302
1303 sub _rewrite_old_classnames {
1304     my ($self, $code) = @_;
1305
1306     return $code unless $self->_rewriting;
1307
1308     my %old_classes = reverse %{ $self->_upgrading_classes };
1309
1310     my $re = join '|', keys %old_classes;
1311     $re = qr/\b($re)\b/;
1312
1313     $code =~ s/$re/$old_classes{$1} || $1/eg;
1314
1315     return $code;
1316 }
1317
1318 sub _load_external {
1319     my ($self, $class) = @_;
1320
1321     return if $self->{skip_load_external};
1322
1323     # so that we don't load our own classes, under any circumstances
1324     local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1325
1326     my $real_inc_path = $self->_find_class_in_inc($class);
1327
1328     my $old_class = $self->_upgrading_classes->{$class}
1329         if $self->_rewriting;
1330
1331     my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1332         if $old_class && $old_class ne $class;
1333
1334     return unless $real_inc_path || $old_real_inc_path;
1335
1336     if ($real_inc_path) {
1337         # If we make it to here, we loaded an external definition
1338         warn qq/# Loaded external class definition for '$class'\n/
1339             if $self->debug;
1340
1341         my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path);
1342
1343         if ($self->dynamic) { # load the class too
1344             eval_package_without_redefine_warnings($class, $code);
1345         }
1346
1347         $self->_ext_stmt($class,
1348           qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1349          .qq|# They are now part of the custom portion of this file\n|
1350          .qq|# for you to hand-edit.  If you do not either delete\n|
1351          .qq|# this section or remove that file from \@INC, this section\n|
1352          .qq|# will be repeated redundantly when you re-create this\n|
1353          .qq|# file again via Loader!  See skip_load_external to disable\n|
1354          .qq|# this feature.\n|
1355         );
1356         chomp $code;
1357         $self->_ext_stmt($class, $code);
1358         $self->_ext_stmt($class,
1359             qq|# End of lines loaded from '$real_inc_path' |
1360         );
1361     }
1362
1363     if ($old_real_inc_path) {
1364         my $code = slurp_file $old_real_inc_path;
1365
1366         $self->_ext_stmt($class, <<"EOF");
1367
1368 # These lines were loaded from '$old_real_inc_path',
1369 # based on the Result class name that would have been created by an older
1370 # version of the Loader. For a static schema, this happens only once during
1371 # upgrade. See skip_load_external to disable this feature.
1372 EOF
1373
1374         $code = $self->_rewrite_old_classnames($code);
1375
1376         if ($self->dynamic) {
1377             warn <<"EOF";
1378
1379 Detected external content in '$old_real_inc_path', a class name that would have
1380 been used by an older version of the Loader.
1381
1382 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1383 new name of the Result.
1384 EOF
1385             eval_package_without_redefine_warnings($class, $code);
1386         }
1387
1388         chomp $code;
1389         $self->_ext_stmt($class, $code);
1390         $self->_ext_stmt($class,
1391             qq|# End of lines loaded from '$old_real_inc_path' |
1392         );
1393     }
1394 }
1395
1396 =head2 load
1397
1398 Does the actual schema-construction work.
1399
1400 =cut
1401
1402 sub load {
1403     my $self = shift;
1404
1405     $self->_load_tables(
1406         $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1407     );
1408 }
1409
1410 =head2 rescan
1411
1412 Arguments: schema
1413
1414 Rescan the database for changes. Returns a list of the newly added table
1415 monikers.
1416
1417 The schema argument should be the schema class or object to be affected.  It
1418 should probably be derived from the original schema_class used during L</load>.
1419
1420 =cut
1421
1422 sub rescan {
1423     my ($self, $schema) = @_;
1424
1425     $self->{schema} = $schema;
1426     $self->_relbuilder->{schema} = $schema;
1427
1428     my @created;
1429     my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1430
1431     foreach my $table (@current) {
1432         if(!exists $self->_tables->{$table->sql_name}) {
1433             push(@created, $table);
1434         }
1435     }
1436
1437     my %current;
1438     @current{map $_->sql_name, @current} = ();
1439     foreach my $table (values %{ $self->_tables }) {
1440         if (not exists $current{$table->sql_name}) {
1441             $self->_remove_table($table);
1442         }
1443     }
1444
1445     delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1446
1447     my $loaded = $self->_load_tables(@current);
1448
1449     foreach my $table (@created) {
1450         $self->monikers->{$table->sql_name} = $self->_table2moniker($table);
1451     }
1452
1453     return map { $self->monikers->{$_->sql_name} } @created;
1454 }
1455
1456 sub _relbuilder {
1457     my ($self) = @_;
1458
1459     return if $self->{skip_relationships};
1460
1461     return $self->{relbuilder} ||= do {
1462         my $relbuilder_suff =
1463             {qw{
1464                 v4  ::Compat::v0_040
1465                 v5  ::Compat::v0_05
1466                 v6  ::Compat::v0_06
1467                 v7  ::Compat::v0_07
1468             }}
1469             ->{$self->naming->{relationships}||$CURRENT_V} || '';
1470
1471         my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1472         $self->ensure_class_loaded($relbuilder_class);
1473         $relbuilder_class->new($self);
1474     };
1475 }
1476
1477 sub _load_tables {
1478     my ($self, @tables) = @_;
1479
1480     # Save the new tables to the tables list and compute monikers
1481     foreach (@tables) {
1482         $self->_tables->{$_->sql_name}  = $_;
1483         $self->monikers->{$_->sql_name} = $self->_table2moniker($_);
1484     }
1485
1486     # check for moniker clashes
1487     my $inverse_moniker_idx;
1488     foreach my $imtable (values %{ $self->_tables }) {
1489         push @{ $inverse_moniker_idx->{$self->monikers->{$imtable->sql_name}} }, $imtable;
1490     }
1491
1492     my @clashes;
1493     foreach my $moniker (keys %$inverse_moniker_idx) {
1494         my $imtables = $inverse_moniker_idx->{$moniker};
1495         if (@$imtables > 1) {
1496             my $different_databases =
1497                 $imtables->[0]->can('database') && (uniq map $_->database||'', @$imtables) > 1;
1498
1499             my $different_schemas =
1500                 (uniq map $_->schema||'', @$imtables) > 1;
1501
1502             if ($different_databases || $different_schemas) {
1503                 my ($use_schema, $use_database) = (1, 0);
1504
1505                 if ($different_databases) {
1506                     $use_database = 1;
1507
1508                     # If any monikers are in the same database, we have to distinguish by
1509                     # both schema and database.
1510                     my %db_counts;
1511                     $db_counts{$_}++ for map $_->database, @$imtables;
1512                     $use_schema = any { $_ > 1 } values %db_counts;
1513                 }
1514
1515                 foreach my $tbl (@$imtables) { delete $self->monikers->{$tbl->sql_name}; }
1516
1517                 my $moniker_parts = [ @{ $self->moniker_parts } ];
1518
1519                 my $have_schema   = 1 if any { $_ eq 'schema'   } @{ $self->moniker_parts };
1520                 my $have_database = 1 if any { $_ eq 'database' } @{ $self->moniker_parts };
1521
1522                 unshift @$moniker_parts, 'schema'   if $use_schema   && !$have_schema;
1523                 unshift @$moniker_parts, 'database' if $use_database && !$have_database;
1524
1525                 local $self->{moniker_parts} = $moniker_parts;
1526
1527                 my %new_monikers;
1528
1529                 foreach my $tbl  (@$imtables)                   { $new_monikers{$tbl->sql_name} = $self->_table2moniker($tbl); }
1530                 foreach my $name (map $_->sql_name, @$imtables) { $self->monikers->{$name} = $new_monikers{$name}; }
1531
1532                 # check if there are still clashes
1533                 my %by_moniker;
1534
1535                 while (my ($t, $m) = each %new_monikers) {
1536                     push @{ $by_moniker{$m} }, $t;
1537                 }
1538
1539                 foreach my $m (grep @{ $by_moniker{$_} } > 1, keys %by_moniker) {
1540                     push @clashes, sprintf ("tried disambiguating by moniker_parts, but tables %s still reduced to the same source moniker '%s'",
1541                         join (', ', @{ $by_moniker{$m} }),
1542                         $m,
1543                     );
1544                 }
1545             }
1546             else {
1547                 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1548                     join (', ', map $_->sql_name, @$imtables),
1549                     $moniker,
1550                 );
1551             }
1552         }
1553     }
1554
1555     if (@clashes) {
1556         die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1557         . 'Change the naming style, or supply an explicit moniker_map: '
1558         . join ('; ', @clashes)
1559         . "\n"
1560         ;
1561     }
1562
1563     foreach my $tbl (@tables) { $self->_make_src_class($tbl); }
1564     foreach my $tbl (@tables) { $self->_setup_src_meta($tbl); }
1565
1566     if(!$self->skip_relationships) {
1567         # The relationship loader needs a working schema
1568         local $self->{quiet} = 1;
1569         local $self->{dump_directory} = $self->{temp_directory};
1570         $self->_reload_classes(\@tables);
1571         $self->_load_relationships(\@tables);
1572
1573         # Remove that temp dir from INC so it doesn't get reloaded
1574         @INC = grep $_ ne $self->dump_directory, @INC;
1575     }
1576
1577     foreach my $tbl                                        (@tables) { $self->_load_roles($tbl); }
1578     foreach my $tbl (map { $self->classes->{$_->sql_name} } @tables) { $self->_load_external($tbl); }
1579
1580     # Reload without unloading first to preserve any symbols from external
1581     # packages.
1582     $self->_reload_classes(\@tables, { unload => 0 });
1583
1584     # Drop temporary cache
1585     delete $self->{_cache};
1586
1587     return \@tables;
1588 }
1589
1590 sub _reload_classes {
1591     my ($self, $tables, $opts) = @_;
1592
1593     my @tables = @$tables;
1594
1595     my $unload = $opts->{unload};
1596     $unload = 1 unless defined $unload;
1597
1598     # so that we don't repeat custom sections
1599     @INC = grep $_ ne $self->dump_directory, @INC;
1600
1601     $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables);
1602
1603     unshift @INC, $self->dump_directory;
1604
1605     my @to_register;
1606     my %have_source = map { $_ => $self->schema->source($_) }
1607         $self->schema->sources;
1608
1609     for my $table (@tables) {
1610         my $moniker = $self->monikers->{$table->sql_name};
1611         my $class = $self->classes->{$table->sql_name};
1612
1613         {
1614             no warnings 'redefine';
1615             local *Class::C3::reinitialize = sub {};  # to speed things up, reinitialized below
1616             use warnings;
1617
1618             if (my $mc = $self->_moose_metaclass($class)) {
1619                 $mc->make_mutable;
1620             }
1621             Class::Unload->unload($class) if $unload;
1622             my ($source, $resultset_class);
1623             if (
1624                 ($source = $have_source{$moniker})
1625                 && ($resultset_class = $source->resultset_class)
1626                 && ($resultset_class ne 'DBIx::Class::ResultSet')
1627             ) {
1628                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1629                 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1630                     $mc->make_mutable;
1631                 }
1632                 Class::Unload->unload($resultset_class) if $unload;
1633                 $self->_reload_class($resultset_class) if $has_file;
1634             }
1635             $self->_reload_class($class);
1636         }
1637         push @to_register, [$moniker, $class];
1638     }
1639
1640     Class::C3->reinitialize;
1641     for (@to_register) {
1642         $self->schema->register_class(@$_);
1643     }
1644 }
1645
1646 sub _moose_metaclass {
1647   return undef unless $INC{'Class/MOP.pm'};   # if CMOP is not loaded the class could not have loaded in the 1st place
1648
1649   my $class = $_[1];
1650
1651   my $mc = try { Class::MOP::class_of($class) }
1652     or return undef;
1653
1654   return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1655 }
1656
1657 # We use this instead of ensure_class_loaded when there are package symbols we
1658 # want to preserve.
1659 sub _reload_class {
1660     my ($self, $class) = @_;
1661
1662     delete $INC{ +class_path($class) };
1663
1664     try {
1665         eval_package_without_redefine_warnings ($class, "require $class");
1666     }
1667     catch {
1668         my $source = slurp_file $self->_get_dump_filename($class);
1669         die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1670     };
1671 }
1672
1673 sub _get_dump_filename {
1674     my ($self, $class) = (@_);
1675
1676     $class =~ s{::}{/}g;
1677     return $self->dump_directory . q{/} . $class . q{.pm};
1678 }
1679
1680 =head2 get_dump_filename
1681
1682 Arguments: class
1683
1684 Returns the full path to the file for a class that the class has been or will
1685 be dumped to. This is a file in a temp dir for a dynamic schema.
1686
1687 =cut
1688
1689 sub get_dump_filename {
1690     my ($self, $class) = (@_);
1691
1692     local $self->{dump_directory} = $self->real_dump_directory;
1693
1694     return $self->_get_dump_filename($class);
1695 }
1696
1697 sub _ensure_dump_subdirs {
1698     my ($self, $class) = (@_);
1699
1700     my @name_parts = split(/::/, $class);
1701     pop @name_parts; # we don't care about the very last element,
1702                      # which is a filename
1703
1704     my $dir = $self->dump_directory;
1705     while (1) {
1706         if(!-d $dir) {
1707             mkdir($dir) or croak "mkdir('$dir') failed: $!";
1708         }
1709         last if !@name_parts;
1710         $dir = File::Spec->catdir($dir, shift @name_parts);
1711     }
1712 }
1713
1714 sub _dump_to_dir {
1715     my ($self, @classes) = @_;
1716
1717     my $schema_class = $self->schema_class;
1718     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1719
1720     my $target_dir = $self->dump_directory;
1721     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1722         unless $self->dynamic or $self->quiet;
1723
1724     my $schema_text =
1725           qq|use utf8;\n|
1726         . qq|package $schema_class;\n\n|
1727         . qq|# Created by DBIx::Class::Schema::Loader\n|
1728         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1729
1730     my $autoclean
1731         = $self->only_autoclean
1732         ? 'namespace::autoclean'
1733         : 'MooseX::MarkAsMethods autoclean => 1'
1734         ;
1735
1736     if ($self->use_moose) {
1737
1738         $schema_text.= qq|use Moose;\nuse $autoclean;\nextends '$schema_base_class';\n\n|;
1739     }
1740     else {
1741         $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1742     }
1743
1744     my @schema_components = @{ $self->schema_components || [] };
1745
1746     if (@schema_components) {
1747         my $schema_components = dump @schema_components;
1748         $schema_components = "($schema_components)" if @schema_components == 1;
1749
1750         $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1751     }
1752
1753     if ($self->use_namespaces) {
1754         $schema_text .= qq|__PACKAGE__->load_namespaces|;
1755         my $namespace_options;
1756
1757         my @attr = qw/resultset_namespace default_resultset_class/;
1758
1759         unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1760
1761         for my $attr (@attr) {
1762             if ($self->$attr) {
1763                 my $code = dumper_squashed $self->$attr;
1764                 $namespace_options .= qq|    $attr => $code,\n|
1765             }
1766         }
1767         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1768         $schema_text .= qq|;\n|;
1769     }
1770     else {
1771         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1772     }
1773
1774     {
1775         local $self->{version_to_dump} = $self->schema_version_to_dump;
1776         $self->_write_classfile($schema_class, $schema_text, 1);
1777     }
1778
1779     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1780
1781     foreach my $src_class (@classes) {
1782         my $src_text =
1783               qq|use utf8;\n|
1784             . qq|package $src_class;\n\n|
1785             . qq|# Created by DBIx::Class::Schema::Loader\n|
1786             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1787
1788         $src_text .= $self->_make_pod_heading($src_class);
1789
1790         $src_text .= qq|use strict;\nuse warnings;\n\n|;
1791
1792         $src_text .= $self->_base_class_pod($result_base_class)
1793             unless $result_base_class eq 'DBIx::Class::Core';
1794
1795         if ($self->use_moose) {
1796             $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse $autoclean;|;
1797
1798             # these options 'use base' which is compile time
1799             if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1800                 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1801             }
1802             else {
1803                 $src_text .= qq|\nextends '$result_base_class';\n|;
1804             }
1805         }
1806         else {
1807              $src_text .= qq|use base '$result_base_class';\n|;
1808         }
1809
1810         $self->_write_classfile($src_class, $src_text);
1811     }
1812
1813     # remove Result dir if downgrading from use_namespaces, and there are no
1814     # files left.
1815     if (my $result_ns = $self->_downgrading_to_load_classes
1816                         || $self->_rewriting_result_namespace) {
1817         my $result_namespace = $self->_result_namespace(
1818             $schema_class,
1819             $result_ns,
1820         );
1821
1822         (my $result_dir = $result_namespace) =~ s{::}{/}g;
1823         $result_dir = $self->dump_directory . '/' . $result_dir;
1824
1825         unless (my @files = glob "$result_dir/*") {
1826             rmdir $result_dir;
1827         }
1828     }
1829
1830     warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
1831 }
1832
1833 sub _sig_comment {
1834     my ($self, $version, $ts) = @_;
1835     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1836          . qq| v| . $version
1837          . q| @ | . $ts
1838          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1839 }
1840
1841 sub _write_classfile {
1842     my ($self, $class, $text, $is_schema) = @_;
1843
1844     my $filename = $self->_get_dump_filename($class);
1845     $self->_ensure_dump_subdirs($class);
1846
1847     if (-f $filename && $self->really_erase_my_files) {
1848         warn "Deleting existing file '$filename' due to "
1849             . "'really_erase_my_files' setting\n" unless $self->quiet;
1850         unlink($filename);
1851     }
1852
1853     my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1854         = $self->_parse_generated_file($filename);
1855
1856     if (! $old_gen && -f $filename) {
1857         croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1858             . " it does not appear to have been generated by Loader"
1859     }
1860
1861     my $custom_content = $old_custom || '';
1862
1863     # Use custom content from a renamed class, the class names in it are
1864     # rewritten below.
1865     if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1866         my $old_filename = $self->_get_dump_filename($renamed_class);
1867
1868         if (-f $old_filename) {
1869             $custom_content = ($self->_parse_generated_file ($old_filename))[4];
1870
1871             unlink $old_filename;
1872         }
1873     }
1874
1875     $custom_content ||= $self->_default_custom_content($is_schema);
1876
1877     # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1878     # If there is already custom content, which does not have the Moose content, add it.
1879     if ($self->use_moose) {
1880
1881         my $non_moose_custom_content = do {
1882             local $self->{use_moose} = 0;
1883             $self->_default_custom_content;
1884         };
1885
1886         if ($custom_content eq $non_moose_custom_content) {
1887             $custom_content = $self->_default_custom_content($is_schema);
1888         }
1889         elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1890             $custom_content .= $self->_default_custom_content($is_schema);
1891         }
1892     }
1893     elsif (defined $self->use_moose && $old_gen) {
1894         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'
1895             if $old_gen =~ /use \s+ MooseX?\b/x;
1896     }
1897
1898     $custom_content = $self->_rewrite_old_classnames($custom_content);
1899
1900     $text .= qq|$_\n|
1901         for @{$self->{_dump_storage}->{$class} || []};
1902
1903     if ($self->filter_generated_code) {
1904         my $filter = $self->filter_generated_code;
1905
1906         if (ref $filter eq 'CODE') {
1907             $text = $filter->(
1908                 ($is_schema ? 'schema' : 'result'),
1909                 $class,
1910                 $text
1911             );
1912         }
1913         else {
1914             my ($fh, $temp_file) = tempfile();
1915
1916             binmode $fh, ':encoding(UTF-8)';
1917             print $fh $text;
1918             close $fh;
1919
1920             open my $out, qq{$filter < "$temp_file"|}
1921                 or croak "Could not open pipe to $filter: $!";
1922
1923             $text = decode('UTF-8', do { local $/; <$out> });
1924
1925             $text =~ s/$CR?$LF/\n/g;
1926
1927             close $out;
1928
1929             my $exit_code = $? >> 8;
1930
1931             unlink $temp_file
1932                 or croak "Could not remove temporary file '$temp_file': $!";
1933
1934             if ($exit_code != 0) {
1935                 croak "filter '$filter' exited non-zero: $exit_code";
1936             }
1937         }
1938         if (not $text or not $text =~ /\bpackage\b/) {
1939             warn("$class skipped due to filter") if $self->debug;
1940             return;
1941         }
1942     }
1943
1944     # Check and see if the dump is in fact different
1945
1946     my $compare_to;
1947     if ($old_md5) {
1948       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1949       if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1950         return unless $self->_upgrading_from && $is_schema;
1951       }
1952     }
1953
1954     $text .= $self->_sig_comment(
1955       $self->version_to_dump,
1956       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1957     );
1958
1959     open(my $fh, '>:encoding(UTF-8)', $filename)
1960         or croak "Cannot open '$filename' for writing: $!";
1961
1962     # Write the top half and its MD5 sum
1963     print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1964
1965     # Write out anything loaded via external partial class file in @INC
1966     print $fh qq|$_\n|
1967         for @{$self->{_ext_storage}->{$class} || []};
1968
1969     # Write out any custom content the user has added
1970     print $fh $custom_content;
1971
1972     close($fh)
1973         or croak "Error closing '$filename': $!";
1974 }
1975
1976 sub _default_moose_custom_content {
1977     my ($self, $is_schema) = @_;
1978
1979     if (not $is_schema) {
1980         return qq|\n__PACKAGE__->meta->make_immutable;|;
1981     }
1982
1983     return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1984 }
1985
1986 sub _default_custom_content {
1987     my ($self, $is_schema) = @_;
1988     my $default = qq|\n\n# You can replace this text with custom|
1989          . qq| code or comments, and it will be preserved on regeneration|;
1990     if ($self->use_moose) {
1991         $default .= $self->_default_moose_custom_content($is_schema);
1992     }
1993     $default .= qq|\n1;\n|;
1994     return $default;
1995 }
1996
1997 sub _parse_generated_file {
1998     my ($self, $fn) = @_;
1999
2000     return unless -f $fn;
2001
2002     open(my $fh, '<:encoding(UTF-8)', $fn)
2003         or croak "Cannot open '$fn' for reading: $!";
2004
2005     my $mark_re =
2006         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
2007
2008     my ($md5, $ts, $ver, $gen);
2009     while(<$fh>) {
2010         if(/$mark_re/) {
2011             my $pre_md5 = $1;
2012             $md5 = $2;
2013
2014             # Pull out the version and timestamp from the line above
2015             ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m;
2016
2017             $gen .= $pre_md5;
2018             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"
2019                 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
2020
2021             last;
2022         }
2023         else {
2024             $gen .= $_;
2025         }
2026     }
2027
2028     my $custom = do { local $/; <$fh> }
2029         if $md5;
2030
2031     $custom ||= '';
2032     $custom =~ s/$CRLF|$LF/\n/g;
2033
2034     close $fh;
2035
2036     return ($gen, $md5, $ver, $ts, $custom);
2037 }
2038
2039 sub _use {
2040     my $self = shift;
2041     my $target = shift;
2042
2043     foreach (@_) {
2044         warn "$target: use $_;" if $self->debug;
2045         $self->_raw_stmt($target, "use $_;");
2046     }
2047 }
2048
2049 sub _inject {
2050     my $self = shift;
2051     my $target = shift;
2052
2053     my $blist = join(q{ }, @_);
2054
2055     return unless $blist;
2056
2057     warn "$target: use base qw/$blist/;" if $self->debug;
2058     $self->_raw_stmt($target, "use base qw/$blist/;");
2059 }
2060
2061 sub _with {
2062     my $self = shift;
2063     my $target = shift;
2064
2065     my $rlist = join(q{, }, map { qq{'$_'} } @_);
2066
2067     return unless $rlist;
2068
2069     warn "$target: with $rlist;" if $self->debug;
2070     $self->_raw_stmt($target, "\nwith $rlist;");
2071 }
2072
2073 sub _result_namespace {
2074     my ($self, $schema_class, $ns) = @_;
2075     my @result_namespace;
2076
2077     $ns = $ns->[0] if ref $ns;
2078
2079     if ($ns =~ /^\+(.*)/) {
2080         # Fully qualified namespace
2081         @result_namespace = ($1)
2082     }
2083     else {
2084         # Relative namespace
2085         @result_namespace = ($schema_class, $ns);
2086     }
2087
2088     return wantarray ? @result_namespace : join '::', @result_namespace;
2089 }
2090
2091 # Create class with applicable bases, setup monikers, etc
2092 sub _make_src_class {
2093     my ($self, $table) = @_;
2094
2095     my $schema       = $self->schema;
2096     my $schema_class = $self->schema_class;
2097
2098     my $table_moniker = $self->monikers->{$table->sql_name};
2099     my @result_namespace = ($schema_class);
2100     if ($self->use_namespaces) {
2101         my $result_namespace = $self->result_namespace || 'Result';
2102         @result_namespace = $self->_result_namespace(
2103             $schema_class,
2104             $result_namespace,
2105         );
2106     }
2107     my $table_class = join(q{::}, @result_namespace, $table_moniker);
2108
2109     if ((my $upgrading_v = $self->_upgrading_from)
2110             || $self->_rewriting) {
2111         local $self->naming->{monikers} = $upgrading_v
2112             if $upgrading_v;
2113
2114         my @result_namespace = @result_namespace;
2115         if ($self->_upgrading_from_load_classes) {
2116             @result_namespace = ($schema_class);
2117         }
2118         elsif (my $ns = $self->_downgrading_to_load_classes) {
2119             @result_namespace = $self->_result_namespace(
2120                 $schema_class,
2121                 $ns,
2122             );
2123         }
2124         elsif ($ns = $self->_rewriting_result_namespace) {
2125             @result_namespace = $self->_result_namespace(
2126                 $schema_class,
2127                 $ns,
2128             );
2129         }
2130
2131         my $old_table_moniker = do {
2132             local $self->naming->{monikers} = $upgrading_v;
2133             $self->_table2moniker($table);
2134         };
2135
2136         my $old_class = join(q{::}, @result_namespace, $old_table_moniker);
2137
2138         $self->_upgrading_classes->{$table_class} = $old_class
2139             unless $table_class eq $old_class;
2140     }
2141
2142     $self->classes->{$table->sql_name}  = $table_class;
2143     $self->moniker_to_table->{$table_moniker} = $table;
2144     $self->class_to_table->{$table_class} = $table;
2145
2146     $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
2147
2148     $self->_use   ($table_class, @{$self->additional_classes});
2149
2150     $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
2151
2152     $self->_inject($table_class, @{$self->left_base_classes});
2153
2154     my @components = @{ $self->components || [] };
2155
2156     push @components, @{ $self->result_components_map->{$table_moniker} }
2157         if exists $self->result_components_map->{$table_moniker};
2158
2159     my @fq_components = @components;
2160     foreach my $component (@fq_components) {
2161         if ($component !~ s/^\+//) {
2162             $component = "DBIx::Class::$component";
2163         }
2164     }
2165
2166     $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
2167
2168     $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
2169
2170     $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
2171
2172     $self->_inject($table_class, @{$self->additional_base_classes});
2173 }
2174
2175 sub _is_result_class_method {
2176     my ($self, $name, $table) = @_;
2177
2178     my $table_moniker = $table ? $self->monikers->{$table->sql_name} : '';
2179
2180     $self->_result_class_methods({})
2181         if not defined $self->_result_class_methods;
2182
2183     if (not exists $self->_result_class_methods->{$table_moniker}) {
2184         my (@methods, %methods);
2185         my $base       = $self->result_base_class || 'DBIx::Class::Core';
2186
2187         my @components = @{ $self->components || [] };
2188
2189         push @components, @{ $self->result_components_map->{$table_moniker} }
2190             if exists $self->result_components_map->{$table_moniker};
2191
2192         for my $c (@components) {
2193             $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
2194         }
2195
2196         my @roles = @{ $self->result_roles || [] };
2197
2198         push @roles, @{ $self->result_roles_map->{$table_moniker} }
2199             if exists $self->result_roles_map->{$table_moniker};
2200
2201         for my $class ($base, @components,
2202                        ($self->use_moose ? 'Moose::Object' : ()), @roles) {
2203             $self->ensure_class_loaded($class);
2204
2205             push @methods, @{ Class::Inspector->methods($class) || [] };
2206         }
2207
2208         push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
2209
2210         @methods{@methods} = ();
2211
2212         $self->_result_class_methods->{$table_moniker} = \%methods;
2213     }
2214     my $result_methods = $self->_result_class_methods->{$table_moniker};
2215
2216     return exists $result_methods->{$name};
2217 }
2218
2219 sub _resolve_col_accessor_collisions {
2220     my ($self, $table, $col_info) = @_;
2221
2222     while (my ($col, $info) = each %$col_info) {
2223         my $accessor = $info->{accessor} || $col;
2224
2225         next if $accessor eq 'id'; # special case (very common column)
2226
2227         if ($self->_is_result_class_method($accessor, $table)) {
2228             my $mapped = 0;
2229
2230             if (my $map = $self->col_collision_map) {
2231                 for my $re (keys %$map) {
2232                     if (my @matches = $col =~ /$re/) {
2233                         $info->{accessor} = sprintf $map->{$re}, @matches;
2234                         $mapped = 1;
2235                     }
2236                 }
2237             }
2238
2239             if (not $mapped) {
2240                 warn <<"EOF";
2241 Column '$col' in table '$table' collides with an inherited method.
2242 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
2243 EOF
2244                 $info->{accessor} = undef;
2245             }
2246         }
2247     }
2248 }
2249
2250 # use the same logic to run moniker_map, col_accessor_map
2251 sub _run_user_map {
2252     my ( $self, $map, $default_code, $ident, @extra ) = @_;
2253
2254     my $default_ident = $default_code->( $ident, @extra );
2255     my $new_ident;
2256     if( $map && ref $map eq 'HASH' ) {
2257         $new_ident = $map->{ $ident };
2258     }
2259     elsif( $map && ref $map eq 'CODE' ) {
2260         $new_ident = $map->( $ident, $default_ident, @extra );
2261     }
2262
2263     $new_ident ||= $default_ident;
2264
2265     return $new_ident;
2266 }
2267
2268 sub _default_column_accessor_name {
2269     my ( $self, $column_name ) = @_;
2270
2271     my $preserve = ($self->naming->{column_accessors}||'') eq 'preserve';
2272
2273     my $v = $self->_get_naming_v('column_accessors');
2274
2275     my $accessor_name = $preserve ?
2276         $self->_to_identifier('column_accessors', $column_name) # assume CamelCase
2277         :
2278         $self->_to_identifier('column_accessors', $column_name, '_');
2279
2280     $accessor_name =~ s/\W+/_/g; # only if naming < v8, otherwise to_identifier
2281                                  # takes care of it
2282
2283     if ($preserve) {
2284         return $accessor_name;
2285     }
2286     elsif ($v < 7 || (not $self->preserve_case)) {
2287         # older naming just lc'd the col accessor and that's all.
2288         return lc $accessor_name;
2289     }
2290
2291     return join '_', map lc, split_name $column_name, $v;
2292 }
2293
2294 sub _make_column_accessor_name {
2295     my ($self, $column_name, $column_context_info ) = @_;
2296
2297     my $accessor = $self->_run_user_map(
2298         $self->col_accessor_map,
2299         sub { $self->_default_column_accessor_name( shift ) },
2300         $column_name,
2301         $column_context_info,
2302        );
2303
2304     return $accessor;
2305 }
2306
2307 # Set up metadata (cols, pks, etc)
2308 sub _setup_src_meta {
2309     my ($self, $table) = @_;
2310
2311     my $schema       = $self->schema;
2312     my $schema_class = $self->schema_class;
2313
2314     my $table_class   = $self->classes->{$table->sql_name};
2315     my $table_moniker = $self->monikers->{$table->sql_name};
2316
2317     $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
2318
2319     my $cols     = $self->_table_columns($table);
2320     my $col_info = $self->__columns_info_for($table);
2321
2322     ### generate all the column accessor names
2323     while (my ($col, $info) = each %$col_info) {
2324         # hashref of other info that could be used by
2325         # user-defined accessor map functions
2326         my $context = {
2327             table_class     => $table_class,
2328             table_moniker   => $table_moniker,
2329             table_name      => $table,
2330             full_table_name => $table->dbic_name,
2331             schema_class    => $schema_class,
2332             column_info     => $info,
2333         };
2334
2335         $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2336     }
2337
2338     $self->_resolve_col_accessor_collisions($table, $col_info);
2339
2340     # prune any redundant accessor names
2341     while (my ($col, $info) = each %$col_info) {
2342         no warnings 'uninitialized';
2343         delete $info->{accessor} if $info->{accessor} eq $col;
2344     }
2345
2346     my $fks = $self->_table_fk_info($table);
2347
2348     foreach my $fkdef (@$fks) {
2349         for my $col (@{ $fkdef->{local_columns} }) {
2350             $col_info->{$col}{is_foreign_key} = 1;
2351         }
2352     }
2353
2354     my $pks = $self->_table_pk_info($table) || [];
2355
2356     my %uniq_tag; # used to eliminate duplicate uniqs
2357
2358     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2359
2360     my $uniqs = $self->_table_uniq_info($table) || [];
2361     my @uniqs;
2362
2363     foreach my $uniq (@$uniqs) {
2364         my ($name, $cols) = @$uniq;
2365         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2366         push @uniqs, [$name, $cols];
2367     }
2368
2369     my @non_nullable_uniqs = grep {
2370         all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2371     } @uniqs;
2372
2373     if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2374         my @by_colnum = sort { $b->[0] <=> $a->[0] }
2375             map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2376
2377         if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2378             my @keys = map $_->[1], @by_colnum;
2379
2380             my $pk = $keys[0];
2381
2382             # remove the uniq from list
2383             @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2384
2385             $pks = $pk->[1];
2386         }
2387     }
2388
2389     foreach my $pkcol (@$pks) {
2390         $col_info->{$pkcol}{is_nullable} = 0;
2391     }
2392
2393     $self->_dbic_stmt(
2394         $table_class,
2395         'add_columns',
2396         map { $_, ($col_info->{$_}||{}) } @$cols
2397     );
2398
2399     $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2400         if @$pks;
2401
2402     # Sort unique constraints by constraint name for repeatable results (rels
2403     # are sorted as well elsewhere.)
2404     @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs;
2405
2406     foreach my $uniq (@uniqs) {
2407         my ($name, $cols) = @$uniq;
2408         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2409     }
2410 }
2411
2412 sub __columns_info_for {
2413     my ($self, $table) = @_;
2414
2415     my $result = $self->_columns_info_for($table);
2416
2417     while (my ($col, $info) = each %$result) {
2418         $info = { %$info, %{ $self->_custom_column_info  ($table, $col, $info) } };
2419         $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2420
2421         $result->{$col} = $info;
2422     }
2423
2424     return $result;
2425 }
2426
2427 =head2 tables
2428
2429 Returns a sorted list of loaded tables, using the original database table
2430 names.
2431
2432 =cut
2433
2434 sub tables {
2435     my $self = shift;
2436
2437     return values %{$self->_tables};
2438 }
2439
2440 sub _get_naming_v {
2441     my ($self, $naming_key) = @_;
2442
2443     my $v;
2444
2445     if (($self->naming->{$naming_key}||'') =~ /^v(\d+)\z/) {
2446         $v = $1;
2447     }
2448     else {
2449         ($v) = $CURRENT_V =~ /^v(\d+)\z/;
2450     }
2451
2452     return $v;
2453 }
2454
2455 sub _to_identifier {
2456     my ($self, $naming_key, $name, $sep_char, $force) = @_;
2457
2458     my $v = $self->_get_naming_v($naming_key);
2459
2460     my $to_identifier = $self->naming->{force_ascii} ?
2461         \&String::ToIdentifier::EN::to_identifier
2462         : \&String::ToIdentifier::EN::Unicode::to_identifier;
2463
2464     return $v >= 8 || $force ? $to_identifier->($name, $sep_char) : $name;
2465 }
2466
2467 # Make a moniker from a table
2468 sub _default_table2moniker {
2469     my ($self, $table) = @_;
2470
2471     my $v = $self->_get_naming_v('monikers');
2472
2473     my @name_parts = map $table->$_, @{ $self->moniker_parts };
2474
2475     my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
2476
2477     my @all_parts;
2478
2479     foreach my $i (0 .. $#name_parts) {
2480         my $part = $name_parts[$i];
2481
2482         if ($i != $name_idx || $v >= 8) {
2483             $part = $self->_to_identifier('monikers', $part, '_', 1);
2484         }
2485
2486         if ($i == $name_idx && $v == 5) {
2487             $part = Lingua::EN::Inflect::Number::to_S($part);
2488         }
2489
2490         my @part_parts = map lc, $v > 6 ?
2491             # use v8 semantics for all moniker parts except name
2492             ($i == $name_idx ? split_name $part, $v : split_name $part)
2493             : split /[\W_]+/, $part;
2494
2495         if ($i == $name_idx && $v >= 6) {
2496             my $as_phrase = join ' ', @part_parts;
2497
2498             my $inflected = ($self->naming->{monikers}||'') eq 'plural' ?
2499                 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2500                 :
2501                 ($self->naming->{monikers}||'') eq 'preserve' ?
2502                     $as_phrase
2503                     :
2504                     Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2505
2506             @part_parts = split /\s+/, $inflected;
2507         }
2508
2509         push @all_parts, map ucfirst, @part_parts;
2510     }
2511
2512     return join '', @all_parts;
2513 }
2514
2515 sub _table2moniker {
2516     my ( $self, $table ) = @_;
2517
2518     $self->_run_user_map(
2519         $self->moniker_map,
2520         sub { $self->_default_table2moniker( shift ) },
2521         $table
2522        );
2523 }
2524
2525 sub _load_relationships {
2526     my ($self, $tables) = @_;
2527
2528     my @tables;
2529
2530     foreach my $table (@$tables) {
2531         my $local_moniker = $self->monikers->{$table->sql_name};
2532
2533         my $tbl_fk_info = $self->_table_fk_info($table);
2534
2535         foreach my $fkdef (@$tbl_fk_info) {
2536             $fkdef->{local_table}   = $table;
2537             $fkdef->{local_moniker} = $local_moniker;
2538             $fkdef->{remote_source} =
2539                 $self->monikers->{$fkdef->{remote_table}->sql_name};
2540         }
2541         my $tbl_uniq_info = $self->_table_uniq_info($table);
2542
2543         push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2544     }
2545
2546     my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2547
2548     foreach my $src_class (sort keys %$rel_stmts) {
2549         # sort by rel name
2550         my @src_stmts = map $_->[2],
2551             sort {
2552                 $a->[0] <=> $b->[0]
2553                 ||
2554                 $a->[1] cmp $b->[1]
2555             } map [
2556                 ($_->{method} eq 'many_to_many' ? 1 : 0),
2557                 $_->{args}[0],
2558                 $_,
2559             ], @{ $rel_stmts->{$src_class} };
2560
2561         foreach my $stmt (@src_stmts) {
2562             $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2563         }
2564     }
2565 }
2566
2567 sub _load_roles {
2568     my ($self, $table) = @_;
2569
2570     my $table_moniker = $self->monikers->{$table->sql_name};
2571     my $table_class   = $self->classes->{$table->sql_name};
2572
2573     my @roles = @{ $self->result_roles || [] };
2574     push @roles, @{ $self->result_roles_map->{$table_moniker} }
2575         if exists $self->result_roles_map->{$table_moniker};
2576
2577     if (@roles) {
2578         $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2579
2580         $self->_with($table_class, @roles);
2581     }
2582 }
2583
2584 # Overload these in driver class:
2585
2586 # Returns an arrayref of column names
2587 sub _table_columns { croak "ABSTRACT METHOD" }
2588
2589 # Returns arrayref of pk col names
2590 sub _table_pk_info { croak "ABSTRACT METHOD" }
2591
2592 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2593 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2594
2595 # Returns an arrayref of foreign key constraints, each
2596 #   being a hashref with 3 keys:
2597 #   local_columns (arrayref), remote_columns (arrayref), remote_table
2598 sub _table_fk_info { croak "ABSTRACT METHOD" }
2599
2600 # Returns an array of lower case table names
2601 sub _tables_list { croak "ABSTRACT METHOD" }
2602
2603 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2604 sub _dbic_stmt {
2605     my $self   = shift;
2606     my $class  = shift;
2607     my $method = shift;
2608
2609     # generate the pod for this statement, storing it with $self->_pod
2610     $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2611
2612     my $args = dump(@_);
2613     $args = '(' . $args . ')' if @_ < 2;
2614     my $stmt = $method . $args . q{;};
2615
2616     warn qq|$class\->$stmt\n| if $self->debug;
2617     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2618     return;
2619 }
2620
2621 sub _make_pod_heading {
2622     my ($self, $class) = @_;
2623
2624     return '' if not $self->generate_pod;
2625
2626     my $table = $self->class_to_table->{$class};
2627     my $pod;
2628
2629     my $pcm = $self->pod_comment_mode;
2630     my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2631     $comment = $self->__table_comment($table);
2632     $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2633     $comment_in_name   = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2634     $comment_in_desc   = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2635
2636     $pod .= "=head1 NAME\n\n";
2637
2638     my $table_descr = $class;
2639     $table_descr .= " - " . $comment if $comment and $comment_in_name;
2640
2641     $pod .= "$table_descr\n\n";
2642
2643     if ($comment and $comment_in_desc) {
2644         $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2645     }
2646     $pod .= "=cut\n\n";
2647
2648     return $pod;
2649 }
2650
2651 # generates the accompanying pod for a DBIC class method statement,
2652 # storing it with $self->_pod
2653 sub _make_pod {
2654     my $self   = shift;
2655     my $class  = shift;
2656     my $method = shift;
2657
2658     if ($method eq 'table') {
2659         my $table = $_[0];
2660         $table = $$table if ref $table eq 'SCALAR';
2661         $self->_pod($class, "=head1 TABLE: C<$table>");
2662         $self->_pod_cut($class);
2663     }
2664     elsif ( $method eq 'add_columns' ) {
2665         $self->_pod( $class, "=head1 ACCESSORS" );
2666         my $col_counter = 0;
2667         my @cols = @_;
2668         while( my ($name,$attrs) = splice @cols,0,2 ) {
2669             $col_counter++;
2670             $self->_pod( $class, '=head2 ' . $name  );
2671             $self->_pod( $class,
2672                 join "\n", map {
2673                     my $s = $attrs->{$_};
2674                     $s = !defined $s          ? 'undef'             :
2675                         length($s) == 0       ? '(empty string)'    :
2676                         ref($s) eq 'SCALAR'   ? $$s                 :
2677                         ref($s)               ? dumper_squashed $s  :
2678                         looks_like_number($s) ? $s                  : qq{'$s'};
2679
2680                     "  $_: $s"
2681                  } sort keys %$attrs,
2682             );
2683             if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2684                 $self->_pod( $class, $comment );
2685             }
2686         }
2687         $self->_pod_cut( $class );
2688     } elsif ( $method =~ /^(?:belongs_to|has_many|might_have)\z/ ) {
2689         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2690         my ( $accessor, $rel_class ) = @_;
2691         $self->_pod( $class, "=head2 $accessor" );
2692         $self->_pod( $class, 'Type: ' . $method );
2693         $self->_pod( $class, "Related object: L<$rel_class>" );
2694         $self->_pod_cut( $class );
2695         $self->{_relations_started} { $class } = 1;
2696     } elsif ( $method eq 'many_to_many' ) {
2697         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2698         my ( $accessor, $rel1, $rel2 ) = @_;
2699         $self->_pod( $class, "=head2 $accessor" );
2700         $self->_pod( $class, 'Type: many_to_many' );
2701         $self->_pod( $class, "Composing rels: L</$rel1> -> $rel2" );
2702         $self->_pod_cut( $class );
2703         $self->{_relations_started} { $class } = 1;
2704     }
2705     elsif ($method eq 'add_unique_constraint') {
2706         $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2707             unless $self->{_uniqs_started}{$class};
2708
2709         my ($name, $cols) = @_;
2710
2711         $self->_pod($class, "=head2 C<$name>");
2712         $self->_pod($class, '=over 4');
2713
2714         foreach my $col (@$cols) {
2715             $self->_pod($class, "=item \* L</$col>");
2716         }
2717
2718         $self->_pod($class, '=back');
2719         $self->_pod_cut($class);
2720
2721         $self->{_uniqs_started}{$class} = 1;
2722     }
2723     elsif ($method eq 'set_primary_key') {
2724         $self->_pod($class, "=head1 PRIMARY KEY");
2725         $self->_pod($class, '=over 4');
2726
2727         foreach my $col (@_) {
2728             $self->_pod($class, "=item \* L</$col>");
2729         }
2730
2731         $self->_pod($class, '=back');
2732         $self->_pod_cut($class);
2733     }
2734 }
2735
2736 sub _pod_class_list {
2737     my ($self, $class, $title, @classes) = @_;
2738
2739     return unless @classes && $self->generate_pod;
2740
2741     $self->_pod($class, "=head1 $title");
2742     $self->_pod($class, '=over 4');
2743
2744     foreach my $link (@classes) {
2745         $self->_pod($class, "=item * L<$link>");
2746     }
2747
2748     $self->_pod($class, '=back');
2749     $self->_pod_cut($class);
2750 }
2751
2752 sub _base_class_pod {
2753     my ($self, $base_class) = @_;
2754
2755     return '' unless $self->generate_pod;
2756
2757     return <<"EOF"
2758 =head1 BASE CLASS: L<$base_class>
2759
2760 =cut
2761
2762 EOF
2763 }
2764
2765 sub _filter_comment {
2766     my ($self, $txt) = @_;
2767
2768     $txt = '' if not defined $txt;
2769
2770     $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2771
2772     return $txt;
2773 }
2774
2775 sub __table_comment {
2776     my $self = shift;
2777
2778     if (my $code = $self->can('_table_comment')) {
2779         return $self->_filter_comment($self->$code(@_));
2780     }
2781
2782     return '';
2783 }
2784
2785 sub __column_comment {
2786     my $self = shift;
2787
2788     if (my $code = $self->can('_column_comment')) {
2789         return $self->_filter_comment($self->$code(@_));
2790     }
2791
2792     return '';
2793 }
2794
2795 # Stores a POD documentation
2796 sub _pod {
2797     my ($self, $class, $stmt) = @_;
2798     $self->_raw_stmt( $class, "\n" . $stmt  );
2799 }
2800
2801 sub _pod_cut {
2802     my ($self, $class ) = @_;
2803     $self->_raw_stmt( $class, "\n=cut\n" );
2804 }
2805
2806 # Store a raw source line for a class (for dumping purposes)
2807 sub _raw_stmt {
2808     my ($self, $class, $stmt) = @_;
2809     push(@{$self->{_dump_storage}->{$class}}, $stmt);
2810 }
2811
2812 # Like above, but separately for the externally loaded stuff
2813 sub _ext_stmt {
2814     my ($self, $class, $stmt) = @_;
2815     push(@{$self->{_ext_storage}->{$class}}, $stmt);
2816 }
2817
2818 sub _custom_column_info {
2819     my ( $self, $table_name, $column_name, $column_info ) = @_;
2820
2821     if (my $code = $self->custom_column_info) {
2822         return $code->($table_name, $column_name, $column_info) || {};
2823     }
2824     return {};
2825 }
2826
2827 sub _datetime_column_info {
2828     my ( $self, $table_name, $column_name, $column_info ) = @_;
2829     my $result = {};
2830     my $type = $column_info->{data_type} || '';
2831     if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2832             or ($type =~ /date|timestamp/i)) {
2833         $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2834         $result->{locale}   = $self->datetime_locale   if $self->datetime_locale;
2835     }
2836     return $result;
2837 }
2838
2839 sub _lc {
2840     my ($self, $name) = @_;
2841
2842     return $self->preserve_case ? $name : lc($name);
2843 }
2844
2845 sub _uc {
2846     my ($self, $name) = @_;
2847
2848     return $self->preserve_case ? $name : uc($name);
2849 }
2850
2851 sub _remove_table {
2852     my ($self, $table) = @_;
2853
2854     try {
2855         my $schema = $self->schema;
2856         # in older DBIC it's a private method
2857         my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2858         $schema->$unregister(delete $self->monikers->{$table->sql_name});
2859         delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}};
2860         delete $self->_tables->{$table->sql_name};
2861     };
2862 }
2863
2864 # remove the dump dir from @INC on destruction
2865 sub DESTROY {
2866     my $self = shift;
2867
2868     @INC = grep $_ ne $self->dump_directory, @INC;
2869 }
2870
2871 =head2 monikers
2872
2873 Returns a hashref of loaded table to moniker mappings.  There will
2874 be two entries for each table, the original name and the "normalized"
2875 name, in the case that the two are different (such as databases
2876 that like uppercase table names, or preserve your original mixed-case
2877 definitions, or what-have-you).
2878
2879 =head2 classes
2880
2881 Returns a hashref of table to class mappings.  In some cases it will
2882 contain multiple entries per table for the original and normalized table
2883 names, as above in L</monikers>.
2884
2885 =head1 NON-ENGLISH DATABASES
2886
2887 If you use the loader on a database with table and column names in a language
2888 other than English, you will want to turn off the English language specific
2889 heuristics.
2890
2891 To do so, use something like this in your loader options:
2892
2893     naming           => { monikers => 'v4' },
2894     inflect_singular => sub { "$_[0]_rel" },
2895     inflect_plural   => sub { "$_[0]_rel" },
2896
2897 =head1 COLUMN ACCESSOR COLLISIONS
2898
2899 Occasionally you may have a column name that collides with a perl method, such
2900 as C<can>. In such cases, the default action is to set the C<accessor> of the
2901 column spec to C<undef>.
2902
2903 You can then name the accessor yourself by placing code such as the following
2904 below the md5:
2905
2906     __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2907
2908 Another option is to use the L</col_collision_map> option.
2909
2910 =head1 RELATIONSHIP NAME COLLISIONS
2911
2912 In very rare cases, you may get a collision between a generated relationship
2913 name and a method in your Result class, for example if you have a foreign key
2914 called C<belongs_to>.
2915
2916 This is a problem because relationship names are also relationship accessor
2917 methods in L<DBIx::Class>.
2918
2919 The default behavior is to append C<_rel> to the relationship name and print
2920 out a warning that refers to this text.
2921
2922 You can also control the renaming with the L</rel_collision_map> option.
2923
2924 =head1 SEE ALSO
2925
2926 L<DBIx::Class::Schema::Loader>, L<dbicdump>
2927
2928 =head1 AUTHOR
2929
2930 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2931
2932 =head1 LICENSE
2933
2934 This library is free software; you can redistribute it and/or modify it under
2935 the same terms as Perl itself.
2936
2937 =cut
2938
2939 1;
2940 # vim:et sts=4 sw=4 tw=0: