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