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