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