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