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