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