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