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