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