1 package DBIx::Class::Schema::Loader::Base;
5 use base qw/Class::Accessor::Grouped Class::C3::Componentised/;
8 use Carp::Clan qw/^DBIx::Class/;
9 use DBIx::Class::Schema::Loader::RelBuilder ();
10 use Data::Dump 'dump';
15 use Lingua::EN::Inflect::Number ();
16 use Lingua::EN::Inflect::Phrase ();
17 use String::ToIdentifier::EN ();
18 use String::ToIdentifier::EN::Unicode ();
21 use Class::Inspector ();
22 use Scalar::Util 'looks_like_number';
23 use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path slurp_file/;
24 use DBIx::Class::Schema::Loader::Optional::Dependencies ();
27 use Encode qw/encode decode/;
28 use List::MoreUtils qw/all any firstidx uniq/;
29 use File::Temp 'tempfile';
32 our $VERSION = '0.07035';
34 __PACKAGE__->mk_group_ro_accessors('simple', qw/
41 additional_base_classes
57 default_resultset_class
63 overwrite_modifications
86 __PACKAGE__->mk_group_accessors('simple', qw/
88 schema_version_to_dump
90 _upgrading_from_load_classes
91 _downgrading_to_load_classes
92 _rewriting_result_namespace
97 pod_comment_spillover_length
103 result_components_map
105 datetime_undef_if_invalid
106 _result_class_methods
108 filter_generated_code
114 my $CURRENT_V = 'v7';
117 schema_components schema_base_class result_base_class
118 additional_base_classes left_base_classes additional_classes components
124 my $CRLF = "\x0d\x0a";
128 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
132 See L<DBIx::Class::Schema::Loader>.
136 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
137 classes, and implements the common functionality between them.
139 =head1 CONSTRUCTOR OPTIONS
141 These constructor options are the base options for
142 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
144 =head2 skip_relationships
146 Skip setting up relationships. The default is to attempt the loading
149 =head2 skip_load_external
151 Skip loading of other classes in @INC. The default is to merge all other classes
152 with the same name found in @INC into the schema file we are creating.
156 Static schemas (ones dumped to disk) will, by default, use the new-style
157 relationship names and singularized Results, unless you're overwriting an
158 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
159 which case the backward compatible RelBuilder will be activated, and the
160 appropriate monikerization used.
166 will disable the backward-compatible RelBuilder and use
167 the new-style relationship names along with singularized Results, even when
168 overwriting a dump made with an earlier version.
170 The option also takes a hashref:
173 relationships => 'v8',
175 column_accessors => 'v8',
181 naming => { ALL => 'v8', force_ascii => 1 }
189 Set L</relationships>, L</monikers> and L</column_accessors> to the specified
194 How to name relationship accessors.
198 How to name Result classes.
200 =item column_accessors
202 How to name column accessors in Result classes.
206 For L</v8> mode and later, uses L<String::ToIdentifier::EN> instead of
207 L<String::ToIdentifier::EM::Unicode> to force monikers and other identifiers to
218 Latest style, whatever that happens to be.
222 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
226 Monikers singularized as whole words, C<might_have> relationships for FKs on
227 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
229 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
234 All monikers and relationships are inflected using
235 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
236 from relationship names.
238 In general, there is very little difference between v5 and v6 schemas.
242 This mode is identical to C<v6> mode, except that monikerization of CamelCase
243 table names is also done better (but best in v8.)
245 CamelCase column names in case-preserving mode will also be handled better
246 for relationship name inflection (but best in v8.) See L</preserve_case>.
248 In this mode, CamelCase L</column_accessors> are normalized based on case
249 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
255 The default mode is L</v7>, to get L</v8> mode, you have to specify it in
256 L</naming> explicitly until C<0.08> comes out.
258 L</monikers> and L</column_accessors> are created using
259 L<String::ToIdentifier::EN::Unicode> or L<String::ToIdentifier::EN> if
260 L</force_ascii> is set; this is only significant for names with non-C<\w>
261 characters such as C<.>.
263 CamelCase identifiers with words in all caps, e.g. C<VLANValidID> are supported
264 correctly in this mode.
266 For relationships, belongs_to accessors are made from column names by stripping
267 postfixes other than C<_id> as well, for example just C<Id>, C<_?ref>, C<_?cd>,
268 C<_?code> and C<_?num>, case insensitively.
272 For L</monikers>, this option does not inflect the table names but makes
273 monikers based on the actual name. For L</column_accessors> this option does
274 not normalize CamelCase column names to lowercase column accessors, but makes
275 accessors that are the same names as the columns (with any non-\w chars
276 replaced with underscores.)
280 For L</monikers>, singularizes the names using the most current inflector. This
281 is the same as setting the option to L</current>.
285 For L</monikers>, pluralizes the names, using the most current inflector.
289 Dynamic schemas will always default to the 0.04XXX relationship names and won't
290 singularize Results for backward compatibility, to activate the new RelBuilder
291 and singularization put this in your C<Schema.pm> file:
293 __PACKAGE__->naming('current');
295 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
296 next major version upgrade:
298 __PACKAGE__->naming('v7');
302 If true, will not print the usual C<Dumping manual schema ... Schema dump
303 completed.> messages. Does not affect warnings (except for warnings related to
304 L</really_erase_my_files>.)
308 By default POD will be generated for columns and relationships, using database
309 metadata for the text if available and supported.
311 Comment metadata can be stored in two ways.
313 The first is that you can create two tables named C<table_comments> and
314 C<column_comments> respectively. These tables must exist in the same database
315 and schema as the tables they describe. They both need to have columns named
316 C<table_name> and C<comment_text>. The second one needs to have a column named
317 C<column_name>. Then data stored in these tables will be used as a source of
318 metadata about tables and comments.
320 (If you wish you can change the name of these tables with the parameters
321 L</table_comments_table> and L</column_comments_table>.)
323 As a fallback you can use built-in commenting mechanisms. Currently this is
324 only supported for PostgreSQL, Oracle and MySQL. To create comments in
325 PostgreSQL you add statements of the form C<COMMENT ON TABLE some_table IS
326 '...'>, the same syntax is used in Oracle. To create comments in MySQL you add
327 C<COMMENT '...'> to the end of the column or table definition. Note that MySQL
328 restricts the length of comments, and also does not handle complex Unicode
331 Set this to C<0> to turn off all POD generation.
333 =head2 pod_comment_mode
335 Controls where table comments appear in the generated POD. Smaller table
336 comments are appended to the C<NAME> section of the documentation, and larger
337 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
338 section to be generated with the comment always, only use C<NAME>, or choose
339 the length threshold at which the comment is forced into the description.
345 Use C<NAME> section only.
349 Force C<DESCRIPTION> always.
353 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
358 =head2 pod_comment_spillover_length
360 When pod_comment_mode is set to C<auto>, this is the length of the comment at
361 which it will be forced into a separate description section.
365 =head2 table_comments_table
367 The table to look for comments about tables in. By default C<table_comments>.
368 See L</generate_pod> for details.
370 This must not be a fully qualified name, the table will be looked for in the
371 same database and schema as the table whose comment is being retrieved.
373 =head2 column_comments_table
375 The table to look for comments about columns in. By default C<column_comments>.
376 See L</generate_pod> for details.
378 This must not be a fully qualified name, the table will be looked for in the
379 same database and schema as the table/column whose comment is being retrieved.
381 =head2 relationship_attrs
383 Hashref of attributes to pass to each generated relationship, listed by type.
384 Also supports relationship type 'all', containing options to pass to all
385 generated relationships. Attributes set for more specific relationship types
386 override those set in 'all', and any attributes specified by this option
387 override the introspected attributes of the foreign key if any.
391 relationship_attrs => {
392 has_many => { cascade_delete => 1, cascade_copy => 1 },
393 might_have => { cascade_delete => 1, cascade_copy => 1 },
396 use this to turn L<DBIx::Class> cascades to on on your
397 L<has_many|DBIx::Class::Relationship/has_many> and
398 L<might_have|DBIx::Class::Relationship/might_have> relationships, they default
401 Can also be a coderef, for more precise control, in which case the coderef gets
402 this hash of parameters (as a list:)
404 rel_name # the name of the relationship
405 rel_type # the type of the relationship: 'belongs_to', 'has_many' or 'might_have'
406 local_source # the DBIx::Class::ResultSource object for the source the rel is *from*
407 remote_source # the DBIx::Class::ResultSource object for the source the rel is *to*
408 local_table # a DBIx::Class::Schema::Loader::Table object for the table of the source the rel is from
409 local_cols # an arrayref of column names of columns used in the rel in the source it is from
410 remote_table # a DBIx::Class::Schema::Loader::Table object for the table of the source the rel is to
411 remote_cols # an arrayref of column names of columns used in the rel in the source it is to
412 attrs # the attributes that would be set
414 it should return the new hashref of attributes, or nothing for no changes.
418 relationship_attrs => sub {
421 say "the relationship name is: $p{rel_name}";
422 say "the relationship is a: $p{rel_type}";
423 say "the local class is: ", $p{local_source}->result_class;
424 say "the remote class is: ", $p{remote_source}->result_class;
425 say "the local table is: ", $p{local_table}->sql_name;
426 say "the rel columns in the local table are: ", (join ", ", @{$p{local_cols}});
427 say "the remote table is: ", $p{remote_table}->sql_name;
428 say "the rel columns in the remote table are: ", (join ", ", @{$p{remote_cols}});
430 if ($p{local_table} eq 'dogs' && @{$p{local_cols}} == 1 && $p{local_cols}[0] eq 'name') {
431 $p{attrs}{could_be_snoopy} = 1;
437 These are the default attributes:
448 on_delete => 'CASCADE',
449 on_update => 'CASCADE',
453 For L<belongs_to|DBIx::Class::Relationship/belongs_to> relationships, these
454 defaults are overridden by the attributes introspected from the foreign key in
455 the database, if this information is available (and the driver is capable of
458 This information overrides the defaults mentioned above, and is then itself
459 overridden by the user's L</relationship_attrs> for C<belongs_to> if any are
462 In general, for most databases, for a plain foreign key with no rules, the
463 values for a L<belongs_to|DBIx::Class::Relationship/belongs_to> relationship
466 on_delete => 'NO ACTION',
467 on_update => 'NO ACTION',
470 In the cases where an attribute is not supported by the DB, a value matching
471 the actual behavior is used, for example Oracle does not support C<ON UPDATE>
472 rules, so C<on_update> is set to C<NO ACTION>. This is done so that the
473 behavior of the schema is preserved when cross deploying to a different RDBMS
474 such as SQLite for testing.
476 In the cases where the DB does not support C<DEFERRABLE> foreign keys, the
477 value is set to C<1> if L<DBIx::Class> has a working C<<
478 $storage->with_deferred_fk_checks >>. This is done so that the same
479 L<DBIx::Class> code can be used, and cross deployed from and to such databases.
483 If set to true, each constructive L<DBIx::Class> statement the loader
484 decides to execute will be C<warn>-ed before execution.
488 Set the name of the schema to load (schema in the sense that your database
491 Can be set to an arrayref of schema names for multiple schemas, or the special
492 value C<%> for all schemas.
494 For MSSQL, Sybase ASE, and Informix can be set to a hashref of databases as
495 keys and arrays of owners as values, set to the value:
499 for all owners in all databases.
501 Name clashes resulting from the same table name in different databases/schemas
502 will be resolved automatically by prefixing the moniker with the database
505 To prefix/suffix all monikers with the database and/or schema, see
510 The database table names are represented by the
511 L<DBIx::Class::Schema::Loader::Table> class in the loader, the
512 L<DBIx::Class::Schema::Loader::Table::Sybase> class for Sybase ASE and
513 L<DBIx::Class::Schema::Loader::Table::Informix> for Informix.
515 Monikers are created normally based on just the
516 L<name|DBIx::Class::Schema::Loader::DBObject/name> property, corresponding to
517 the table name, but can consist of other parts of the fully qualified name of
520 The L</moniker_parts> option is an arrayref of methods on the table class
521 corresponding to parts of the fully qualified table name, defaulting to
522 C<['name']>, in the order those parts are used to create the moniker name.
524 The C<'name'> entry B<must> be present.
526 Below is a table of supported databases and possible L</moniker_parts>.
530 =item * DB2, Firebird, mysql, Oracle, Pg, SQLAnywhere, SQLite, MS Access
534 =item * Informix, MSSQL, Sybase ASE
536 C<database>, C<schema>, C<name>
542 Only load tables matching regex. Best specified as a qr// regex.
546 Exclude tables matching regex. Best specified as a qr// regex.
550 Overrides the default table name to moniker translation. Can be either a
551 hashref of table keys and moniker values, or a coderef for a translator
552 function taking a L<table object|DBIx::Class::Schema::Loader::Table> argument
553 (which stringifies to the unqualified table name) and returning a scalar
554 moniker. If the hash entry does not exist, or the function returns a false
555 value, the code falls back to default behavior for that table name.
557 The default behavior is to split on case transition and non-alphanumeric
558 boundaries, singularize the resulting phrase, then join the titlecased words
561 Table Name | Moniker Name
562 ---------------------------------
564 luser_group | LuserGroup
565 luser-opts | LuserOpt
566 stations_visited | StationVisited
567 routeChange | RouteChange
569 =head2 col_accessor_map
571 Same as moniker_map, but for column accessor names. If a coderef is
572 passed, the code is called with arguments of
574 the name of the column in the underlying database,
575 default accessor name that DBICSL would ordinarily give this column,
577 table_class => name of the DBIC class we are building,
578 table_moniker => calculated moniker for this table (after moniker_map if present),
579 table => table object of interface DBIx::Class::Schema::Loader::Table,
580 full_table_name => schema-qualified name of the database table (RDBMS specific),
581 schema_class => name of the schema class we are building,
582 column_info => hashref of column info (data_type, is_nullable, etc),
585 the L<table object|DBIx::Class::Schema::Loader::Table> stringifies to the
586 unqualified table name.
590 Similar in idea to moniker_map, but different in the details. It can be
591 a hashref or a code ref.
593 If it is a hashref, keys can be either the default relationship name, or the
594 moniker. The keys that are the default relationship name should map to the
595 name you want to change the relationship to. Keys that are monikers should map
596 to hashes mapping relationship names to their translation. You can do both at
597 once, and the more specific moniker version will be picked up first. So, for
598 instance, you could have
607 and relationships that would have been named C<bar> will now be named C<baz>
608 except that in the table whose moniker is C<Foo> it will be named C<blat>.
610 If it is a coderef, the argument passed will be a hashref of this form:
613 name => default relationship name,
614 type => the relationship type eg: C<has_many>,
615 local_class => name of the DBIC class we are building,
616 local_moniker => moniker of the DBIC class we are building,
617 local_columns => columns in this table in the relationship,
618 remote_class => name of the DBIC class we are related to,
619 remote_moniker => moniker of the DBIC class we are related to,
620 remote_columns => columns in the other table in the relationship,
621 # for type => "many_to_many" only:
622 link_class => name of the DBIC class for the link table
623 link_moniker => moniker of the DBIC class for the link table
624 link_rel_name => name of the relationship to the link table
627 DBICSL will try to use the value returned as the relationship name.
629 =head2 inflect_plural
631 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
632 if hash key does not exist or coderef returns false), but acts as a map
633 for pluralizing relationship names. The default behavior is to utilize
634 L<Lingua::EN::Inflect::Phrase/to_PL>.
636 =head2 inflect_singular
638 As L</inflect_plural> above, but for singularizing relationship names.
639 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
641 =head2 schema_base_class
643 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
645 =head2 schema_components
647 List of components to load into the Schema class.
649 =head2 result_base_class
651 Base class for your table classes (aka result classes). Defaults to
654 =head2 additional_base_classes
656 List of additional base classes all of your table classes will use.
658 =head2 left_base_classes
660 List of additional base classes all of your table classes will use
661 that need to be leftmost.
663 =head2 additional_classes
665 List of additional classes which all of your table classes will use.
669 List of additional components to be loaded into all of your Result
670 classes. A good example would be
671 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
673 =head2 result_components_map
675 A hashref of moniker keys and component values. Unlike L</components>, which
676 loads the given components into every Result class, this option allows you to
677 load certain components for specified Result classes. For example:
679 result_components_map => {
680 StationVisited => '+YourApp::Schema::Component::StationVisited',
682 '+YourApp::Schema::Component::RouteChange',
683 'InflateColumn::DateTime',
687 You may use this in conjunction with L</components>.
691 List of L<Moose> roles to be applied to all of your Result classes.
693 =head2 result_roles_map
695 A hashref of moniker keys and role values. Unlike L</result_roles>, which
696 applies the given roles to every Result class, this option allows you to apply
697 certain roles for specified Result classes. For example:
699 result_roles_map => {
701 'YourApp::Role::Building',
702 'YourApp::Role::Destination',
704 RouteChange => 'YourApp::Role::TripEvent',
707 You may use this in conjunction with L</result_roles>.
709 =head2 use_namespaces
711 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
714 Generate result class names suitable for
715 L<DBIx::Class::Schema/load_namespaces> and call that instead of
716 L<DBIx::Class::Schema/load_classes>. When using this option you can also
717 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
718 C<resultset_namespace>, C<default_resultset_class>), and they will be added
719 to the call (and the generated result class names adjusted appropriately).
721 =head2 dump_directory
723 The value of this option is a perl libdir pathname. Within
724 that directory this module will create a baseline manual
725 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
727 The created schema class will have the same classname as the one on
728 which you are setting this option (and the ResultSource classes will be
729 based on this name as well).
731 Normally you wouldn't hard-code this setting in your schema class, as it
732 is meant for one-time manual usage.
734 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
735 recommended way to access this functionality.
737 =head2 dump_overwrite
739 Deprecated. See L</really_erase_my_files> below, which does *not* mean
740 the same thing as the old C<dump_overwrite> setting from previous releases.
742 =head2 really_erase_my_files
744 Default false. If true, Loader will unconditionally delete any existing
745 files before creating the new ones from scratch when dumping a schema to disk.
747 The default behavior is instead to only replace the top portion of the
748 file, up to and including the final stanza which contains
749 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
750 leaving any customizations you placed after that as they were.
752 When C<really_erase_my_files> is not set, if the output file already exists,
753 but the aforementioned final stanza is not found, or the checksum
754 contained there does not match the generated contents, Loader will
755 croak and not touch the file.
757 You should really be using version control on your schema classes (and all
758 of the rest of your code for that matter). Don't blame me if a bug in this
759 code wipes something out when it shouldn't have, you've been warned.
761 =head2 overwrite_modifications
763 Default false. If false, when updating existing files, Loader will
764 refuse to modify any Loader-generated code that has been modified
765 since its last run (as determined by the checksum Loader put in its
768 If true, Loader will discard any manual modifications that have been
769 made to Loader-generated code.
771 Again, you should be using version control on your schema classes. Be
772 careful with this option.
774 =head2 custom_column_info
776 Hook for adding extra attributes to the
777 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
779 Must be a coderef that returns a hashref with the extra attributes.
781 Receives the L<table object|DBIx::Class::Schema::Loader::Table> (which
782 stringifies to the unqualified table name), column name and column_info.
786 custom_column_info => sub {
787 my ($table, $column_name, $column_info) = @_;
789 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
790 return { is_snoopy => 1 };
794 This attribute can also be used to set C<inflate_datetime> on a non-datetime
795 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
797 =head2 datetime_timezone
799 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
800 columns with the DATE/DATETIME/TIMESTAMP data_types.
802 =head2 datetime_locale
804 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
805 columns with the DATE/DATETIME/TIMESTAMP data_types.
807 =head2 datetime_undef_if_invalid
809 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
810 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
813 The default is recommended to deal with data such as C<00/00/00> which
814 sometimes ends up in such columns in MySQL.
818 File in Perl format, which should return a HASH reference, from which to read
823 Normally database names are lowercased and split by underscore, use this option
824 if you have CamelCase database names.
826 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
827 case-sensitive collation will turn this option on unconditionally.
829 B<NOTE:> L</naming> = C<v8> is highly recommended with this option as the
830 semantics of this mode are much improved for CamelCase database names.
832 L</naming> = C<v7> or greater is required with this option.
834 =head2 qualify_objects
836 Set to true to prepend the L</db_schema> to table names for C<<
837 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
839 This attribute is automatically set to true for multi db_schema configurations,
840 unless explicitly set to false by the user.
844 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
845 L<MooseX::MarkAsMethods> (or L<namespace::autoclean>, see below). The default
846 content after the md5 sum also makes the classes immutable.
848 It is safe to upgrade your existing Schema to this option.
850 =head2 only_autoclean
852 By default, we use L<MooseX::MarkAsMethods> to remove imported functions from
853 your generated classes. It uses L<namespace::autoclean> to do this, after
854 telling your object's metaclass that any operator L<overload>s in your class
855 are methods, which will cause namespace::autoclean to spare them from removal.
857 This prevents the "Hey, where'd my overloads go?!" effect.
859 If you don't care about operator overloads, enabling this option falls back to
860 just using L<namespace::autoclean> itself.
862 If none of the above made any sense, or you don't have some pressing need to
863 only use L<namespace::autoclean>, leaving this set to the default is
866 =head2 col_collision_map
868 This option controls how accessors for column names which collide with perl
869 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
871 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
872 strings which are compiled to regular expressions that map to
873 L<sprintf|perlfunc/sprintf> formats.
877 col_collision_map => 'column_%s'
879 col_collision_map => { '(.*)' => 'column_%s' }
881 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
883 =head2 rel_collision_map
885 Works just like L</col_collision_map>, but for relationship names/accessors
886 rather than column names/accessors.
888 The default is to just append C<_rel> to the relationship name, see
889 L</RELATIONSHIP NAME COLLISIONS>.
891 =head2 uniq_to_primary
893 Automatically promotes the largest unique constraints with non-nullable columns
894 on tables to primary keys, assuming there is only one largest unique
897 =head2 filter_generated_code
899 An optional hook that lets you filter the generated text for various classes
900 through a function that change it in any way that you want. The function will
901 receive the type of file, C<schema> or C<result>, class and code; and returns
902 the new code to use instead. For instance you could add custom comments, or do
903 anything else that you want.
905 The option can also be set to a string, which is then used as a filter program,
908 If this exists but fails to return text matching C</\bpackage\b/>, no file will
911 filter_generated_code => sub {
912 my ($type, $class, $text) = @_;
919 None of these methods are intended for direct invocation by regular
920 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
921 L<DBIx::Class::Schema::Loader>.
925 # ensure that a peice of object data is a valid arrayref, creating
926 # an empty one or encapsulating whatever's there.
927 sub _ensure_arrayref {
932 $self->{$_} = [ $self->{$_} ]
933 unless ref $self->{$_} eq 'ARRAY';
939 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
940 by L<DBIx::Class::Schema::Loader>.
945 my ( $class, %args ) = @_;
947 if (exists $args{column_accessor_map}) {
948 $args{col_accessor_map} = delete $args{column_accessor_map};
951 my $self = { %args };
953 # don't lose undef options
954 for (values %$self) {
955 $_ = 0 unless defined $_;
958 bless $self => $class;
960 if (my $config_file = $self->config_file) {
961 my $config_opts = do $config_file;
963 croak "Error reading config from $config_file: $@" if $@;
965 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
967 while (my ($k, $v) = each %$config_opts) {
968 $self->{$k} = $v unless exists $self->{$k};
972 if (defined $self->{result_component_map}) {
973 if (defined $self->result_components_map) {
974 croak "Specify only one of result_components_map or result_component_map";
976 $self->result_components_map($self->{result_component_map})
979 if (defined $self->{result_role_map}) {
980 if (defined $self->result_roles_map) {
981 croak "Specify only one of result_roles_map or result_role_map";
983 $self->result_roles_map($self->{result_role_map})
986 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
987 if ((not defined $self->use_moose) || (not $self->use_moose))
988 && ((defined $self->result_roles) || (defined $self->result_roles_map));
990 $self->_ensure_arrayref(qw/schema_components
992 additional_base_classes
998 $self->_validate_class_args;
1000 croak "result_components_map must be a hash"
1001 if defined $self->result_components_map
1002 && ref $self->result_components_map ne 'HASH';
1004 if ($self->result_components_map) {
1005 my %rc_map = %{ $self->result_components_map };
1006 foreach my $moniker (keys %rc_map) {
1007 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
1009 $self->result_components_map(\%rc_map);
1012 $self->result_components_map({});
1014 $self->_validate_result_components_map;
1016 croak "result_roles_map must be a hash"
1017 if defined $self->result_roles_map
1018 && ref $self->result_roles_map ne 'HASH';
1020 if ($self->result_roles_map) {
1021 my %rr_map = %{ $self->result_roles_map };
1022 foreach my $moniker (keys %rr_map) {
1023 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
1025 $self->result_roles_map(\%rr_map);
1027 $self->result_roles_map({});
1029 $self->_validate_result_roles_map;
1031 if ($self->use_moose) {
1032 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
1033 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
1034 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
1038 $self->{_tables} = {};
1039 $self->{monikers} = {};
1040 $self->{moniker_to_table} = {};
1041 $self->{class_to_table} = {};
1042 $self->{classes} = {};
1043 $self->{_upgrading_classes} = {};
1045 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
1046 $self->{schema} ||= $self->{schema_class};
1047 $self->{table_comments_table} ||= 'table_comments';
1048 $self->{column_comments_table} ||= 'column_comments';
1050 croak "dump_overwrite is deprecated. Please read the"
1051 . " DBIx::Class::Schema::Loader::Base documentation"
1052 if $self->{dump_overwrite};
1054 $self->{dynamic} = ! $self->{dump_directory};
1055 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
1060 $self->{dump_directory} ||= $self->{temp_directory};
1062 $self->real_dump_directory($self->{dump_directory});
1064 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
1065 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
1067 if (not defined $self->naming) {
1068 $self->naming_set(0);
1071 $self->naming_set(1);
1074 if ((not ref $self->naming) && defined $self->naming) {
1075 my $naming_ver = $self->naming;
1077 relationships => $naming_ver,
1078 monikers => $naming_ver,
1079 column_accessors => $naming_ver,
1082 elsif (ref $self->naming eq 'HASH' && exists $self->naming->{ALL}) {
1083 my $val = delete $self->naming->{ALL};
1085 $self->naming->{$_} = $val
1086 foreach qw/relationships monikers column_accessors/;
1089 if ($self->naming) {
1090 foreach my $key (qw/relationships monikers column_accessors/) {
1091 $self->naming->{$key} = $CURRENT_V if ($self->naming->{$key}||'') eq 'current';
1094 $self->{naming} ||= {};
1096 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
1097 croak 'custom_column_info must be a CODE ref';
1100 $self->_check_back_compat;
1102 $self->use_namespaces(1) unless defined $self->use_namespaces;
1103 $self->generate_pod(1) unless defined $self->generate_pod;
1104 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
1105 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
1107 if (my $col_collision_map = $self->col_collision_map) {
1108 if (my $reftype = ref $col_collision_map) {
1109 if ($reftype ne 'HASH') {
1110 croak "Invalid type $reftype for option 'col_collision_map'";
1114 $self->col_collision_map({ '(.*)' => $col_collision_map });
1118 if (my $rel_collision_map = $self->rel_collision_map) {
1119 if (my $reftype = ref $rel_collision_map) {
1120 if ($reftype ne 'HASH') {
1121 croak "Invalid type $reftype for option 'rel_collision_map'";
1125 $self->rel_collision_map({ '(.*)' => $rel_collision_map });
1129 if (defined(my $rel_name_map = $self->rel_name_map)) {
1130 my $reftype = ref $rel_name_map;
1131 if ($reftype ne 'HASH' && $reftype ne 'CODE') {
1132 croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
1136 if (defined(my $filter = $self->filter_generated_code)) {
1137 my $reftype = ref $filter;
1138 if ($reftype && $reftype ne 'CODE') {
1139 croak "Invalid type $reftype for option 'filter_generated_code, must be a scalar or a CODE reference";
1143 if (defined $self->db_schema) {
1144 if (ref $self->db_schema eq 'ARRAY') {
1145 if (@{ $self->db_schema } > 1 && not defined $self->{qualify_objects}) {
1146 $self->{qualify_objects} = 1;
1148 elsif (@{ $self->db_schema } == 0) {
1149 $self->{db_schema} = undef;
1152 elsif (not ref $self->db_schema) {
1153 if ($self->db_schema eq '%' && not defined $self->{qualify_objects}) {
1154 $self->{qualify_objects} = 1;
1157 $self->{db_schema} = [ $self->db_schema ];
1161 if (not $self->moniker_parts) {
1162 $self->moniker_parts(['name']);
1165 if (not ref $self->moniker_parts) {
1166 $self->moniker_parts([ $self->moniker_parts ]);
1168 if (ref $self->moniker_parts ne 'ARRAY') {
1169 croak 'moniker_parts must be an arrayref';
1171 if ((firstidx { $_ eq 'name' } @{ $self->moniker_parts }) == -1) {
1172 croak "moniker_parts option *must* contain 'name'";
1179 sub _check_back_compat {
1182 # dynamic schemas will always be in 0.04006 mode, unless overridden
1183 if ($self->dynamic) {
1184 # just in case, though no one is likely to dump a dynamic schema
1185 $self->schema_version_to_dump('0.04006');
1187 if (not $self->naming_set) {
1188 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1190 Dynamic schema detected, will run in 0.04006 mode.
1192 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1193 to disable this warning.
1195 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1200 $self->_upgrading_from('v4');
1203 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
1204 $self->use_namespaces(1);
1207 $self->naming->{relationships} ||= 'v4';
1208 $self->naming->{monikers} ||= 'v4';
1210 if ($self->use_namespaces) {
1211 $self->_upgrading_from_load_classes(1);
1214 $self->use_namespaces(0);
1220 # otherwise check if we need backcompat mode for a static schema
1221 my $filename = $self->get_dump_filename($self->schema_class);
1222 return unless -e $filename;
1224 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
1225 $self->_parse_generated_file($filename);
1227 return unless $old_ver;
1229 # determine if the existing schema was dumped with use_moose => 1
1230 if (! defined $self->use_moose) {
1231 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
1234 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
1236 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
1237 my $ds = eval $result_namespace;
1239 Could not eval expression '$result_namespace' for result_namespace from
1242 $result_namespace = $ds || '';
1244 if ($load_classes && (not defined $self->use_namespaces)) {
1245 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1247 'load_classes;' static schema detected, turning off 'use_namespaces'.
1249 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
1250 variable to disable this warning.
1252 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1255 $self->use_namespaces(0);
1257 elsif ($load_classes && $self->use_namespaces) {
1258 $self->_upgrading_from_load_classes(1);
1260 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
1261 $self->_downgrading_to_load_classes(
1262 $result_namespace || 'Result'
1265 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
1266 if (not $self->result_namespace) {
1267 $self->result_namespace($result_namespace || 'Result');
1269 elsif ($result_namespace ne $self->result_namespace) {
1270 $self->_rewriting_result_namespace(
1271 $result_namespace || 'Result'
1276 # XXX when we go past .0 this will need fixing
1277 my ($v) = $old_ver =~ /([1-9])/;
1280 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
1282 if (not %{ $self->naming }) {
1283 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1285 Version $old_ver static schema detected, turning on backcompat mode.
1287 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1288 to disable this warning.
1290 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
1292 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
1293 from version 0.04006.
1296 $self->naming->{relationships} ||= $v;
1297 $self->naming->{monikers} ||= $v;
1298 $self->naming->{column_accessors} ||= $v;
1300 $self->schema_version_to_dump($old_ver);
1303 $self->_upgrading_from($v);
1307 sub _validate_class_args {
1310 foreach my $k (@CLASS_ARGS) {
1311 next unless $self->$k;
1313 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
1314 $self->_validate_classes($k, \@classes);
1318 sub _validate_result_components_map {
1321 foreach my $classes (values %{ $self->result_components_map }) {
1322 $self->_validate_classes('result_components_map', $classes);
1326 sub _validate_result_roles_map {
1329 foreach my $classes (values %{ $self->result_roles_map }) {
1330 $self->_validate_classes('result_roles_map', $classes);
1334 sub _validate_classes {
1337 my $classes = shift;
1339 # make a copy to not destroy original
1340 my @classes = @$classes;
1342 foreach my $c (@classes) {
1343 # components default to being under the DBIx::Class namespace unless they
1344 # are preceeded with a '+'
1345 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1346 $c = 'DBIx::Class::' . $c;
1349 # 1 == installed, 0 == not installed, undef == invalid classname
1350 my $installed = Class::Inspector->installed($c);
1351 if ( defined($installed) ) {
1352 if ( $installed == 0 ) {
1353 croak qq/$c, as specified in the loader option "$key", is not installed/;
1356 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1362 sub _find_file_in_inc {
1363 my ($self, $file) = @_;
1365 foreach my $prefix (@INC) {
1366 my $fullpath = File::Spec->catfile($prefix, $file);
1367 return $fullpath if -f $fullpath
1368 # abs_path throws on Windows for nonexistant files
1369 and (try { Cwd::abs_path($fullpath) }) ne
1370 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1376 sub _find_class_in_inc {
1377 my ($self, $class) = @_;
1379 return $self->_find_file_in_inc(class_path($class));
1385 return $self->_upgrading_from
1386 || $self->_upgrading_from_load_classes
1387 || $self->_downgrading_to_load_classes
1388 || $self->_rewriting_result_namespace
1392 sub _rewrite_old_classnames {
1393 my ($self, $code) = @_;
1395 return $code unless $self->_rewriting;
1397 my %old_classes = reverse %{ $self->_upgrading_classes };
1399 my $re = join '|', keys %old_classes;
1400 $re = qr/\b($re)\b/;
1402 $code =~ s/$re/$old_classes{$1} || $1/eg;
1407 sub _load_external {
1408 my ($self, $class) = @_;
1410 return if $self->{skip_load_external};
1412 # so that we don't load our own classes, under any circumstances
1413 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1415 my $real_inc_path = $self->_find_class_in_inc($class);
1417 my $old_class = $self->_upgrading_classes->{$class}
1418 if $self->_rewriting;
1420 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1421 if $old_class && $old_class ne $class;
1423 return unless $real_inc_path || $old_real_inc_path;
1425 if ($real_inc_path) {
1426 # If we make it to here, we loaded an external definition
1427 warn qq/# Loaded external class definition for '$class'\n/
1430 my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path);
1432 if ($self->dynamic) { # load the class too
1433 eval_package_without_redefine_warnings($class, $code);
1436 $self->_ext_stmt($class,
1437 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1438 .qq|# They are now part of the custom portion of this file\n|
1439 .qq|# for you to hand-edit. If you do not either delete\n|
1440 .qq|# this section or remove that file from \@INC, this section\n|
1441 .qq|# will be repeated redundantly when you re-create this\n|
1442 .qq|# file again via Loader! See skip_load_external to disable\n|
1443 .qq|# this feature.\n|
1446 $self->_ext_stmt($class, $code);
1447 $self->_ext_stmt($class,
1448 qq|# End of lines loaded from '$real_inc_path' |
1452 if ($old_real_inc_path) {
1453 my $code = slurp_file $old_real_inc_path;
1455 $self->_ext_stmt($class, <<"EOF");
1457 # These lines were loaded from '$old_real_inc_path',
1458 # based on the Result class name that would have been created by an older
1459 # version of the Loader. For a static schema, this happens only once during
1460 # upgrade. See skip_load_external to disable this feature.
1463 $code = $self->_rewrite_old_classnames($code);
1465 if ($self->dynamic) {
1468 Detected external content in '$old_real_inc_path', a class name that would have
1469 been used by an older version of the Loader.
1471 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1472 new name of the Result.
1474 eval_package_without_redefine_warnings($class, $code);
1478 $self->_ext_stmt($class, $code);
1479 $self->_ext_stmt($class,
1480 qq|# End of lines loaded from '$old_real_inc_path' |
1487 Does the actual schema-construction work.
1494 $self->_load_tables(
1495 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1503 Rescan the database for changes. Returns a list of the newly added table
1506 The schema argument should be the schema class or object to be affected. It
1507 should probably be derived from the original schema_class used during L</load>.
1512 my ($self, $schema) = @_;
1514 $self->{schema} = $schema;
1515 $self->_relbuilder->{schema} = $schema;
1518 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1520 foreach my $table (@current) {
1521 if(!exists $self->_tables->{$table->sql_name}) {
1522 push(@created, $table);
1527 @current{map $_->sql_name, @current} = ();
1528 foreach my $table (values %{ $self->_tables }) {
1529 if (not exists $current{$table->sql_name}) {
1530 $self->_remove_table($table);
1534 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1536 my $loaded = $self->_load_tables(@current);
1538 foreach my $table (@created) {
1539 $self->monikers->{$table->sql_name} = $self->_table2moniker($table);
1542 return map { $self->monikers->{$_->sql_name} } @created;
1548 return if $self->{skip_relationships};
1550 return $self->{relbuilder} ||= do {
1551 my $relbuilder_suff =
1558 ->{$self->naming->{relationships}||$CURRENT_V} || '';
1560 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1561 $self->ensure_class_loaded($relbuilder_class);
1562 $relbuilder_class->new($self);
1567 my ($self, @tables) = @_;
1569 # Save the new tables to the tables list and compute monikers
1571 $self->_tables->{$_->sql_name} = $_;
1572 $self->monikers->{$_->sql_name} = $self->_table2moniker($_);
1575 # check for moniker clashes
1576 my $inverse_moniker_idx;
1577 foreach my $imtable (values %{ $self->_tables }) {
1578 push @{ $inverse_moniker_idx->{$self->monikers->{$imtable->sql_name}} }, $imtable;
1582 foreach my $moniker (keys %$inverse_moniker_idx) {
1583 my $imtables = $inverse_moniker_idx->{$moniker};
1584 if (@$imtables > 1) {
1585 my $different_databases =
1586 $imtables->[0]->can('database') && (uniq map $_->database||'', @$imtables) > 1;
1588 my $different_schemas =
1589 (uniq map $_->schema||'', @$imtables) > 1;
1591 if ($different_databases || $different_schemas) {
1592 my ($use_schema, $use_database) = (1, 0);
1594 if ($different_databases) {
1597 # If any monikers are in the same database, we have to distinguish by
1598 # both schema and database.
1600 $db_counts{$_}++ for map $_->database, @$imtables;
1601 $use_schema = any { $_ > 1 } values %db_counts;
1604 foreach my $tbl (@$imtables) { delete $self->monikers->{$tbl->sql_name}; }
1606 my $moniker_parts = [ @{ $self->moniker_parts } ];
1608 my $have_schema = 1 if any { $_ eq 'schema' } @{ $self->moniker_parts };
1609 my $have_database = 1 if any { $_ eq 'database' } @{ $self->moniker_parts };
1611 unshift @$moniker_parts, 'schema' if $use_schema && !$have_schema;
1612 unshift @$moniker_parts, 'database' if $use_database && !$have_database;
1614 local $self->{moniker_parts} = $moniker_parts;
1618 foreach my $tbl (@$imtables) { $new_monikers{$tbl->sql_name} = $self->_table2moniker($tbl); }
1619 foreach my $name (map $_->sql_name, @$imtables) { $self->monikers->{$name} = $new_monikers{$name}; }
1621 # check if there are still clashes
1624 while (my ($t, $m) = each %new_monikers) {
1625 push @{ $by_moniker{$m} }, $t;
1628 foreach my $m (grep @{ $by_moniker{$_} } > 1, keys %by_moniker) {
1629 push @clashes, sprintf ("tried disambiguating by moniker_parts, but tables %s still reduced to the same source moniker '%s'",
1630 join (', ', @{ $by_moniker{$m} }),
1636 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1637 join (', ', map $_->sql_name, @$imtables),
1645 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1646 . 'Change the naming style, or supply an explicit moniker_map: '
1647 . join ('; ', @clashes)
1652 foreach my $tbl (@tables) { $self->_make_src_class($tbl); }
1653 foreach my $tbl (@tables) { $self->_setup_src_meta($tbl); }
1655 if(!$self->skip_relationships) {
1656 # The relationship loader needs a working schema
1657 local $self->{quiet} = 1;
1658 local $self->{dump_directory} = $self->{temp_directory};
1659 $self->_reload_classes(\@tables);
1660 $self->_load_relationships(\@tables);
1662 # Remove that temp dir from INC so it doesn't get reloaded
1663 @INC = grep $_ ne $self->dump_directory, @INC;
1666 foreach my $tbl (@tables) { $self->_load_roles($tbl); }
1667 foreach my $tbl (map { $self->classes->{$_->sql_name} } @tables) { $self->_load_external($tbl); }
1669 # Reload without unloading first to preserve any symbols from external
1671 $self->_reload_classes(\@tables, { unload => 0 });
1673 # Drop temporary cache
1674 delete $self->{_cache};
1679 sub _reload_classes {
1680 my ($self, $tables, $opts) = @_;
1682 my @tables = @$tables;
1684 my $unload = $opts->{unload};
1685 $unload = 1 unless defined $unload;
1687 # so that we don't repeat custom sections
1688 @INC = grep $_ ne $self->dump_directory, @INC;
1690 $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables);
1692 unshift @INC, $self->dump_directory;
1695 my %have_source = map { $_ => $self->schema->source($_) }
1696 $self->schema->sources;
1698 for my $table (@tables) {
1699 my $moniker = $self->monikers->{$table->sql_name};
1700 my $class = $self->classes->{$table->sql_name};
1703 no warnings 'redefine';
1704 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1707 if (my $mc = $self->_moose_metaclass($class)) {
1710 Class::Unload->unload($class) if $unload;
1711 my ($source, $resultset_class);
1713 ($source = $have_source{$moniker})
1714 && ($resultset_class = $source->resultset_class)
1715 && ($resultset_class ne 'DBIx::Class::ResultSet')
1717 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1718 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1721 Class::Unload->unload($resultset_class) if $unload;
1722 $self->_reload_class($resultset_class) if $has_file;
1724 $self->_reload_class($class);
1726 push @to_register, [$moniker, $class];
1729 Class::C3->reinitialize;
1730 for (@to_register) {
1731 $self->schema->register_class(@$_);
1735 sub _moose_metaclass {
1736 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1740 my $mc = try { Class::MOP::class_of($class) }
1743 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1746 # We use this instead of ensure_class_loaded when there are package symbols we
1749 my ($self, $class) = @_;
1751 delete $INC{ +class_path($class) };
1754 eval_package_without_redefine_warnings ($class, "require $class");
1757 my $source = slurp_file $self->_get_dump_filename($class);
1758 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1762 sub _get_dump_filename {
1763 my ($self, $class) = (@_);
1765 $class =~ s{::}{/}g;
1766 return $self->dump_directory . q{/} . $class . q{.pm};
1769 =head2 get_dump_filename
1773 Returns the full path to the file for a class that the class has been or will
1774 be dumped to. This is a file in a temp dir for a dynamic schema.
1778 sub get_dump_filename {
1779 my ($self, $class) = (@_);
1781 local $self->{dump_directory} = $self->real_dump_directory;
1783 return $self->_get_dump_filename($class);
1786 sub _ensure_dump_subdirs {
1787 my ($self, $class) = (@_);
1789 my @name_parts = split(/::/, $class);
1790 pop @name_parts; # we don't care about the very last element,
1791 # which is a filename
1793 my $dir = $self->dump_directory;
1796 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1798 last if !@name_parts;
1799 $dir = File::Spec->catdir($dir, shift @name_parts);
1804 my ($self, @classes) = @_;
1806 my $schema_class = $self->schema_class;
1807 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1809 my $target_dir = $self->dump_directory;
1810 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1811 unless $self->dynamic or $self->quiet;
1815 . qq|package $schema_class;\n\n|
1816 . qq|# Created by DBIx::Class::Schema::Loader\n|
1817 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1820 = $self->only_autoclean
1821 ? 'namespace::autoclean'
1822 : 'MooseX::MarkAsMethods autoclean => 1'
1825 if ($self->use_moose) {
1827 $schema_text.= qq|use Moose;\nuse $autoclean;\nextends '$schema_base_class';\n\n|;
1830 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1833 my @schema_components = @{ $self->schema_components || [] };
1835 if (@schema_components) {
1836 my $schema_components = dump @schema_components;
1837 $schema_components = "($schema_components)" if @schema_components == 1;
1839 $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1842 if ($self->use_namespaces) {
1843 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1844 my $namespace_options;
1846 my @attr = qw/resultset_namespace default_resultset_class/;
1848 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1850 for my $attr (@attr) {
1852 my $code = dumper_squashed $self->$attr;
1853 $namespace_options .= qq| $attr => $code,\n|
1856 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1857 $schema_text .= qq|;\n|;
1860 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1864 local $self->{version_to_dump} = $self->schema_version_to_dump;
1865 $self->_write_classfile($schema_class, $schema_text, 1);
1868 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1870 foreach my $src_class (@classes) {
1873 . qq|package $src_class;\n\n|
1874 . qq|# Created by DBIx::Class::Schema::Loader\n|
1875 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1877 $src_text .= $self->_make_pod_heading($src_class);
1879 $src_text .= qq|use strict;\nuse warnings;\n\n|;
1881 $src_text .= $self->_base_class_pod($result_base_class)
1882 unless $result_base_class eq 'DBIx::Class::Core';
1884 if ($self->use_moose) {
1885 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse $autoclean;|;
1887 # these options 'use base' which is compile time
1888 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1889 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1892 $src_text .= qq|\nextends '$result_base_class';\n|;
1896 $src_text .= qq|use base '$result_base_class';\n|;
1899 $self->_write_classfile($src_class, $src_text);
1902 # remove Result dir if downgrading from use_namespaces, and there are no
1904 if (my $result_ns = $self->_downgrading_to_load_classes
1905 || $self->_rewriting_result_namespace) {
1906 my $result_namespace = $self->_result_namespace(
1911 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1912 $result_dir = $self->dump_directory . '/' . $result_dir;
1914 unless (my @files = glob "$result_dir/*") {
1919 warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
1923 my ($self, $version, $ts) = @_;
1924 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1927 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1930 sub _write_classfile {
1931 my ($self, $class, $text, $is_schema) = @_;
1933 my $filename = $self->_get_dump_filename($class);
1934 $self->_ensure_dump_subdirs($class);
1936 if (-f $filename && $self->really_erase_my_files) {
1937 warn "Deleting existing file '$filename' due to "
1938 . "'really_erase_my_files' setting\n" unless $self->quiet;
1942 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1943 = $self->_parse_generated_file($filename);
1945 if (! $old_gen && -f $filename) {
1946 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1947 . " it does not appear to have been generated by Loader"
1950 my $custom_content = $old_custom || '';
1952 # Use custom content from a renamed class, the class names in it are
1954 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1955 my $old_filename = $self->_get_dump_filename($renamed_class);
1957 if (-f $old_filename) {
1958 $custom_content = ($self->_parse_generated_file ($old_filename))[4];
1960 unlink $old_filename;
1964 $custom_content ||= $self->_default_custom_content($is_schema);
1966 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1967 # If there is already custom content, which does not have the Moose content, add it.
1968 if ($self->use_moose) {
1970 my $non_moose_custom_content = do {
1971 local $self->{use_moose} = 0;
1972 $self->_default_custom_content;
1975 if ($custom_content eq $non_moose_custom_content) {
1976 $custom_content = $self->_default_custom_content($is_schema);
1978 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1979 $custom_content .= $self->_default_custom_content($is_schema);
1982 elsif (defined $self->use_moose && $old_gen) {
1983 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'
1984 if $old_gen =~ /use \s+ MooseX?\b/x;
1987 $custom_content = $self->_rewrite_old_classnames($custom_content);
1990 for @{$self->{_dump_storage}->{$class} || []};
1992 if ($self->filter_generated_code) {
1993 my $filter = $self->filter_generated_code;
1995 if (ref $filter eq 'CODE') {
1997 ($is_schema ? 'schema' : 'result'),
2003 my ($fh, $temp_file) = tempfile();
2005 binmode $fh, ':encoding(UTF-8)';
2009 open my $out, qq{$filter < "$temp_file"|}
2010 or croak "Could not open pipe to $filter: $!";
2012 $text = decode('UTF-8', do { local $/; <$out> });
2014 $text =~ s/$CR?$LF/\n/g;
2018 my $exit_code = $? >> 8;
2021 or croak "Could not remove temporary file '$temp_file': $!";
2023 if ($exit_code != 0) {
2024 croak "filter '$filter' exited non-zero: $exit_code";
2027 if (not $text or not $text =~ /\bpackage\b/) {
2028 warn("$class skipped due to filter") if $self->debug;
2033 # Check and see if the dump is in fact different
2037 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
2038 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
2039 return unless $self->_upgrading_from && $is_schema;
2043 $text .= $self->_sig_comment(
2044 $self->version_to_dump,
2045 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
2048 open(my $fh, '>:encoding(UTF-8)', $filename)
2049 or croak "Cannot open '$filename' for writing: $!";
2051 # Write the top half and its MD5 sum
2052 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
2054 # Write out anything loaded via external partial class file in @INC
2056 for @{$self->{_ext_storage}->{$class} || []};
2058 # Write out any custom content the user has added
2059 print $fh $custom_content;
2062 or croak "Error closing '$filename': $!";
2065 sub _default_moose_custom_content {
2066 my ($self, $is_schema) = @_;
2068 if (not $is_schema) {
2069 return qq|\n__PACKAGE__->meta->make_immutable;|;
2072 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
2075 sub _default_custom_content {
2076 my ($self, $is_schema) = @_;
2077 my $default = qq|\n\n# You can replace this text with custom|
2078 . qq| code or comments, and it will be preserved on regeneration|;
2079 if ($self->use_moose) {
2080 $default .= $self->_default_moose_custom_content($is_schema);
2082 $default .= qq|\n1;\n|;
2086 sub _parse_generated_file {
2087 my ($self, $fn) = @_;
2089 return unless -f $fn;
2091 open(my $fh, '<:encoding(UTF-8)', $fn)
2092 or croak "Cannot open '$fn' for reading: $!";
2095 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
2097 my ($md5, $ts, $ver, $gen);
2103 # Pull out the version and timestamp from the line above
2104 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m;
2107 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"
2108 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
2117 my $custom = do { local $/; <$fh> }
2121 $custom =~ s/$CRLF|$LF/\n/g;
2125 return ($gen, $md5, $ver, $ts, $custom);
2133 warn "$target: use $_;" if $self->debug;
2134 $self->_raw_stmt($target, "use $_;");
2142 my $blist = join(q{ }, @_);
2144 return unless $blist;
2146 warn "$target: use base qw/$blist/;" if $self->debug;
2147 $self->_raw_stmt($target, "use base qw/$blist/;");
2154 my $rlist = join(q{, }, map { qq{'$_'} } @_);
2156 return unless $rlist;
2158 warn "$target: with $rlist;" if $self->debug;
2159 $self->_raw_stmt($target, "\nwith $rlist;");
2162 sub _result_namespace {
2163 my ($self, $schema_class, $ns) = @_;
2164 my @result_namespace;
2166 $ns = $ns->[0] if ref $ns;
2168 if ($ns =~ /^\+(.*)/) {
2169 # Fully qualified namespace
2170 @result_namespace = ($1)
2173 # Relative namespace
2174 @result_namespace = ($schema_class, $ns);
2177 return wantarray ? @result_namespace : join '::', @result_namespace;
2180 # Create class with applicable bases, setup monikers, etc
2181 sub _make_src_class {
2182 my ($self, $table) = @_;
2184 my $schema = $self->schema;
2185 my $schema_class = $self->schema_class;
2187 my $table_moniker = $self->monikers->{$table->sql_name};
2188 my @result_namespace = ($schema_class);
2189 if ($self->use_namespaces) {
2190 my $result_namespace = $self->result_namespace || 'Result';
2191 @result_namespace = $self->_result_namespace(
2196 my $table_class = join(q{::}, @result_namespace, $table_moniker);
2198 if ((my $upgrading_v = $self->_upgrading_from)
2199 || $self->_rewriting) {
2200 local $self->naming->{monikers} = $upgrading_v
2203 my @result_namespace = @result_namespace;
2204 if ($self->_upgrading_from_load_classes) {
2205 @result_namespace = ($schema_class);
2207 elsif (my $ns = $self->_downgrading_to_load_classes) {
2208 @result_namespace = $self->_result_namespace(
2213 elsif ($ns = $self->_rewriting_result_namespace) {
2214 @result_namespace = $self->_result_namespace(
2220 my $old_table_moniker = do {
2221 local $self->naming->{monikers} = $upgrading_v;
2222 $self->_table2moniker($table);
2225 my $old_class = join(q{::}, @result_namespace, $old_table_moniker);
2227 $self->_upgrading_classes->{$table_class} = $old_class
2228 unless $table_class eq $old_class;
2231 $self->classes->{$table->sql_name} = $table_class;
2232 $self->moniker_to_table->{$table_moniker} = $table;
2233 $self->class_to_table->{$table_class} = $table;
2235 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
2237 $self->_use ($table_class, @{$self->additional_classes});
2239 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
2241 $self->_inject($table_class, @{$self->left_base_classes});
2243 my @components = @{ $self->components || [] };
2245 push @components, @{ $self->result_components_map->{$table_moniker} }
2246 if exists $self->result_components_map->{$table_moniker};
2248 my @fq_components = @components;
2249 foreach my $component (@fq_components) {
2250 if ($component !~ s/^\+//) {
2251 $component = "DBIx::Class::$component";
2255 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
2257 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
2259 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
2261 $self->_inject($table_class, @{$self->additional_base_classes});
2264 sub _is_result_class_method {
2265 my ($self, $name, $table) = @_;
2267 my $table_moniker = $table ? $self->monikers->{$table->sql_name} : '';
2269 $self->_result_class_methods({})
2270 if not defined $self->_result_class_methods;
2272 if (not exists $self->_result_class_methods->{$table_moniker}) {
2273 my (@methods, %methods);
2274 my $base = $self->result_base_class || 'DBIx::Class::Core';
2276 my @components = @{ $self->components || [] };
2278 push @components, @{ $self->result_components_map->{$table_moniker} }
2279 if exists $self->result_components_map->{$table_moniker};
2281 for my $c (@components) {
2282 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
2285 my @roles = @{ $self->result_roles || [] };
2287 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2288 if exists $self->result_roles_map->{$table_moniker};
2290 for my $class ($base, @components,
2291 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
2292 $self->ensure_class_loaded($class);
2294 push @methods, @{ Class::Inspector->methods($class) || [] };
2297 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
2299 @methods{@methods} = ();
2301 $self->_result_class_methods->{$table_moniker} = \%methods;
2303 my $result_methods = $self->_result_class_methods->{$table_moniker};
2305 return exists $result_methods->{$name};
2308 sub _resolve_col_accessor_collisions {
2309 my ($self, $table, $col_info) = @_;
2311 while (my ($col, $info) = each %$col_info) {
2312 my $accessor = $info->{accessor} || $col;
2314 next if $accessor eq 'id'; # special case (very common column)
2316 if ($self->_is_result_class_method($accessor, $table)) {
2319 if (my $map = $self->col_collision_map) {
2320 for my $re (keys %$map) {
2321 if (my @matches = $col =~ /$re/) {
2322 $info->{accessor} = sprintf $map->{$re}, @matches;
2330 Column '$col' in table '$table' collides with an inherited method.
2331 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
2333 $info->{accessor} = undef;
2339 # use the same logic to run moniker_map, col_accessor_map
2341 my ( $self, $map, $default_code, $ident, @extra ) = @_;
2343 my $default_ident = $default_code->( $ident, @extra );
2345 if( $map && ref $map eq 'HASH' ) {
2346 $new_ident = $map->{ $ident };
2348 elsif( $map && ref $map eq 'CODE' ) {
2349 $new_ident = $map->( $ident, $default_ident, @extra );
2352 $new_ident ||= $default_ident;
2357 sub _default_column_accessor_name {
2358 my ( $self, $column_name ) = @_;
2360 my $preserve = ($self->naming->{column_accessors}||'') eq 'preserve';
2362 my $v = $self->_get_naming_v('column_accessors');
2364 my $accessor_name = $preserve ?
2365 $self->_to_identifier('column_accessors', $column_name) # assume CamelCase
2367 $self->_to_identifier('column_accessors', $column_name, '_');
2369 $accessor_name =~ s/\W+/_/g; # only if naming < v8, otherwise to_identifier
2373 return $accessor_name;
2375 elsif ($v < 7 || (not $self->preserve_case)) {
2376 # older naming just lc'd the col accessor and that's all.
2377 return lc $accessor_name;
2380 return join '_', map lc, split_name $column_name, $v;
2383 sub _make_column_accessor_name {
2384 my ($self, $column_name, $column_context_info ) = @_;
2386 my $accessor = $self->_run_user_map(
2387 $self->col_accessor_map,
2388 sub { $self->_default_column_accessor_name( shift ) },
2390 $column_context_info,
2396 # Set up metadata (cols, pks, etc)
2397 sub _setup_src_meta {
2398 my ($self, $table) = @_;
2400 my $schema = $self->schema;
2401 my $schema_class = $self->schema_class;
2403 my $table_class = $self->classes->{$table->sql_name};
2404 my $table_moniker = $self->monikers->{$table->sql_name};
2406 $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
2408 my $cols = $self->_table_columns($table);
2409 my $col_info = $self->__columns_info_for($table);
2411 ### generate all the column accessor names
2412 while (my ($col, $info) = each %$col_info) {
2413 # hashref of other info that could be used by
2414 # user-defined accessor map functions
2416 table_class => $table_class,
2417 table_moniker => $table_moniker,
2418 table_name => $table, # bugwards compatibility, RT#84050
2420 full_table_name => $table->dbic_name,
2421 schema_class => $schema_class,
2422 column_info => $info,
2425 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2428 $self->_resolve_col_accessor_collisions($table, $col_info);
2430 # prune any redundant accessor names
2431 while (my ($col, $info) = each %$col_info) {
2432 no warnings 'uninitialized';
2433 delete $info->{accessor} if $info->{accessor} eq $col;
2436 my $fks = $self->_table_fk_info($table);
2438 foreach my $fkdef (@$fks) {
2439 for my $col (@{ $fkdef->{local_columns} }) {
2440 $col_info->{$col}{is_foreign_key} = 1;
2444 my $pks = $self->_table_pk_info($table) || [];
2446 my %uniq_tag; # used to eliminate duplicate uniqs
2448 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2450 my $uniqs = $self->_table_uniq_info($table) || [];
2453 foreach my $uniq (@$uniqs) {
2454 my ($name, $cols) = @$uniq;
2455 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2456 push @uniqs, [$name, $cols];
2459 my @non_nullable_uniqs = grep {
2460 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2463 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2464 my @by_colnum = sort { $b->[0] <=> $a->[0] }
2465 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2467 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2468 my @keys = map $_->[1], @by_colnum;
2472 # remove the uniq from list
2473 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2479 foreach my $pkcol (@$pks) {
2480 $col_info->{$pkcol}{is_nullable} = 0;
2486 map { $_, ($col_info->{$_}||{}) } @$cols
2489 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2492 # Sort unique constraints by constraint name for repeatable results (rels
2493 # are sorted as well elsewhere.)
2494 @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs;
2496 foreach my $uniq (@uniqs) {
2497 my ($name, $cols) = @$uniq;
2498 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2502 sub __columns_info_for {
2503 my ($self, $table) = @_;
2505 my $result = $self->_columns_info_for($table);
2507 while (my ($col, $info) = each %$result) {
2508 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
2509 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2511 $result->{$col} = $info;
2519 Returns a sorted list of loaded tables, using the original database table
2527 return values %{$self->_tables};
2531 my ($self, $naming_key) = @_;
2535 if (($self->naming->{$naming_key}||'') =~ /^v(\d+)\z/) {
2539 ($v) = $CURRENT_V =~ /^v(\d+)\z/;
2545 sub _to_identifier {
2546 my ($self, $naming_key, $name, $sep_char, $force) = @_;
2548 my $v = $self->_get_naming_v($naming_key);
2550 my $to_identifier = $self->naming->{force_ascii} ?
2551 \&String::ToIdentifier::EN::to_identifier
2552 : \&String::ToIdentifier::EN::Unicode::to_identifier;
2554 return $v >= 8 || $force ? $to_identifier->($name, $sep_char) : $name;
2557 # Make a moniker from a table
2558 sub _default_table2moniker {
2559 my ($self, $table) = @_;
2561 my $v = $self->_get_naming_v('monikers');
2563 my @name_parts = map $table->$_, @{ $self->moniker_parts };
2565 my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
2569 foreach my $i (0 .. $#name_parts) {
2570 my $part = $name_parts[$i];
2572 if ($i != $name_idx || $v >= 8) {
2573 $part = $self->_to_identifier('monikers', $part, '_', 1);
2576 if ($i == $name_idx && $v == 5) {
2577 $part = Lingua::EN::Inflect::Number::to_S($part);
2580 my @part_parts = map lc, $v > 6 ?
2581 # use v8 semantics for all moniker parts except name
2582 ($i == $name_idx ? split_name $part, $v : split_name $part)
2583 : split /[\W_]+/, $part;
2585 if ($i == $name_idx && $v >= 6) {
2586 my $as_phrase = join ' ', @part_parts;
2588 my $inflected = ($self->naming->{monikers}||'') eq 'plural' ?
2589 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2591 ($self->naming->{monikers}||'') eq 'preserve' ?
2594 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2596 @part_parts = split /\s+/, $inflected;
2599 push @all_parts, map ucfirst, @part_parts;
2602 return join '', @all_parts;
2605 sub _table2moniker {
2606 my ( $self, $table ) = @_;
2608 $self->_run_user_map(
2610 sub { $self->_default_table2moniker( shift ) },
2615 sub _load_relationships {
2616 my ($self, $tables) = @_;
2620 foreach my $table (@$tables) {
2621 my $local_moniker = $self->monikers->{$table->sql_name};
2623 my $tbl_fk_info = $self->_table_fk_info($table);
2625 foreach my $fkdef (@$tbl_fk_info) {
2626 $fkdef->{local_table} = $table;
2627 $fkdef->{local_moniker} = $local_moniker;
2628 $fkdef->{remote_source} =
2629 $self->monikers->{$fkdef->{remote_table}->sql_name};
2631 my $tbl_uniq_info = $self->_table_uniq_info($table);
2633 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2636 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2638 foreach my $src_class (sort keys %$rel_stmts) {
2640 my @src_stmts = map $_->[2],
2646 ($_->{method} eq 'many_to_many' ? 1 : 0),
2649 ], @{ $rel_stmts->{$src_class} };
2651 foreach my $stmt (@src_stmts) {
2652 $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2658 my ($self, $table) = @_;
2660 my $table_moniker = $self->monikers->{$table->sql_name};
2661 my $table_class = $self->classes->{$table->sql_name};
2663 my @roles = @{ $self->result_roles || [] };
2664 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2665 if exists $self->result_roles_map->{$table_moniker};
2668 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2670 $self->_with($table_class, @roles);
2674 # Overload these in driver class:
2676 # Returns an arrayref of column names
2677 sub _table_columns { croak "ABSTRACT METHOD" }
2679 # Returns arrayref of pk col names
2680 sub _table_pk_info { croak "ABSTRACT METHOD" }
2682 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2683 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2685 # Returns an arrayref of foreign key constraints, each
2686 # being a hashref with 3 keys:
2687 # local_columns (arrayref), remote_columns (arrayref), remote_table
2688 sub _table_fk_info { croak "ABSTRACT METHOD" }
2690 # Returns an array of lower case table names
2691 sub _tables_list { croak "ABSTRACT METHOD" }
2693 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2699 # generate the pod for this statement, storing it with $self->_pod
2700 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2702 my $args = dump(@_);
2703 $args = '(' . $args . ')' if @_ < 2;
2704 my $stmt = $method . $args . q{;};
2706 warn qq|$class\->$stmt\n| if $self->debug;
2707 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2711 sub _make_pod_heading {
2712 my ($self, $class) = @_;
2714 return '' if not $self->generate_pod;
2716 my $table = $self->class_to_table->{$class};
2719 my $pcm = $self->pod_comment_mode;
2720 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2721 $comment = $self->__table_comment($table);
2722 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2723 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2724 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2726 $pod .= "=head1 NAME\n\n";
2728 my $table_descr = $class;
2729 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2731 $pod .= "$table_descr\n\n";
2733 if ($comment and $comment_in_desc) {
2734 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2741 # generates the accompanying pod for a DBIC class method statement,
2742 # storing it with $self->_pod
2748 if ($method eq 'table') {
2750 $table = $$table if ref $table eq 'SCALAR';
2751 $self->_pod($class, "=head1 TABLE: C<$table>");
2752 $self->_pod_cut($class);
2754 elsif ( $method eq 'add_columns' ) {
2755 $self->_pod( $class, "=head1 ACCESSORS" );
2756 my $col_counter = 0;
2758 while( my ($name,$attrs) = splice @cols,0,2 ) {
2760 $self->_pod( $class, '=head2 ' . $name );
2761 $self->_pod( $class,
2763 my $s = $attrs->{$_};
2764 $s = !defined $s ? 'undef' :
2765 length($s) == 0 ? '(empty string)' :
2766 ref($s) eq 'SCALAR' ? $$s :
2767 ref($s) ? dumper_squashed $s :
2768 looks_like_number($s) ? $s : qq{'$s'};
2771 } sort keys %$attrs,
2773 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2774 $self->_pod( $class, $comment );
2777 $self->_pod_cut( $class );
2778 } elsif ( $method =~ /^(?:belongs_to|has_many|might_have)\z/ ) {
2779 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2780 my ( $accessor, $rel_class ) = @_;
2781 $self->_pod( $class, "=head2 $accessor" );
2782 $self->_pod( $class, 'Type: ' . $method );
2783 $self->_pod( $class, "Related object: L<$rel_class>" );
2784 $self->_pod_cut( $class );
2785 $self->{_relations_started} { $class } = 1;
2786 } elsif ( $method eq 'many_to_many' ) {
2787 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2788 my ( $accessor, $rel1, $rel2 ) = @_;
2789 $self->_pod( $class, "=head2 $accessor" );
2790 $self->_pod( $class, 'Type: many_to_many' );
2791 $self->_pod( $class, "Composing rels: L</$rel1> -> $rel2" );
2792 $self->_pod_cut( $class );
2793 $self->{_relations_started} { $class } = 1;
2795 elsif ($method eq 'add_unique_constraint') {
2796 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2797 unless $self->{_uniqs_started}{$class};
2799 my ($name, $cols) = @_;
2801 $self->_pod($class, "=head2 C<$name>");
2802 $self->_pod($class, '=over 4');
2804 foreach my $col (@$cols) {
2805 $self->_pod($class, "=item \* L</$col>");
2808 $self->_pod($class, '=back');
2809 $self->_pod_cut($class);
2811 $self->{_uniqs_started}{$class} = 1;
2813 elsif ($method eq 'set_primary_key') {
2814 $self->_pod($class, "=head1 PRIMARY KEY");
2815 $self->_pod($class, '=over 4');
2817 foreach my $col (@_) {
2818 $self->_pod($class, "=item \* L</$col>");
2821 $self->_pod($class, '=back');
2822 $self->_pod_cut($class);
2826 sub _pod_class_list {
2827 my ($self, $class, $title, @classes) = @_;
2829 return unless @classes && $self->generate_pod;
2831 $self->_pod($class, "=head1 $title");
2832 $self->_pod($class, '=over 4');
2834 foreach my $link (@classes) {
2835 $self->_pod($class, "=item * L<$link>");
2838 $self->_pod($class, '=back');
2839 $self->_pod_cut($class);
2842 sub _base_class_pod {
2843 my ($self, $base_class) = @_;
2845 return '' unless $self->generate_pod;
2848 =head1 BASE CLASS: L<$base_class>
2855 sub _filter_comment {
2856 my ($self, $txt) = @_;
2858 $txt = '' if not defined $txt;
2860 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2865 sub __table_comment {
2868 if (my $code = $self->can('_table_comment')) {
2869 return $self->_filter_comment($self->$code(@_));
2875 sub __column_comment {
2878 if (my $code = $self->can('_column_comment')) {
2879 return $self->_filter_comment($self->$code(@_));
2885 # Stores a POD documentation
2887 my ($self, $class, $stmt) = @_;
2888 $self->_raw_stmt( $class, "\n" . $stmt );
2892 my ($self, $class ) = @_;
2893 $self->_raw_stmt( $class, "\n=cut\n" );
2896 # Store a raw source line for a class (for dumping purposes)
2898 my ($self, $class, $stmt) = @_;
2899 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2902 # Like above, but separately for the externally loaded stuff
2904 my ($self, $class, $stmt) = @_;
2905 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2908 sub _custom_column_info {
2909 my ( $self, $table_name, $column_name, $column_info ) = @_;
2911 if (my $code = $self->custom_column_info) {
2912 return $code->($table_name, $column_name, $column_info) || {};
2917 sub _datetime_column_info {
2918 my ( $self, $table_name, $column_name, $column_info ) = @_;
2920 my $type = $column_info->{data_type} || '';
2921 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2922 or ($type =~ /date|timestamp/i)) {
2923 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2924 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2930 my ($self, $name) = @_;
2932 return $self->preserve_case ? $name : lc($name);
2936 my ($self, $name) = @_;
2938 return $self->preserve_case ? $name : uc($name);
2942 my ($self, $table) = @_;
2945 my $schema = $self->schema;
2946 # in older DBIC it's a private method
2947 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2948 $schema->$unregister(delete $self->monikers->{$table->sql_name});
2949 delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}};
2950 delete $self->_tables->{$table->sql_name};
2954 # remove the dump dir from @INC on destruction
2958 @INC = grep $_ ne $self->dump_directory, @INC;
2963 Returns a hashref of loaded table to moniker mappings. There will
2964 be two entries for each table, the original name and the "normalized"
2965 name, in the case that the two are different (such as databases
2966 that like uppercase table names, or preserve your original mixed-case
2967 definitions, or what-have-you).
2971 Returns a hashref of table to class mappings. In some cases it will
2972 contain multiple entries per table for the original and normalized table
2973 names, as above in L</monikers>.
2975 =head1 NON-ENGLISH DATABASES
2977 If you use the loader on a database with table and column names in a language
2978 other than English, you will want to turn off the English language specific
2981 To do so, use something like this in your loader options:
2983 naming => { monikers => 'v4' },
2984 inflect_singular => sub { "$_[0]_rel" },
2985 inflect_plural => sub { "$_[0]_rel" },
2987 =head1 COLUMN ACCESSOR COLLISIONS
2989 Occasionally you may have a column name that collides with a perl method, such
2990 as C<can>. In such cases, the default action is to set the C<accessor> of the
2991 column spec to C<undef>.
2993 You can then name the accessor yourself by placing code such as the following
2996 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2998 Another option is to use the L</col_collision_map> option.
3000 =head1 RELATIONSHIP NAME COLLISIONS
3002 In very rare cases, you may get a collision between a generated relationship
3003 name and a method in your Result class, for example if you have a foreign key
3004 called C<belongs_to>.
3006 This is a problem because relationship names are also relationship accessor
3007 methods in L<DBIx::Class>.
3009 The default behavior is to append C<_rel> to the relationship name and print
3010 out a warning that refers to this text.
3012 You can also control the renaming with the L</rel_collision_map> option.
3016 L<DBIx::Class::Schema::Loader>, L<dbicdump>
3020 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
3024 This library is free software; you can redistribute it and/or modify it under
3025 the same terms as Perl itself.
3030 # vim:et sts=4 sw=4 tw=0: