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 sub _quote {
1849     my ($self, $identifier) = @_;
1850
1851     my $qt = $self->schema->storage->sql_maker->quote_char;
1852
1853     if (ref $qt) {
1854         return $qt->[0] . $identifier . $qt->[1];
1855     }
1856
1857     return "${qt}${identifier}${qt}";
1858 }
1859
1860 # Set up metadata (cols, pks, etc)
1861 sub _setup_src_meta {
1862     my ($self, $table) = @_;
1863
1864     my $schema       = $self->schema;
1865     my $schema_class = $self->schema_class;
1866
1867     my $table_class   = $self->classes->{$table};
1868     my $table_moniker = $self->monikers->{$table};
1869
1870     my $table_name = $table;
1871
1872     my $sql_maker  = $self->schema->storage->sql_maker;
1873     my $name_sep   = $sql_maker->name_sep;
1874
1875     if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1876         $table_name = \ $self->_quote($table_name);
1877     }
1878
1879     my $full_table_name = ($self->qualify_objects ?
1880         ($self->_quote($self->db_schema) . '.') : '')
1881         . (ref $table_name ? $$table_name : $table_name);
1882
1883     # be careful to not create refs Data::Dump can "optimize"
1884     $full_table_name = \do {"".$full_table_name} if ref $table_name;
1885
1886     $self->_dbic_stmt($table_class, 'table', $full_table_name);
1887
1888     my $cols     = $self->_table_columns($table);
1889     my $col_info = $self->__columns_info_for($table);
1890
1891     ### generate all the column accessor names
1892     while (my ($col, $info) = each %$col_info) {
1893         # hashref of other info that could be used by
1894         # user-defined accessor map functions
1895         my $context = {
1896             table_class     => $table_class,
1897             table_moniker   => $table_moniker,
1898             table_name      => $table_name,
1899             full_table_name => $full_table_name,
1900             schema_class    => $schema_class,
1901             column_info     => $info,
1902         };
1903
1904         $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
1905     }
1906
1907     $self->_resolve_col_accessor_collisions($table, $col_info);
1908
1909     # prune any redundant accessor names
1910     while (my ($col, $info) = each %$col_info) {
1911         no warnings 'uninitialized';
1912         delete $info->{accessor} if $info->{accessor} eq $col;
1913     }
1914
1915     my $fks = $self->_table_fk_info($table);
1916
1917     foreach my $fkdef (@$fks) {
1918         for my $col (@{ $fkdef->{local_columns} }) {
1919             $col_info->{$col}{is_foreign_key} = 1;
1920         }
1921     }
1922
1923     my $pks = $self->_table_pk_info($table) || [];
1924
1925     foreach my $pkcol (@$pks) {
1926         $col_info->{$pkcol}{is_nullable} = 0;
1927     }
1928
1929     $self->_dbic_stmt(
1930         $table_class,
1931         'add_columns',
1932         map { $_, ($col_info->{$_}||{}) } @$cols
1933     );
1934
1935     my %uniq_tag; # used to eliminate duplicate uniqs
1936
1937     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1938           : carp("$table has no primary key");
1939     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1940
1941     my $uniqs = $self->_table_uniq_info($table) || [];
1942     for (@$uniqs) {
1943         my ($name, $cols) = @$_;
1944         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1945         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1946     }
1947
1948 }
1949
1950 sub __columns_info_for {
1951     my ($self, $table) = @_;
1952
1953     my $result = $self->_columns_info_for($table);
1954
1955     while (my ($col, $info) = each %$result) {
1956         $info = { %$info, %{ $self->_custom_column_info  ($table, $col, $info) } };
1957         $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1958
1959         $result->{$col} = $info;
1960     }
1961
1962     return $result;
1963 }
1964
1965 =head2 tables
1966
1967 Returns a sorted list of loaded tables, using the original database table
1968 names.
1969
1970 =cut
1971
1972 sub tables {
1973     my $self = shift;
1974
1975     return keys %{$self->_tables};
1976 }
1977
1978 # Make a moniker from a table
1979 sub _default_table2moniker {
1980     no warnings 'uninitialized';
1981     my ($self, $table) = @_;
1982
1983     if ($self->naming->{monikers} eq 'v4') {
1984         return join '', map ucfirst, split /[\W_]+/, lc $table;
1985     }
1986     elsif ($self->naming->{monikers} eq 'v5') {
1987         return join '', map ucfirst, split /[\W_]+/,
1988             Lingua::EN::Inflect::Number::to_S(lc $table);
1989     }
1990     elsif ($self->naming->{monikers} eq 'v6') {
1991         (my $as_phrase = lc $table) =~ s/_+/ /g;
1992         my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1993
1994         return join '', map ucfirst, split /\W+/, $inflected;
1995     }
1996
1997     my @words = map lc, split_name $table;
1998     my $as_phrase = join ' ', @words;
1999
2000     my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2001
2002     return join '', map ucfirst, split /\W+/, $inflected;
2003 }
2004
2005 sub _table2moniker {
2006     my ( $self, $table ) = @_;
2007
2008     $self->_run_user_map(
2009         $self->moniker_map,
2010         sub { $self->_default_table2moniker( shift ) },
2011         $table
2012        );
2013 }
2014
2015 sub _load_relationships {
2016     my ($self, $tables) = @_;
2017
2018     my @tables;
2019
2020     foreach my $table (@$tables) {
2021         my $tbl_fk_info = $self->_table_fk_info($table);
2022         foreach my $fkdef (@$tbl_fk_info) {
2023             $fkdef->{remote_source} =
2024                 $self->monikers->{delete $fkdef->{remote_table}};
2025         }
2026         my $tbl_uniq_info = $self->_table_uniq_info($table);
2027
2028         my $local_moniker = $self->monikers->{$table};
2029
2030         push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2031     }
2032
2033     my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2034
2035     foreach my $src_class (sort keys %$rel_stmts) {
2036         my $src_stmts = $rel_stmts->{$src_class};
2037         foreach my $stmt (@$src_stmts) {
2038             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
2039         }
2040     }
2041 }
2042
2043 sub _load_roles {
2044     my ($self, $table) = @_;
2045
2046     my $table_moniker = $self->monikers->{$table};
2047     my $table_class   = $self->classes->{$table};
2048
2049     my @roles = @{ $self->result_roles || [] };
2050     push @roles, @{ $self->result_roles_map->{$table_moniker} }
2051         if exists $self->result_roles_map->{$table_moniker};
2052
2053     if (@roles) {
2054         $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2055
2056         $self->_with($table_class, @roles);
2057     }
2058 }
2059
2060 # Overload these in driver class:
2061
2062 # Returns an arrayref of column names
2063 sub _table_columns { croak "ABSTRACT METHOD" }
2064
2065 # Returns arrayref of pk col names
2066 sub _table_pk_info { croak "ABSTRACT METHOD" }
2067
2068 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2069 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2070
2071 # Returns an arrayref of foreign key constraints, each
2072 #   being a hashref with 3 keys:
2073 #   local_columns (arrayref), remote_columns (arrayref), remote_table
2074 sub _table_fk_info { croak "ABSTRACT METHOD" }
2075
2076 # Returns an array of lower case table names
2077 sub _tables_list { croak "ABSTRACT METHOD" }
2078
2079 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2080 sub _dbic_stmt {
2081     my $self   = shift;
2082     my $class  = shift;
2083     my $method = shift;
2084
2085     # generate the pod for this statement, storing it with $self->_pod
2086     $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2087
2088     my $args = dump(@_);
2089     $args = '(' . $args . ')' if @_ < 2;
2090     my $stmt = $method . $args . q{;};
2091
2092     warn qq|$class\->$stmt\n| if $self->debug;
2093     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2094     return;
2095 }
2096
2097 # generates the accompanying pod for a DBIC class method statement,
2098 # storing it with $self->_pod
2099 sub _make_pod {
2100     my $self   = shift;
2101     my $class  = shift;
2102     my $method = shift;
2103
2104     if ( $method eq 'table' ) {
2105         my ($table) = @_;
2106         my $pcm = $self->pod_comment_mode;
2107         my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2108         $comment = $self->__table_comment($table);
2109         $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2110         $comment_in_name   = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2111         $comment_in_desc   = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2112         $self->_pod( $class, "=head1 NAME" );
2113         my $table_descr = $class;
2114         $table_descr .= " - " . $comment if $comment and $comment_in_name;
2115         $self->{_class2table}{ $class } = $table;
2116         $self->_pod( $class, $table_descr );
2117         if ($comment and $comment_in_desc) {
2118             $self->_pod( $class, "=head1 DESCRIPTION" );
2119             $self->_pod( $class, $comment );
2120         }
2121         $self->_pod_cut( $class );
2122     } elsif ( $method eq 'add_columns' ) {
2123         $self->_pod( $class, "=head1 ACCESSORS" );
2124         my $col_counter = 0;
2125         my @cols = @_;
2126         while( my ($name,$attrs) = splice @cols,0,2 ) {
2127             $col_counter++;
2128             $self->_pod( $class, '=head2 ' . $name  );
2129             $self->_pod( $class,
2130                 join "\n", map {
2131                     my $s = $attrs->{$_};
2132                     $s = !defined $s          ? 'undef'             :
2133                         length($s) == 0       ? '(empty string)'    :
2134                         ref($s) eq 'SCALAR'   ? $$s                 :
2135                         ref($s)               ? dumper_squashed $s  :
2136                         looks_like_number($s) ? $s                  : qq{'$s'};
2137
2138                     "  $_: $s"
2139                  } sort keys %$attrs,
2140             );
2141             if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter, $name)) {
2142                 $self->_pod( $class, $comment );
2143             }
2144         }
2145         $self->_pod_cut( $class );
2146     } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2147         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2148         my ( $accessor, $rel_class ) = @_;
2149         $self->_pod( $class, "=head2 $accessor" );
2150         $self->_pod( $class, 'Type: ' . $method );
2151         $self->_pod( $class, "Related object: L<$rel_class>" );
2152         $self->_pod_cut( $class );
2153         $self->{_relations_started} { $class } = 1;
2154     }
2155 }
2156
2157 sub _pod_class_list {
2158     my ($self, $class, $title, @classes) = @_;
2159
2160     return unless @classes && $self->generate_pod;
2161
2162     $self->_pod($class, "=head1 $title");
2163     $self->_pod($class, '=over 4');
2164
2165     foreach my $link (@classes) {
2166         $self->_pod($class, "=item * L<$link>");
2167     }
2168
2169     $self->_pod($class, '=back');
2170     $self->_pod_cut($class);
2171 }
2172
2173 sub _base_class_pod {
2174     my ($self, $class, $base_class) = @_;
2175
2176     return unless $self->generate_pod;
2177
2178     $self->_pod($class, "=head1 BASE CLASS: L<$base_class>");
2179     $self->_pod_cut($class);
2180 }
2181
2182 sub _filter_comment {
2183     my ($self, $txt) = @_;
2184
2185     $txt = '' if not defined $txt;
2186
2187     $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2188
2189     return $txt;
2190 }
2191
2192 sub __table_comment {
2193     my $self = shift;
2194
2195     if (my $code = $self->can('_table_comment')) {
2196         return $self->_filter_comment($self->$code(@_));
2197     }
2198
2199     return '';
2200 }
2201
2202 sub __column_comment {
2203     my $self = shift;
2204
2205     if (my $code = $self->can('_column_comment')) {
2206         return $self->_filter_comment($self->$code(@_));
2207     }
2208
2209     return '';
2210 }
2211
2212 # Stores a POD documentation
2213 sub _pod {
2214     my ($self, $class, $stmt) = @_;
2215     $self->_raw_stmt( $class, "\n" . $stmt  );
2216 }
2217
2218 sub _pod_cut {
2219     my ($self, $class ) = @_;
2220     $self->_raw_stmt( $class, "\n=cut\n" );
2221 }
2222
2223 # Store a raw source line for a class (for dumping purposes)
2224 sub _raw_stmt {
2225     my ($self, $class, $stmt) = @_;
2226     push(@{$self->{_dump_storage}->{$class}}, $stmt);
2227 }
2228
2229 # Like above, but separately for the externally loaded stuff
2230 sub _ext_stmt {
2231     my ($self, $class, $stmt) = @_;
2232     push(@{$self->{_ext_storage}->{$class}}, $stmt);
2233 }
2234
2235 sub _custom_column_info {
2236     my ( $self, $table_name, $column_name, $column_info ) = @_;
2237
2238     if (my $code = $self->custom_column_info) {
2239         return $code->($table_name, $column_name, $column_info) || {};
2240     }
2241     return {};
2242 }
2243
2244 sub _datetime_column_info {
2245     my ( $self, $table_name, $column_name, $column_info ) = @_;
2246     my $result = {};
2247     my $type = $column_info->{data_type} || '';
2248     if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2249             or ($type =~ /date|timestamp/i)) {
2250         $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2251         $result->{locale}   = $self->datetime_locale   if $self->datetime_locale;
2252     }
2253     return $result;
2254 }
2255
2256 sub _lc {
2257     my ($self, $name) = @_;
2258
2259     return $self->preserve_case ? $name : lc($name);
2260 }
2261
2262 sub _uc {
2263     my ($self, $name) = @_;
2264
2265     return $self->preserve_case ? $name : uc($name);
2266 }
2267
2268 sub _unregister_source_for_table {
2269     my ($self, $table) = @_;
2270
2271     try {
2272         local $@;
2273         my $schema = $self->schema;
2274         # in older DBIC it's a private method
2275         my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2276         $schema->$unregister($self->_table2moniker($table));
2277         delete $self->monikers->{$table};
2278         delete $self->classes->{$table};
2279         delete $self->_upgrading_classes->{$table};
2280         delete $self->{_tables}{$table};
2281     };
2282 }
2283
2284 # remove the dump dir from @INC on destruction
2285 sub DESTROY {
2286     my $self = shift;
2287
2288     @INC = grep $_ ne $self->dump_directory, @INC;
2289 }
2290
2291 =head2 monikers
2292
2293 Returns a hashref of loaded table to moniker mappings.  There will
2294 be two entries for each table, the original name and the "normalized"
2295 name, in the case that the two are different (such as databases
2296 that like uppercase table names, or preserve your original mixed-case
2297 definitions, or what-have-you).
2298
2299 =head2 classes
2300
2301 Returns a hashref of table to class mappings.  In some cases it will
2302 contain multiple entries per table for the original and normalized table
2303 names, as above in L</monikers>.
2304
2305 =head1 COLUMN ACCESSOR COLLISIONS
2306
2307 Occasionally you may have a column name that collides with a perl method, such
2308 as C<can>. In such cases, the default action is to set the C<accessor> of the
2309 column spec to C<undef>.
2310
2311 You can then name the accessor yourself by placing code such as the following
2312 below the md5:
2313
2314     __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2315
2316 Another option is to use the L</col_collision_map> option.
2317
2318 =head1 RELATIONSHIP NAME COLLISIONS
2319
2320 In very rare cases, you may get a collision between a generated relationship
2321 name and a method in your Result class, for example if you have a foreign key
2322 called C<belongs_to>.
2323
2324 This is a problem because relationship names are also relationship accessor
2325 methods in L<DBIx::Class>.
2326
2327 The default behavior is to append C<_rel> to the relationship name and print
2328 out a warning that refers to this text.
2329
2330 You can also control the renaming with the L</rel_collision_map> option.
2331
2332 =head1 SEE ALSO
2333
2334 L<DBIx::Class::Schema::Loader>
2335
2336 =head1 AUTHOR
2337
2338 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2339
2340 =head1 LICENSE
2341
2342 This library is free software; you can redistribute it and/or modify it under
2343 the same terms as Perl itself.
2344
2345 =cut
2346
2347 1;
2348 # vim:et sts=4 sw=4 tw=0: