lib/DBIx/Class/Schema/Loader/Base.pm

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