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