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