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 sigwarn_silencer/;
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.07037';
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
112 moniker_part_separator
116 my $CURRENT_V = 'v7';
119 schema_components schema_base_class result_base_class
120 additional_base_classes left_base_classes additional_classes components
126 my $CRLF = "\x0d\x0a";
130 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
134 See L<DBIx::Class::Schema::Loader>.
138 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
139 classes, and implements the common functionality between them.
141 =head1 CONSTRUCTOR OPTIONS
143 These constructor options are the base options for
144 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
146 =head2 skip_relationships
148 Skip setting up relationships. The default is to attempt the loading
151 =head2 skip_load_external
153 Skip loading of other classes in @INC. The default is to merge all other classes
154 with the same name found in @INC into the schema file we are creating.
158 Static schemas (ones dumped to disk) will, by default, use the new-style
159 relationship names and singularized Results, unless you're overwriting an
160 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
161 which case the backward compatible RelBuilder will be activated, and the
162 appropriate monikerization used.
168 will disable the backward-compatible RelBuilder and use
169 the new-style relationship names along with singularized Results, even when
170 overwriting a dump made with an earlier version.
172 The option also takes a hashref:
175 relationships => 'v8',
177 column_accessors => 'v8',
183 naming => { ALL => 'v8', force_ascii => 1 }
191 Set L</relationships>, L</monikers> and L</column_accessors> to the specified
196 How to name relationship accessors.
200 How to name Result classes.
202 =item column_accessors
204 How to name column accessors in Result classes.
208 For L</v8> mode and later, uses L<String::ToIdentifier::EN> instead of
209 L<String::ToIdentifier::EM::Unicode> to force monikers and other identifiers to
220 Latest style, whatever that happens to be.
224 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
228 Monikers singularized as whole words, C<might_have> relationships for FKs on
229 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
231 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
236 All monikers and relationships are inflected using
237 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
238 from relationship names.
240 In general, there is very little difference between v5 and v6 schemas.
244 This mode is identical to C<v6> mode, except that monikerization of CamelCase
245 table names is also done better (but best in v8.)
247 CamelCase column names in case-preserving mode will also be handled better
248 for relationship name inflection (but best in v8.) See L</preserve_case>.
250 In this mode, CamelCase L</column_accessors> are normalized based on case
251 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
257 The default mode is L</v7>, to get L</v8> mode, you have to specify it in
258 L</naming> explicitly until C<0.08> comes out.
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<.>.
265 CamelCase identifiers with words in all caps, e.g. C<VLANValidID> are supported
266 correctly in this mode.
268 For relationships, belongs_to accessors are made from column names by stripping
269 postfixes other than C<_id> as well, for example just C<Id>, C<_?ref>, C<_?cd>,
270 C<_?code> and C<_?num>, case insensitively.
274 For L</monikers>, this option does not inflect the table names but makes
275 monikers based on the actual name. For L</column_accessors> this option does
276 not normalize CamelCase column names to lowercase column accessors, but makes
277 accessors that are the same names as the columns (with any non-\w chars
278 replaced with underscores.)
282 For L</monikers>, singularizes the names using the most current inflector. This
283 is the same as setting the option to L</current>.
287 For L</monikers>, pluralizes the names, using the most current inflector.
291 Dynamic schemas will always default to the 0.04XXX relationship names and won't
292 singularize Results for backward compatibility, to activate the new RelBuilder
293 and singularization put this in your C<Schema.pm> file:
295 __PACKAGE__->naming('current');
297 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
298 next major version upgrade:
300 __PACKAGE__->naming('v7');
304 If true, will not print the usual C<Dumping manual schema ... Schema dump
305 completed.> messages. Does not affect warnings (except for warnings related to
306 L</really_erase_my_files>.)
310 By default POD will be generated for columns and relationships, using database
311 metadata for the text if available and supported.
313 Comment metadata can be stored in two ways.
315 The first is that you can create two tables named C<table_comments> and
316 C<column_comments> respectively. These tables must exist in the same database
317 and schema as the tables they describe. They both need to have columns named
318 C<table_name> and C<comment_text>. The second one needs to have a column named
319 C<column_name>. Then data stored in these tables will be used as a source of
320 metadata about tables and comments.
322 (If you wish you can change the name of these tables with the parameters
323 L</table_comments_table> and L</column_comments_table>.)
325 As a fallback you can use built-in commenting mechanisms. Currently this is
326 only supported for PostgreSQL, Oracle and MySQL. To create comments in
327 PostgreSQL you add statements of the form C<COMMENT ON TABLE some_table IS
328 '...'>, the same syntax is used in Oracle. To create comments in MySQL you add
329 C<COMMENT '...'> to the end of the column or table definition. Note that MySQL
330 restricts the length of comments, and also does not handle complex Unicode
333 Set this to C<0> to turn off all POD generation.
335 =head2 pod_comment_mode
337 Controls where table comments appear in the generated POD. Smaller table
338 comments are appended to the C<NAME> section of the documentation, and larger
339 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
340 section to be generated with the comment always, only use C<NAME>, or choose
341 the length threshold at which the comment is forced into the description.
347 Use C<NAME> section only.
351 Force C<DESCRIPTION> always.
355 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
360 =head2 pod_comment_spillover_length
362 When pod_comment_mode is set to C<auto>, this is the length of the comment at
363 which it will be forced into a separate description section.
367 =head2 table_comments_table
369 The table to look for comments about tables in. By default C<table_comments>.
370 See L</generate_pod> for details.
372 This must not be a fully qualified name, the table will be looked for in the
373 same database and schema as the table whose comment is being retrieved.
375 =head2 column_comments_table
377 The table to look for comments about columns in. By default C<column_comments>.
378 See L</generate_pod> for details.
380 This must not be a fully qualified name, the table will be looked for in the
381 same database and schema as the table/column whose comment is being retrieved.
383 =head2 relationship_attrs
385 Hashref of attributes to pass to each generated relationship, listed by type.
386 Also supports relationship type 'all', containing options to pass to all
387 generated relationships. Attributes set for more specific relationship types
388 override those set in 'all', and any attributes specified by this option
389 override the introspected attributes of the foreign key if any.
393 relationship_attrs => {
394 has_many => { cascade_delete => 1, cascade_copy => 1 },
395 might_have => { cascade_delete => 1, cascade_copy => 1 },
398 use this to turn L<DBIx::Class> cascades to on on your
399 L<has_many|DBIx::Class::Relationship/has_many> and
400 L<might_have|DBIx::Class::Relationship/might_have> relationships, they default
403 Can also be a coderef, for more precise control, in which case the coderef gets
404 this hash of parameters (as a list:)
406 rel_name # the name of the relationship
407 rel_type # the type of the relationship: 'belongs_to', 'has_many' or 'might_have'
408 local_source # the DBIx::Class::ResultSource object for the source the rel is *from*
409 remote_source # the DBIx::Class::ResultSource object for the source the rel is *to*
410 local_table # a DBIx::Class::Schema::Loader::Table object for the table of the source the rel is from
411 local_cols # an arrayref of column names of columns used in the rel in the source it is from
412 remote_table # a DBIx::Class::Schema::Loader::Table object for the table of the source the rel is to
413 remote_cols # an arrayref of column names of columns used in the rel in the source it is to
414 attrs # the attributes that would be set
416 it should return the new hashref of attributes, or nothing for no changes.
420 relationship_attrs => sub {
423 say "the relationship name is: $p{rel_name}";
424 say "the relationship is a: $p{rel_type}";
425 say "the local class is: ", $p{local_source}->result_class;
426 say "the remote class is: ", $p{remote_source}->result_class;
427 say "the local table is: ", $p{local_table}->sql_name;
428 say "the rel columns in the local table are: ", (join ", ", @{$p{local_cols}});
429 say "the remote table is: ", $p{remote_table}->sql_name;
430 say "the rel columns in the remote table are: ", (join ", ", @{$p{remote_cols}});
432 if ($p{local_table} eq 'dogs' && @{$p{local_cols}} == 1 && $p{local_cols}[0] eq 'name') {
433 $p{attrs}{could_be_snoopy} = 1;
439 These are the default attributes:
450 on_delete => 'CASCADE',
451 on_update => 'CASCADE',
455 For L<belongs_to|DBIx::Class::Relationship/belongs_to> relationships, these
456 defaults are overridden by the attributes introspected from the foreign key in
457 the database, if this information is available (and the driver is capable of
460 This information overrides the defaults mentioned above, and is then itself
461 overridden by the user's L</relationship_attrs> for C<belongs_to> if any are
464 In general, for most databases, for a plain foreign key with no rules, the
465 values for a L<belongs_to|DBIx::Class::Relationship/belongs_to> relationship
468 on_delete => 'NO ACTION',
469 on_update => 'NO ACTION',
472 In the cases where an attribute is not supported by the DB, a value matching
473 the actual behavior is used, for example Oracle does not support C<ON UPDATE>
474 rules, so C<on_update> is set to C<NO ACTION>. This is done so that the
475 behavior of the schema is preserved when cross deploying to a different RDBMS
476 such as SQLite for testing.
478 In the cases where the DB does not support C<DEFERRABLE> foreign keys, the
479 value is set to C<1> if L<DBIx::Class> has a working C<<
480 $storage->with_deferred_fk_checks >>. This is done so that the same
481 L<DBIx::Class> code can be used, and cross deployed from and to such databases.
485 If set to true, each constructive L<DBIx::Class> statement the loader
486 decides to execute will be C<warn>-ed before execution.
490 Set the name of the schema to load (schema in the sense that your database
493 Can be set to an arrayref of schema names for multiple schemas, or the special
494 value C<%> for all schemas.
496 For MSSQL, Sybase ASE, and Informix can be set to a hashref of databases as
497 keys and arrays of owners as values, set to the value:
501 for all owners in all databases.
503 Name clashes resulting from the same table name in different databases/schemas
504 will be resolved automatically by prefixing the moniker with the database
507 To prefix/suffix all monikers with the database and/or schema, see
512 The database table names are represented by the
513 L<DBIx::Class::Schema::Loader::Table> class in the loader, the
514 L<DBIx::Class::Schema::Loader::Table::Sybase> class for Sybase ASE and
515 L<DBIx::Class::Schema::Loader::Table::Informix> for Informix.
517 Monikers are created normally based on just the
518 L<name|DBIx::Class::Schema::Loader::DBObject/name> property, corresponding to
519 the table name, but can consist of other parts of the fully qualified name of
522 The L</moniker_parts> option is an arrayref of methods on the table class
523 corresponding to parts of the fully qualified table name, defaulting to
524 C<['name']>, in the order those parts are used to create the moniker name.
525 The parts are joined together using L</moniker_part_separator>.
527 The C<'name'> entry B<must> be present.
529 Below is a table of supported databases and possible L</moniker_parts>.
533 =item * DB2, Firebird, mysql, Oracle, Pg, SQLAnywhere, SQLite, MS Access
537 =item * Informix, MSSQL, Sybase ASE
539 C<database>, C<schema>, C<name>
543 =head2 moniker_part_separator
545 String used to join L</moniker_parts> when creating the moniker.
546 Defaults to the empty string. Use C<::> to get a separate namespace per
547 database and/or schema.
551 Only load matching tables.
555 Exclude matching tables.
557 These can be specified either as a regex (preferrably on the C<qr//>
558 form), or as an arrayref of arrayrefs. Regexes are matched against
559 the (unqualified) table name, while arrayrefs are matched according to
564 db_schema => [qw(some_schema other_schema)],
565 moniker_parts => [qw(schema name)],
567 [ qr/\Asome_schema\z/ => qr/\A(?:foo|bar)\z/ ],
568 [ qr/\Aother_schema\z/ => qr/\Abaz\z/ ],
571 In this case only the tables C<foo> and C<bar> in C<some_schema> and
572 C<baz> in C<other_schema> will be dumped.
576 Overrides the default table name to moniker translation. Either
582 a nested hashref, which will be traversed according to L</moniker_parts>
586 moniker_parts => [qw(schema name)],
593 In which case the table C<bar> in the C<foo> schema would get the moniker
598 a hashref of unqualified table name keys and moniker values
602 a coderef for a translator function taking a L<table
603 object|DBIx::Class::Schema::Loader::Table> argument (which stringifies to the
604 unqualified table name) and returning a scalar moniker
606 The function is also passed a coderef that can be called with either
607 of the hashref forms to get the moniker mapped accordingly. This is
608 useful if you need to handle some monikers specially, but want to use
609 the hashref form for the rest.
613 If the hash entry does not exist, or the function returns a false
614 value, the code falls back to default behavior for that table name.
616 The default behavior is to split on case transition and non-alphanumeric
617 boundaries, singularize the resulting phrase, then join the titlecased words
620 Table Name | Moniker Name
621 ---------------------------------
623 luser_group | LuserGroup
624 luser-opts | LuserOpt
625 stations_visited | StationVisited
626 routeChange | RouteChange
628 =head2 moniker_part_map
630 Map for overriding the monikerization of individual L</moniker_parts>.
631 The keys are the moniker part to override, the value is either a
632 hashref of coderef for mapping the corresponding part of the
633 moniker. If a coderef is used, it gets called with the moniker part
634 and the hash key the code ref was found under.
638 moniker_part_map => {
639 schema => sub { ... },
642 Given the table C<foo.bar>, the code ref would be called with the
643 arguments C<foo> and C<schema>, plus a coderef similar to the one
644 described in L</moniker_map>.
646 L</moniker_map> takes precedence over this.
648 =head2 col_accessor_map
650 Same as moniker_map, but for column accessor names. If a coderef is
651 passed, the code is called with arguments of
653 the name of the column in the underlying database,
654 default accessor name that DBICSL would ordinarily give this column,
656 table_class => name of the DBIC class we are building,
657 table_moniker => calculated moniker for this table (after moniker_map if present),
658 table => table object of interface DBIx::Class::Schema::Loader::Table,
659 full_table_name => schema-qualified name of the database table (RDBMS specific),
660 schema_class => name of the schema class we are building,
661 column_info => hashref of column info (data_type, is_nullable, etc),
663 coderef ref that can be called with a hashref map
665 the L<table object|DBIx::Class::Schema::Loader::Table> stringifies to the
666 unqualified table name.
670 Similar in idea to moniker_map, but different in the details. It can be
671 a hashref or a code ref.
673 If it is a hashref, keys can be either the default relationship name, or the
674 moniker. The keys that are the default relationship name should map to the
675 name you want to change the relationship to. Keys that are monikers should map
676 to hashes mapping relationship names to their translation. You can do both at
677 once, and the more specific moniker version will be picked up first. So, for
678 instance, you could have
687 and relationships that would have been named C<bar> will now be named C<baz>
688 except that in the table whose moniker is C<Foo> it will be named C<blat>.
690 If it is a coderef, it will be passed a hashref of this form:
693 name => default relationship name,
694 type => the relationship type eg: C<has_many>,
695 local_class => name of the DBIC class we are building,
696 local_moniker => moniker of the DBIC class we are building,
697 local_columns => columns in this table in the relationship,
698 remote_class => name of the DBIC class we are related to,
699 remote_moniker => moniker of the DBIC class we are related to,
700 remote_columns => columns in the other table in the relationship,
701 # for type => "many_to_many" only:
702 link_class => name of the DBIC class for the link table
703 link_moniker => moniker of the DBIC class for the link table
704 link_rel_name => name of the relationship to the link table
707 In addition it is passed a coderef that can be called with a hashref map.
709 DBICSL will try to use the value returned as the relationship name.
711 =head2 inflect_plural
713 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
714 if hash key does not exist or coderef returns false), but acts as a map
715 for pluralizing relationship names. The default behavior is to utilize
716 L<Lingua::EN::Inflect::Phrase/to_PL>.
718 =head2 inflect_singular
720 As L</inflect_plural> above, but for singularizing relationship names.
721 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
723 =head2 schema_base_class
725 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
727 =head2 schema_components
729 List of components to load into the Schema class.
731 =head2 result_base_class
733 Base class for your table classes (aka result classes). Defaults to
736 =head2 additional_base_classes
738 List of additional base classes all of your table classes will use.
740 =head2 left_base_classes
742 List of additional base classes all of your table classes will use
743 that need to be leftmost.
745 =head2 additional_classes
747 List of additional classes which all of your table classes will use.
751 List of additional components to be loaded into all of your Result
752 classes. A good example would be
753 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
755 =head2 result_components_map
757 A hashref of moniker keys and component values. Unlike L</components>, which
758 loads the given components into every Result class, this option allows you to
759 load certain components for specified Result classes. For example:
761 result_components_map => {
762 StationVisited => '+YourApp::Schema::Component::StationVisited',
764 '+YourApp::Schema::Component::RouteChange',
765 'InflateColumn::DateTime',
769 You may use this in conjunction with L</components>.
773 List of L<Moose> roles to be applied to all of your Result classes.
775 =head2 result_roles_map
777 A hashref of moniker keys and role values. Unlike L</result_roles>, which
778 applies the given roles to every Result class, this option allows you to apply
779 certain roles for specified Result classes. For example:
781 result_roles_map => {
783 'YourApp::Role::Building',
784 'YourApp::Role::Destination',
786 RouteChange => 'YourApp::Role::TripEvent',
789 You may use this in conjunction with L</result_roles>.
791 =head2 use_namespaces
793 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
796 Generate result class names suitable for
797 L<DBIx::Class::Schema/load_namespaces> and call that instead of
798 L<DBIx::Class::Schema/load_classes>. When using this option you can also
799 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
800 C<resultset_namespace>, C<default_resultset_class>), and they will be added
801 to the call (and the generated result class names adjusted appropriately).
803 =head2 dump_directory
805 The value of this option is a perl libdir pathname. Within
806 that directory this module will create a baseline manual
807 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
809 The created schema class will have the same classname as the one on
810 which you are setting this option (and the ResultSource classes will be
811 based on this name as well).
813 Normally you wouldn't hard-code this setting in your schema class, as it
814 is meant for one-time manual usage.
816 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
817 recommended way to access this functionality.
819 =head2 dump_overwrite
821 Deprecated. See L</really_erase_my_files> below, which does *not* mean
822 the same thing as the old C<dump_overwrite> setting from previous releases.
824 =head2 really_erase_my_files
826 Default false. If true, Loader will unconditionally delete any existing
827 files before creating the new ones from scratch when dumping a schema to disk.
829 The default behavior is instead to only replace the top portion of the
830 file, up to and including the final stanza which contains
831 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
832 leaving any customizations you placed after that as they were.
834 When C<really_erase_my_files> is not set, if the output file already exists,
835 but the aforementioned final stanza is not found, or the checksum
836 contained there does not match the generated contents, Loader will
837 croak and not touch the file.
839 You should really be using version control on your schema classes (and all
840 of the rest of your code for that matter). Don't blame me if a bug in this
841 code wipes something out when it shouldn't have, you've been warned.
843 =head2 overwrite_modifications
845 Default false. If false, when updating existing files, Loader will
846 refuse to modify any Loader-generated code that has been modified
847 since its last run (as determined by the checksum Loader put in its
850 If true, Loader will discard any manual modifications that have been
851 made to Loader-generated code.
853 Again, you should be using version control on your schema classes. Be
854 careful with this option.
856 =head2 custom_column_info
858 Hook for adding extra attributes to the
859 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
861 Must be a coderef that returns a hashref with the extra attributes.
863 Receives the L<table object|DBIx::Class::Schema::Loader::Table> (which
864 stringifies to the unqualified table name), column name and column_info.
868 custom_column_info => sub {
869 my ($table, $column_name, $column_info) = @_;
871 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
872 return { is_snoopy => 1 };
876 This attribute can also be used to set C<inflate_datetime> on a non-datetime
877 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
879 =head2 datetime_timezone
881 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
882 columns with the DATE/DATETIME/TIMESTAMP data_types.
884 =head2 datetime_locale
886 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
887 columns with the DATE/DATETIME/TIMESTAMP data_types.
889 =head2 datetime_undef_if_invalid
891 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
892 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
895 The default is recommended to deal with data such as C<00/00/00> which
896 sometimes ends up in such columns in MySQL.
900 File in Perl format, which should return a HASH reference, from which to read
905 Normally database names are lowercased and split by underscore, use this option
906 if you have CamelCase database names.
908 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
909 case-sensitive collation will turn this option on unconditionally.
911 B<NOTE:> L</naming> = C<v8> is highly recommended with this option as the
912 semantics of this mode are much improved for CamelCase database names.
914 L</naming> = C<v7> or greater is required with this option.
916 =head2 qualify_objects
918 Set to true to prepend the L</db_schema> to table names for C<<
919 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
921 This attribute is automatically set to true for multi db_schema configurations,
922 unless explicitly set to false by the user.
926 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
927 L<MooseX::MarkAsMethods> (or L<namespace::autoclean>, see below). The default
928 content after the md5 sum also makes the classes immutable.
930 It is safe to upgrade your existing Schema to this option.
932 =head2 only_autoclean
934 By default, we use L<MooseX::MarkAsMethods> to remove imported functions from
935 your generated classes. It uses L<namespace::autoclean> to do this, after
936 telling your object's metaclass that any operator L<overload>s in your class
937 are methods, which will cause namespace::autoclean to spare them from removal.
939 This prevents the "Hey, where'd my overloads go?!" effect.
941 If you don't care about operator overloads, enabling this option falls back to
942 just using L<namespace::autoclean> itself.
944 If none of the above made any sense, or you don't have some pressing need to
945 only use L<namespace::autoclean>, leaving this set to the default is
948 =head2 col_collision_map
950 This option controls how accessors for column names which collide with perl
951 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
953 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
954 strings which are compiled to regular expressions that map to
955 L<sprintf|perlfunc/sprintf> formats.
959 col_collision_map => 'column_%s'
961 col_collision_map => { '(.*)' => 'column_%s' }
963 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
965 =head2 rel_collision_map
967 Works just like L</col_collision_map>, but for relationship names/accessors
968 rather than column names/accessors.
970 The default is to just append C<_rel> to the relationship name, see
971 L</RELATIONSHIP NAME COLLISIONS>.
973 =head2 uniq_to_primary
975 Automatically promotes the largest unique constraints with non-nullable columns
976 on tables to primary keys, assuming there is only one largest unique
979 =head2 filter_generated_code
981 An optional hook that lets you filter the generated text for various classes
982 through a function that change it in any way that you want. The function will
983 receive the type of file, C<schema> or C<result>, class and code; and returns
984 the new code to use instead. For instance you could add custom comments, or do
985 anything else that you want.
987 The option can also be set to a string, which is then used as a filter program,
990 If this exists but fails to return text matching C</\bpackage\b/>, no file will
993 filter_generated_code => sub {
994 my ($type, $class, $text) = @_;
1001 None of these methods are intended for direct invocation by regular
1002 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
1003 L<DBIx::Class::Schema::Loader>.
1007 # ensure that a piece of object data is a valid arrayref, creating
1008 # an empty one or encapsulating whatever's there.
1009 sub _ensure_arrayref {
1014 $self->{$_} = [ $self->{$_} ]
1015 unless ref $self->{$_} eq 'ARRAY';
1021 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
1022 by L<DBIx::Class::Schema::Loader>.
1027 my ( $class, %args ) = @_;
1029 if (exists $args{column_accessor_map}) {
1030 $args{col_accessor_map} = delete $args{column_accessor_map};
1033 my $self = { %args };
1035 # don't lose undef options
1036 for (values %$self) {
1037 $_ = 0 unless defined $_;
1040 bless $self => $class;
1042 if (my $config_file = $self->config_file) {
1043 my $config_opts = do $config_file;
1045 croak "Error reading config from $config_file: $@" if $@;
1047 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
1049 while (my ($k, $v) = each %$config_opts) {
1050 $self->{$k} = $v unless exists $self->{$k};
1054 if (defined $self->{result_component_map}) {
1055 if (defined $self->result_components_map) {
1056 croak "Specify only one of result_components_map or result_component_map";
1058 $self->result_components_map($self->{result_component_map})
1061 if (defined $self->{result_role_map}) {
1062 if (defined $self->result_roles_map) {
1063 croak "Specify only one of result_roles_map or result_role_map";
1065 $self->result_roles_map($self->{result_role_map})
1068 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
1069 if ((not defined $self->use_moose) || (not $self->use_moose))
1070 && ((defined $self->result_roles) || (defined $self->result_roles_map));
1072 $self->_ensure_arrayref(qw/schema_components
1074 additional_base_classes
1080 $self->_validate_class_args;
1082 croak "result_components_map must be a hash"
1083 if defined $self->result_components_map
1084 && ref $self->result_components_map ne 'HASH';
1086 if ($self->result_components_map) {
1087 my %rc_map = %{ $self->result_components_map };
1088 foreach my $moniker (keys %rc_map) {
1089 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
1091 $self->result_components_map(\%rc_map);
1094 $self->result_components_map({});
1096 $self->_validate_result_components_map;
1098 croak "result_roles_map must be a hash"
1099 if defined $self->result_roles_map
1100 && ref $self->result_roles_map ne 'HASH';
1102 if ($self->result_roles_map) {
1103 my %rr_map = %{ $self->result_roles_map };
1104 foreach my $moniker (keys %rr_map) {
1105 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
1107 $self->result_roles_map(\%rr_map);
1109 $self->result_roles_map({});
1111 $self->_validate_result_roles_map;
1113 if ($self->use_moose) {
1114 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
1115 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
1116 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
1120 $self->{_tables} = {};
1121 $self->{monikers} = {};
1122 $self->{moniker_to_table} = {};
1123 $self->{class_to_table} = {};
1124 $self->{classes} = {};
1125 $self->{_upgrading_classes} = {};
1127 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
1128 $self->{schema} ||= $self->{schema_class};
1129 $self->{table_comments_table} ||= 'table_comments';
1130 $self->{column_comments_table} ||= 'column_comments';
1132 croak "dump_overwrite is deprecated. Please read the"
1133 . " DBIx::Class::Schema::Loader::Base documentation"
1134 if $self->{dump_overwrite};
1136 $self->{dynamic} = ! $self->{dump_directory};
1137 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
1142 $self->{dump_directory} ||= $self->{temp_directory};
1144 $self->real_dump_directory($self->{dump_directory});
1146 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
1147 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
1149 if (not defined $self->naming) {
1150 $self->naming_set(0);
1153 $self->naming_set(1);
1156 if ((not ref $self->naming) && defined $self->naming) {
1157 my $naming_ver = $self->naming;
1159 relationships => $naming_ver,
1160 monikers => $naming_ver,
1161 column_accessors => $naming_ver,
1164 elsif (ref $self->naming eq 'HASH' && exists $self->naming->{ALL}) {
1165 my $val = delete $self->naming->{ALL};
1167 $self->naming->{$_} = $val
1168 foreach qw/relationships monikers column_accessors/;
1171 if ($self->naming) {
1172 foreach my $key (qw/relationships monikers column_accessors/) {
1173 $self->naming->{$key} = $CURRENT_V if ($self->naming->{$key}||'') eq 'current';
1176 $self->{naming} ||= {};
1178 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
1179 croak 'custom_column_info must be a CODE ref';
1182 $self->_check_back_compat;
1184 $self->use_namespaces(1) unless defined $self->use_namespaces;
1185 $self->generate_pod(1) unless defined $self->generate_pod;
1186 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
1187 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
1189 if (my $col_collision_map = $self->col_collision_map) {
1190 if (my $reftype = ref $col_collision_map) {
1191 if ($reftype ne 'HASH') {
1192 croak "Invalid type $reftype for option 'col_collision_map'";
1196 $self->col_collision_map({ '(.*)' => $col_collision_map });
1200 if (my $rel_collision_map = $self->rel_collision_map) {
1201 if (my $reftype = ref $rel_collision_map) {
1202 if ($reftype ne 'HASH') {
1203 croak "Invalid type $reftype for option 'rel_collision_map'";
1207 $self->rel_collision_map({ '(.*)' => $rel_collision_map });
1211 if (defined(my $rel_name_map = $self->rel_name_map)) {
1212 my $reftype = ref $rel_name_map;
1213 if ($reftype ne 'HASH' && $reftype ne 'CODE') {
1214 croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
1218 if (defined(my $filter = $self->filter_generated_code)) {
1219 my $reftype = ref $filter;
1220 if ($reftype && $reftype ne 'CODE') {
1221 croak "Invalid type $reftype for option 'filter_generated_code, must be a scalar or a CODE reference";
1225 if (defined $self->db_schema) {
1226 if (ref $self->db_schema eq 'ARRAY') {
1227 if (@{ $self->db_schema } > 1 && not defined $self->{qualify_objects}) {
1228 $self->{qualify_objects} = 1;
1230 elsif (@{ $self->db_schema } == 0) {
1231 $self->{db_schema} = undef;
1234 elsif (not ref $self->db_schema) {
1235 if ($self->db_schema eq '%' && not defined $self->{qualify_objects}) {
1236 $self->{qualify_objects} = 1;
1239 $self->{db_schema} = [ $self->db_schema ];
1243 if (not $self->moniker_parts) {
1244 $self->moniker_parts(['name']);
1247 if (not ref $self->moniker_parts) {
1248 $self->moniker_parts([ $self->moniker_parts ]);
1250 if (ref $self->moniker_parts ne 'ARRAY') {
1251 croak 'moniker_parts must be an arrayref';
1253 if ((firstidx { $_ eq 'name' } @{ $self->moniker_parts }) == -1) {
1254 croak "moniker_parts option *must* contain 'name'";
1258 if (not defined $self->moniker_part_separator) {
1259 $self->moniker_part_separator('');
1261 if (not defined $self->moniker_part_map) {
1262 $self->moniker_part_map({}),
1268 sub _check_back_compat {
1271 # dynamic schemas will always be in 0.04006 mode, unless overridden
1272 if ($self->dynamic) {
1273 # just in case, though no one is likely to dump a dynamic schema
1274 $self->schema_version_to_dump('0.04006');
1276 if (not $self->naming_set) {
1277 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1279 Dynamic schema detected, will run in 0.04006 mode.
1281 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1282 to disable this warning.
1284 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1289 $self->_upgrading_from('v4');
1292 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
1293 $self->use_namespaces(1);
1296 $self->naming->{relationships} ||= 'v4';
1297 $self->naming->{monikers} ||= 'v4';
1299 if ($self->use_namespaces) {
1300 $self->_upgrading_from_load_classes(1);
1303 $self->use_namespaces(0);
1309 # otherwise check if we need backcompat mode for a static schema
1310 my $filename = $self->get_dump_filename($self->schema_class);
1311 return unless -e $filename;
1313 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
1314 $self->_parse_generated_file($filename);
1316 return unless $old_ver;
1318 # determine if the existing schema was dumped with use_moose => 1
1319 if (! defined $self->use_moose) {
1320 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
1323 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
1325 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
1326 my $ds = eval $result_namespace;
1328 Could not eval expression '$result_namespace' for result_namespace from
1331 $result_namespace = $ds || '';
1333 if ($load_classes && (not defined $self->use_namespaces)) {
1334 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1336 'load_classes;' static schema detected, turning off 'use_namespaces'.
1338 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
1339 variable to disable this warning.
1341 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1344 $self->use_namespaces(0);
1346 elsif ($load_classes && $self->use_namespaces) {
1347 $self->_upgrading_from_load_classes(1);
1349 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
1350 $self->_downgrading_to_load_classes(
1351 $result_namespace || 'Result'
1354 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
1355 if (not $self->result_namespace) {
1356 $self->result_namespace($result_namespace || 'Result');
1358 elsif ($result_namespace ne $self->result_namespace) {
1359 $self->_rewriting_result_namespace(
1360 $result_namespace || 'Result'
1365 # XXX when we go past .0 this will need fixing
1366 my ($v) = $old_ver =~ /([1-9])/;
1369 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
1371 if (not %{ $self->naming }) {
1372 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1374 Version $old_ver static schema detected, turning on backcompat mode.
1376 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1377 to disable this warning.
1379 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
1381 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
1382 from version 0.04006.
1385 $self->naming->{relationships} ||= $v;
1386 $self->naming->{monikers} ||= $v;
1387 $self->naming->{column_accessors} ||= $v;
1389 $self->schema_version_to_dump($old_ver);
1392 $self->_upgrading_from($v);
1396 sub _validate_class_args {
1399 foreach my $k (@CLASS_ARGS) {
1400 next unless $self->$k;
1402 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
1403 $self->_validate_classes($k, \@classes);
1407 sub _validate_result_components_map {
1410 foreach my $classes (values %{ $self->result_components_map }) {
1411 $self->_validate_classes('result_components_map', $classes);
1415 sub _validate_result_roles_map {
1418 foreach my $classes (values %{ $self->result_roles_map }) {
1419 $self->_validate_classes('result_roles_map', $classes);
1423 sub _validate_classes {
1426 my $classes = shift;
1428 # make a copy to not destroy original
1429 my @classes = @$classes;
1431 foreach my $c (@classes) {
1432 # components default to being under the DBIx::Class namespace unless they
1433 # are preceded with a '+'
1434 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1435 $c = 'DBIx::Class::' . $c;
1438 # 1 == installed, 0 == not installed, undef == invalid classname
1439 my $installed = Class::Inspector->installed($c);
1440 if ( defined($installed) ) {
1441 if ( $installed == 0 ) {
1442 croak qq/$c, as specified in the loader option "$key", is not installed/;
1445 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1451 sub _find_file_in_inc {
1452 my ($self, $file) = @_;
1454 foreach my $prefix (@INC) {
1455 my $fullpath = File::Spec->catfile($prefix, $file);
1456 # abs_path pure-perl fallback warns for non-existent files
1457 local $SIG{__WARN__} = sigwarn_silencer(qr/^stat\(.*\Q$file\E\)/);
1458 return $fullpath if -f $fullpath
1459 # abs_path throws on Windows for nonexistent files
1460 and (try { Cwd::abs_path($fullpath) }) ne
1461 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1467 sub _find_class_in_inc {
1468 my ($self, $class) = @_;
1470 return $self->_find_file_in_inc(class_path($class));
1476 return $self->_upgrading_from
1477 || $self->_upgrading_from_load_classes
1478 || $self->_downgrading_to_load_classes
1479 || $self->_rewriting_result_namespace
1483 sub _rewrite_old_classnames {
1484 my ($self, $code) = @_;
1486 return $code unless $self->_rewriting;
1488 my %old_classes = reverse %{ $self->_upgrading_classes };
1490 my $re = join '|', keys %old_classes;
1491 $re = qr/\b($re)\b/;
1493 $code =~ s/$re/$old_classes{$1} || $1/eg;
1498 sub _load_external {
1499 my ($self, $class) = @_;
1501 return if $self->{skip_load_external};
1503 # so that we don't load our own classes, under any circumstances
1504 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1506 my $real_inc_path = $self->_find_class_in_inc($class);
1508 my $old_class = $self->_upgrading_classes->{$class}
1509 if $self->_rewriting;
1511 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1512 if $old_class && $old_class ne $class;
1514 return unless $real_inc_path || $old_real_inc_path;
1516 if ($real_inc_path) {
1517 # If we make it to here, we loaded an external definition
1518 warn qq/# Loaded external class definition for '$class'\n/
1521 my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path);
1523 if ($self->dynamic) { # load the class too
1524 eval_package_without_redefine_warnings($class, $code);
1527 $self->_ext_stmt($class,
1528 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1529 .qq|# They are now part of the custom portion of this file\n|
1530 .qq|# for you to hand-edit. If you do not either delete\n|
1531 .qq|# this section or remove that file from \@INC, this section\n|
1532 .qq|# will be repeated redundantly when you re-create this\n|
1533 .qq|# file again via Loader! See skip_load_external to disable\n|
1534 .qq|# this feature.\n|
1537 $self->_ext_stmt($class, $code);
1538 $self->_ext_stmt($class,
1539 qq|# End of lines loaded from '$real_inc_path' |
1543 if ($old_real_inc_path) {
1544 my $code = slurp_file $old_real_inc_path;
1546 $self->_ext_stmt($class, <<"EOF");
1548 # These lines were loaded from '$old_real_inc_path',
1549 # based on the Result class name that would have been created by an older
1550 # version of the Loader. For a static schema, this happens only once during
1551 # upgrade. See skip_load_external to disable this feature.
1554 $code = $self->_rewrite_old_classnames($code);
1556 if ($self->dynamic) {
1559 Detected external content in '$old_real_inc_path', a class name that would have
1560 been used by an older version of the Loader.
1562 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1563 new name of the Result.
1565 eval_package_without_redefine_warnings($class, $code);
1569 $self->_ext_stmt($class, $code);
1570 $self->_ext_stmt($class,
1571 qq|# End of lines loaded from '$old_real_inc_path' |
1578 Does the actual schema-construction work.
1585 $self->_load_tables(
1586 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1594 Rescan the database for changes. Returns a list of the newly added table
1597 The schema argument should be the schema class or object to be affected. It
1598 should probably be derived from the original schema_class used during L</load>.
1603 my ($self, $schema) = @_;
1605 $self->{schema} = $schema;
1606 $self->_relbuilder->{schema} = $schema;
1609 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1611 foreach my $table (@current) {
1612 if(!exists $self->_tables->{$table->sql_name}) {
1613 push(@created, $table);
1618 @current{map $_->sql_name, @current} = ();
1619 foreach my $table (values %{ $self->_tables }) {
1620 if (not exists $current{$table->sql_name}) {
1621 $self->_remove_table($table);
1625 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1627 my $loaded = $self->_load_tables(@current);
1629 foreach my $table (@created) {
1630 $self->monikers->{$table->sql_name} = $self->_table2moniker($table);
1633 return map { $self->monikers->{$_->sql_name} } @created;
1639 return if $self->{skip_relationships};
1641 return $self->{relbuilder} ||= do {
1642 my $relbuilder_suff =
1649 ->{$self->naming->{relationships}||$CURRENT_V} || '';
1651 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1652 $self->ensure_class_loaded($relbuilder_class);
1653 $relbuilder_class->new($self);
1658 my ($self, @tables) = @_;
1660 # Save the new tables to the tables list and compute monikers
1662 $self->_tables->{$_->sql_name} = $_;
1663 $self->monikers->{$_->sql_name} = $self->_table2moniker($_);
1666 # check for moniker clashes
1667 my $inverse_moniker_idx;
1668 foreach my $imtable (values %{ $self->_tables }) {
1669 push @{ $inverse_moniker_idx->{$self->monikers->{$imtable->sql_name}} }, $imtable;
1673 foreach my $moniker (keys %$inverse_moniker_idx) {
1674 my $imtables = $inverse_moniker_idx->{$moniker};
1675 if (@$imtables > 1) {
1676 my $different_databases =
1677 $imtables->[0]->can('database') && (uniq map $_->database||'', @$imtables) > 1;
1679 my $different_schemas =
1680 (uniq map $_->schema||'', @$imtables) > 1;
1682 if ($different_databases || $different_schemas) {
1683 my ($use_schema, $use_database) = (1, 0);
1685 if ($different_databases) {
1688 # If any monikers are in the same database, we have to distinguish by
1689 # both schema and database.
1691 $db_counts{$_}++ for map $_->database, @$imtables;
1692 $use_schema = any { $_ > 1 } values %db_counts;
1695 foreach my $tbl (@$imtables) { delete $self->monikers->{$tbl->sql_name}; }
1697 my $moniker_parts = [ @{ $self->moniker_parts } ];
1699 my $have_schema = any { $_ eq 'schema' } @{ $self->moniker_parts };
1700 my $have_database = any { $_ eq 'database' } @{ $self->moniker_parts };
1702 unshift @$moniker_parts, 'schema' if $use_schema && !$have_schema;
1703 unshift @$moniker_parts, 'database' if $use_database && !$have_database;
1705 local $self->{moniker_parts} = $moniker_parts;
1709 foreach my $tbl (@$imtables) { $new_monikers{$tbl->sql_name} = $self->_table2moniker($tbl); }
1710 foreach my $name (map $_->sql_name, @$imtables) { $self->monikers->{$name} = $new_monikers{$name}; }
1712 # check if there are still clashes
1715 while (my ($t, $m) = each %new_monikers) {
1716 push @{ $by_moniker{$m} }, $t;
1719 foreach my $m (grep @{ $by_moniker{$_} } > 1, keys %by_moniker) {
1720 push @clashes, sprintf ("tried disambiguating by moniker_parts, but tables %s still reduced to the same source moniker '%s'",
1721 join (', ', @{ $by_moniker{$m} }),
1727 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1728 join (', ', map $_->sql_name, @$imtables),
1736 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1737 . 'Change the naming style, or supply an explicit moniker_map: '
1738 . join ('; ', @clashes)
1743 foreach my $tbl (@tables) { $self->_make_src_class($tbl); }
1744 foreach my $tbl (@tables) { $self->_setup_src_meta($tbl); }
1746 if(!$self->skip_relationships) {
1747 # The relationship loader needs a working schema
1748 local $self->{quiet} = 1;
1749 local $self->{dump_directory} = $self->{temp_directory};
1750 $self->_reload_classes(\@tables);
1751 $self->_load_relationships(\@tables);
1753 # Remove that temp dir from INC so it doesn't get reloaded
1754 @INC = grep $_ ne $self->dump_directory, @INC;
1757 foreach my $tbl (@tables) { $self->_load_roles($tbl); }
1758 foreach my $tbl (map { $self->classes->{$_->sql_name} } @tables) { $self->_load_external($tbl); }
1760 # Reload without unloading first to preserve any symbols from external
1762 $self->_reload_classes(\@tables, { unload => 0 });
1764 # Drop temporary cache
1765 delete $self->{_cache};
1770 sub _reload_classes {
1771 my ($self, $tables, $opts) = @_;
1773 my @tables = @$tables;
1775 my $unload = $opts->{unload};
1776 $unload = 1 unless defined $unload;
1778 # so that we don't repeat custom sections
1779 @INC = grep $_ ne $self->dump_directory, @INC;
1781 $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables);
1783 unshift @INC, $self->dump_directory;
1786 my %have_source = map { $_ => $self->schema->source($_) }
1787 $self->schema->sources;
1789 for my $table (@tables) {
1790 my $moniker = $self->monikers->{$table->sql_name};
1791 my $class = $self->classes->{$table->sql_name};
1794 no warnings 'redefine';
1795 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1798 if (my $mc = $self->_moose_metaclass($class)) {
1801 Class::Unload->unload($class) if $unload;
1802 my ($source, $resultset_class);
1804 ($source = $have_source{$moniker})
1805 && ($resultset_class = $source->resultset_class)
1806 && ($resultset_class ne 'DBIx::Class::ResultSet')
1808 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1809 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1812 Class::Unload->unload($resultset_class) if $unload;
1813 $self->_reload_class($resultset_class) if $has_file;
1815 $self->_reload_class($class);
1817 push @to_register, [$moniker, $class];
1820 Class::C3->reinitialize;
1821 for (@to_register) {
1822 $self->schema->register_class(@$_);
1826 sub _moose_metaclass {
1827 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1831 my $mc = try { Class::MOP::class_of($class) }
1834 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1837 # We use this instead of ensure_class_loaded when there are package symbols we
1840 my ($self, $class) = @_;
1842 delete $INC{ +class_path($class) };
1845 eval_package_without_redefine_warnings ($class, "require $class");
1848 my $source = slurp_file $self->_get_dump_filename($class);
1849 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1853 sub _get_dump_filename {
1854 my ($self, $class) = (@_);
1856 $class =~ s{::}{/}g;
1857 return $self->dump_directory . q{/} . $class . q{.pm};
1860 =head2 get_dump_filename
1864 Returns the full path to the file for a class that the class has been or will
1865 be dumped to. This is a file in a temp dir for a dynamic schema.
1869 sub get_dump_filename {
1870 my ($self, $class) = (@_);
1872 local $self->{dump_directory} = $self->real_dump_directory;
1874 return $self->_get_dump_filename($class);
1877 sub _ensure_dump_subdirs {
1878 my ($self, $class) = (@_);
1880 my @name_parts = split(/::/, $class);
1881 pop @name_parts; # we don't care about the very last element,
1882 # which is a filename
1884 my $dir = $self->dump_directory;
1887 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1889 last if !@name_parts;
1890 $dir = File::Spec->catdir($dir, shift @name_parts);
1895 my ($self, @classes) = @_;
1897 my $schema_class = $self->schema_class;
1898 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1900 my $target_dir = $self->dump_directory;
1901 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1902 unless $self->dynamic or $self->quiet;
1906 . qq|package $schema_class;\n\n|
1907 . qq|# Created by DBIx::Class::Schema::Loader\n|
1908 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1911 = $self->only_autoclean
1912 ? 'namespace::autoclean'
1913 : 'MooseX::MarkAsMethods autoclean => 1'
1916 if ($self->use_moose) {
1918 $schema_text.= qq|use Moose;\nuse $autoclean;\nextends '$schema_base_class';\n\n|;
1921 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1924 my @schema_components = @{ $self->schema_components || [] };
1926 if (@schema_components) {
1927 my $schema_components = dump @schema_components;
1928 $schema_components = "($schema_components)" if @schema_components == 1;
1930 $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1933 if ($self->use_namespaces) {
1934 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1935 my $namespace_options;
1937 my @attr = qw/resultset_namespace default_resultset_class/;
1939 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1941 for my $attr (@attr) {
1943 my $code = dumper_squashed $self->$attr;
1944 $namespace_options .= qq| $attr => $code,\n|
1947 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1948 $schema_text .= qq|;\n|;
1951 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1955 local $self->{version_to_dump} = $self->schema_version_to_dump;
1956 $self->_write_classfile($schema_class, $schema_text, 1);
1959 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1961 foreach my $src_class (@classes) {
1964 . qq|package $src_class;\n\n|
1965 . qq|# Created by DBIx::Class::Schema::Loader\n|
1966 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1968 $src_text .= $self->_make_pod_heading($src_class);
1970 $src_text .= qq|use strict;\nuse warnings;\n\n|;
1972 $src_text .= $self->_base_class_pod($result_base_class)
1973 unless $result_base_class eq 'DBIx::Class::Core';
1975 if ($self->use_moose) {
1976 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse $autoclean;|;
1978 # these options 'use base' which is compile time
1979 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1980 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1983 $src_text .= qq|\nextends '$result_base_class';\n|;
1987 $src_text .= qq|use base '$result_base_class';\n|;
1990 $self->_write_classfile($src_class, $src_text);
1993 # remove Result dir if downgrading from use_namespaces, and there are no
1995 if (my $result_ns = $self->_downgrading_to_load_classes
1996 || $self->_rewriting_result_namespace) {
1997 my $result_namespace = $self->_result_namespace(
2002 (my $result_dir = $result_namespace) =~ s{::}{/}g;
2003 $result_dir = $self->dump_directory . '/' . $result_dir;
2005 unless (my @files = glob "$result_dir/*") {
2010 warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
2014 my ($self, $version, $ts) = @_;
2015 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
2018 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
2021 sub _write_classfile {
2022 my ($self, $class, $text, $is_schema) = @_;
2024 my $filename = $self->_get_dump_filename($class);
2025 $self->_ensure_dump_subdirs($class);
2027 if (-f $filename && $self->really_erase_my_files) {
2028 warn "Deleting existing file '$filename' due to "
2029 . "'really_erase_my_files' setting\n" unless $self->quiet;
2033 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
2034 = $self->_parse_generated_file($filename);
2036 if (! $old_gen && -f $filename) {
2037 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
2038 . " it does not appear to have been generated by Loader"
2041 my $custom_content = $old_custom || '';
2043 # Use custom content from a renamed class, the class names in it are
2045 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
2046 my $old_filename = $self->_get_dump_filename($renamed_class);
2048 if (-f $old_filename) {
2049 $custom_content = ($self->_parse_generated_file ($old_filename))[4];
2051 unlink $old_filename;
2055 $custom_content ||= $self->_default_custom_content($is_schema);
2057 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
2058 # If there is already custom content, which does not have the Moose content, add it.
2059 if ($self->use_moose) {
2061 my $non_moose_custom_content = do {
2062 local $self->{use_moose} = 0;
2063 $self->_default_custom_content;
2066 if ($custom_content eq $non_moose_custom_content) {
2067 $custom_content = $self->_default_custom_content($is_schema);
2069 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
2070 $custom_content .= $self->_default_custom_content($is_schema);
2073 elsif (defined $self->use_moose && $old_gen) {
2074 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'
2075 if $old_gen =~ /use \s+ MooseX?\b/x;
2078 $custom_content = $self->_rewrite_old_classnames($custom_content);
2081 for @{$self->{_dump_storage}->{$class} || []};
2083 if ($self->filter_generated_code) {
2084 my $filter = $self->filter_generated_code;
2086 if (ref $filter eq 'CODE') {
2088 ($is_schema ? 'schema' : 'result'),
2094 my ($fh, $temp_file) = tempfile();
2096 binmode $fh, ':encoding(UTF-8)';
2100 open my $out, qq{$filter < "$temp_file"|}
2101 or croak "Could not open pipe to $filter: $!";
2103 $text = decode('UTF-8', do { local $/; <$out> });
2105 $text =~ s/$CR?$LF/\n/g;
2109 my $exit_code = $? >> 8;
2112 or croak "Could not remove temporary file '$temp_file': $!";
2114 if ($exit_code != 0) {
2115 croak "filter '$filter' exited non-zero: $exit_code";
2118 if (not $text or not $text =~ /\bpackage\b/) {
2119 warn("$class skipped due to filter") if $self->debug;
2124 # Check and see if the dump is in fact different
2128 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
2129 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
2130 return unless $self->_upgrading_from && $is_schema;
2134 $text .= $self->_sig_comment(
2135 $self->version_to_dump,
2136 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
2139 open(my $fh, '>:encoding(UTF-8)', $filename)
2140 or croak "Cannot open '$filename' for writing: $!";
2142 # Write the top half and its MD5 sum
2143 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
2145 # Write out anything loaded via external partial class file in @INC
2147 for @{$self->{_ext_storage}->{$class} || []};
2149 # Write out any custom content the user has added
2150 print $fh $custom_content;
2153 or croak "Error closing '$filename': $!";
2156 sub _default_moose_custom_content {
2157 my ($self, $is_schema) = @_;
2159 if (not $is_schema) {
2160 return qq|\n__PACKAGE__->meta->make_immutable;|;
2163 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
2166 sub _default_custom_content {
2167 my ($self, $is_schema) = @_;
2168 my $default = qq|\n\n# You can replace this text with custom|
2169 . qq| code or comments, and it will be preserved on regeneration|;
2170 if ($self->use_moose) {
2171 $default .= $self->_default_moose_custom_content($is_schema);
2173 $default .= qq|\n1;\n|;
2177 sub _parse_generated_file {
2178 my ($self, $fn) = @_;
2180 return unless -f $fn;
2182 open(my $fh, '<:encoding(UTF-8)', $fn)
2183 or croak "Cannot open '$fn' for reading: $!";
2186 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
2188 my ($md5, $ts, $ver, $gen);
2194 # Pull out the version and timestamp from the line above
2195 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m;
2198 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"
2199 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
2208 my $custom = do { local $/; <$fh> }
2212 $custom =~ s/$CRLF|$LF/\n/g;
2216 return ($gen, $md5, $ver, $ts, $custom);
2224 warn "$target: use $_;" if $self->debug;
2225 $self->_raw_stmt($target, "use $_;");
2233 my $blist = join(q{ }, @_);
2235 return unless $blist;
2237 warn "$target: use base qw/$blist/;" if $self->debug;
2238 $self->_raw_stmt($target, "use base qw/$blist/;");
2245 my $rlist = join(q{, }, map { qq{'$_'} } @_);
2247 return unless $rlist;
2249 warn "$target: with $rlist;" if $self->debug;
2250 $self->_raw_stmt($target, "\nwith $rlist;");
2253 sub _result_namespace {
2254 my ($self, $schema_class, $ns) = @_;
2255 my @result_namespace;
2257 $ns = $ns->[0] if ref $ns;
2259 if ($ns =~ /^\+(.*)/) {
2260 # Fully qualified namespace
2261 @result_namespace = ($1)
2264 # Relative namespace
2265 @result_namespace = ($schema_class, $ns);
2268 return wantarray ? @result_namespace : join '::', @result_namespace;
2271 # Create class with applicable bases, setup monikers, etc
2272 sub _make_src_class {
2273 my ($self, $table) = @_;
2275 my $schema = $self->schema;
2276 my $schema_class = $self->schema_class;
2278 my $table_moniker = $self->monikers->{$table->sql_name};
2279 my @result_namespace = ($schema_class);
2280 if ($self->use_namespaces) {
2281 my $result_namespace = $self->result_namespace || 'Result';
2282 @result_namespace = $self->_result_namespace(
2287 my $table_class = join(q{::}, @result_namespace, $table_moniker);
2289 if ((my $upgrading_v = $self->_upgrading_from)
2290 || $self->_rewriting) {
2291 local $self->naming->{monikers} = $upgrading_v
2294 my @result_namespace = @result_namespace;
2295 if ($self->_upgrading_from_load_classes) {
2296 @result_namespace = ($schema_class);
2298 elsif (my $ns = $self->_downgrading_to_load_classes) {
2299 @result_namespace = $self->_result_namespace(
2304 elsif ($ns = $self->_rewriting_result_namespace) {
2305 @result_namespace = $self->_result_namespace(
2311 my $old_table_moniker = do {
2312 local $self->naming->{monikers} = $upgrading_v;
2313 $self->_table2moniker($table);
2316 my $old_class = join(q{::}, @result_namespace, $old_table_moniker);
2318 $self->_upgrading_classes->{$table_class} = $old_class
2319 unless $table_class eq $old_class;
2322 $self->classes->{$table->sql_name} = $table_class;
2323 $self->moniker_to_table->{$table_moniker} = $table;
2324 $self->class_to_table->{$table_class} = $table;
2326 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
2328 $self->_use ($table_class, @{$self->additional_classes});
2330 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
2332 $self->_inject($table_class, @{$self->left_base_classes});
2334 my @components = @{ $self->components || [] };
2336 push @components, @{ $self->result_components_map->{$table_moniker} }
2337 if exists $self->result_components_map->{$table_moniker};
2339 my @fq_components = @components;
2340 foreach my $component (@fq_components) {
2341 if ($component !~ s/^\+//) {
2342 $component = "DBIx::Class::$component";
2346 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
2348 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
2350 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
2352 $self->_inject($table_class, @{$self->additional_base_classes});
2355 sub _is_result_class_method {
2356 my ($self, $name, $table) = @_;
2358 my $table_moniker = $table ? $self->monikers->{$table->sql_name} : '';
2360 $self->_result_class_methods({})
2361 if not defined $self->_result_class_methods;
2363 if (not exists $self->_result_class_methods->{$table_moniker}) {
2364 my (@methods, %methods);
2365 my $base = $self->result_base_class || 'DBIx::Class::Core';
2367 my @components = @{ $self->components || [] };
2369 push @components, @{ $self->result_components_map->{$table_moniker} }
2370 if exists $self->result_components_map->{$table_moniker};
2372 for my $c (@components) {
2373 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
2376 my @roles = @{ $self->result_roles || [] };
2378 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2379 if exists $self->result_roles_map->{$table_moniker};
2381 for my $class ($base, @components,
2382 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
2383 $self->ensure_class_loaded($class);
2385 push @methods, @{ Class::Inspector->methods($class) || [] };
2388 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
2390 @methods{@methods} = ();
2392 $self->_result_class_methods->{$table_moniker} = \%methods;
2394 my $result_methods = $self->_result_class_methods->{$table_moniker};
2396 return exists $result_methods->{$name};
2399 sub _resolve_col_accessor_collisions {
2400 my ($self, $table, $col_info) = @_;
2402 while (my ($col, $info) = each %$col_info) {
2403 my $accessor = $info->{accessor} || $col;
2405 next if $accessor eq 'id'; # special case (very common column)
2407 if ($self->_is_result_class_method($accessor, $table)) {
2410 if (my $map = $self->col_collision_map) {
2411 for my $re (keys %$map) {
2412 if (my @matches = $col =~ /$re/) {
2413 $info->{accessor} = sprintf $map->{$re}, @matches;
2421 Column '$col' in table '$table' collides with an inherited method.
2422 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
2424 $info->{accessor} = undef;
2430 # use the same logic to run moniker_map, col_accessor_map
2432 my ( $self, $map, $default_code, $ident, @extra ) = @_;
2434 my $default_ident = $default_code->( $ident, @extra );
2436 if( $map && ref $map eq 'HASH' ) {
2437 if (my @parts = try{ @{ $ident } }) {
2438 my $part_map = $map;
2440 my $part = shift @parts;
2441 last unless exists $part_map->{ $part };
2442 if ( !ref $part_map->{ $part } && !@parts ) {
2443 $new_ident = $part_map->{ $part };
2446 elsif ( ref $part_map->{ $part } eq 'HASH' ) {
2447 $part_map = $part_map->{ $part };
2451 if( !$new_ident && !ref $map->{ $ident } ) {
2452 $new_ident = $map->{ $ident };
2455 elsif( $map && ref $map eq 'CODE' ) {
2458 croak "reentered map must be a hashref"
2459 unless 'HASH' eq ref($cb_map);
2460 return $self->_run_user_map($cb_map, $default_code, $ident, @extra);
2462 $new_ident = $map->( $ident, $default_ident, @extra, $cb );
2465 $new_ident ||= $default_ident;
2470 sub _default_column_accessor_name {
2471 my ( $self, $column_name ) = @_;
2473 my $preserve = ($self->naming->{column_accessors}||'') eq 'preserve';
2475 my $v = $self->_get_naming_v('column_accessors');
2477 my $accessor_name = $preserve ?
2478 $self->_to_identifier('column_accessors', $column_name) # assume CamelCase
2480 $self->_to_identifier('column_accessors', $column_name, '_');
2482 $accessor_name =~ s/\W+/_/g; # only if naming < v8, otherwise to_identifier
2486 return $accessor_name;
2488 elsif ($v < 7 || (not $self->preserve_case)) {
2489 # older naming just lc'd the col accessor and that's all.
2490 return lc $accessor_name;
2493 return join '_', map lc, split_name $column_name, $v;
2496 sub _make_column_accessor_name {
2497 my ($self, $column_name, $column_context_info ) = @_;
2499 my $accessor = $self->_run_user_map(
2500 $self->col_accessor_map,
2501 sub { $self->_default_column_accessor_name( shift ) },
2503 $column_context_info,
2509 sub _table_is_view {
2510 #my ($self, $table) = @_;
2514 # Set up metadata (cols, pks, etc)
2515 sub _setup_src_meta {
2516 my ($self, $table) = @_;
2518 my $schema = $self->schema;
2519 my $schema_class = $self->schema_class;
2521 my $table_class = $self->classes->{$table->sql_name};
2522 my $table_moniker = $self->monikers->{$table->sql_name};
2524 $self->_dbic_stmt($table_class, 'table_class', 'DBIx::Class::ResultSource::View')
2525 if $self->_table_is_view($table);
2527 $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
2529 my $cols = $self->_table_columns($table);
2530 my $col_info = $self->__columns_info_for($table);
2532 ### generate all the column accessor names
2533 while (my ($col, $info) = each %$col_info) {
2534 # hashref of other info that could be used by
2535 # user-defined accessor map functions
2537 table_class => $table_class,
2538 table_moniker => $table_moniker,
2539 table_name => $table, # bugwards compatibility, RT#84050
2541 full_table_name => $table->dbic_name,
2542 schema_class => $schema_class,
2543 column_info => $info,
2546 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2549 $self->_resolve_col_accessor_collisions($table, $col_info);
2551 # prune any redundant accessor names
2552 while (my ($col, $info) = each %$col_info) {
2553 no warnings 'uninitialized';
2554 delete $info->{accessor} if $info->{accessor} eq $col;
2557 my $fks = $self->_table_fk_info($table);
2559 foreach my $fkdef (@$fks) {
2560 for my $col (@{ $fkdef->{local_columns} }) {
2561 $col_info->{$col}{is_foreign_key} = 1;
2565 my $pks = $self->_table_pk_info($table) || [];
2567 my %uniq_tag; # used to eliminate duplicate uniqs
2569 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2571 my $uniqs = $self->_table_uniq_info($table) || [];
2574 foreach my $uniq (@$uniqs) {
2575 my ($name, $cols) = @$uniq;
2576 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2577 push @uniqs, [$name, $cols];
2580 my @non_nullable_uniqs = grep {
2581 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2584 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2585 my @by_colnum = sort { $b->[0] <=> $a->[0] }
2586 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2588 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2589 my @keys = map $_->[1], @by_colnum;
2593 # remove the uniq from list
2594 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2600 foreach my $pkcol (@$pks) {
2601 $col_info->{$pkcol}{is_nullable} = 0;
2607 map { $_, ($col_info->{$_}||{}) } @$cols
2610 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2613 # Sort unique constraints by constraint name for repeatable results (rels
2614 # are sorted as well elsewhere.)
2615 @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs;
2617 foreach my $uniq (@uniqs) {
2618 my ($name, $cols) = @$uniq;
2619 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2623 sub __columns_info_for {
2624 my ($self, $table) = @_;
2626 my $result = $self->_columns_info_for($table);
2628 while (my ($col, $info) = each %$result) {
2629 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
2630 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2632 $result->{$col} = $info;
2640 Returns a sorted list of loaded tables, using the original database table
2648 return values %{$self->_tables};
2652 my ($self, $naming_key) = @_;
2656 if (($self->naming->{$naming_key}||'') =~ /^v(\d+)\z/) {
2660 ($v) = $CURRENT_V =~ /^v(\d+)\z/;
2666 sub _to_identifier {
2667 my ($self, $naming_key, $name, $sep_char, $force) = @_;
2669 my $v = $self->_get_naming_v($naming_key);
2671 my $to_identifier = $self->naming->{force_ascii} ?
2672 \&String::ToIdentifier::EN::to_identifier
2673 : \&String::ToIdentifier::EN::Unicode::to_identifier;
2675 return $v >= 8 || $force ? $to_identifier->($name, $sep_char) : $name;
2678 # Make a moniker from a table
2679 sub _default_table2moniker {
2680 my ($self, $table) = @_;
2682 my $v = $self->_get_naming_v('monikers');
2684 my @moniker_parts = @{ $self->moniker_parts };
2685 my @name_parts = map $table->$_, @moniker_parts;
2687 my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
2691 foreach my $i (0 .. $#name_parts) {
2692 my $part = $name_parts[$i];
2694 my $moniker_part = $self->_run_user_map(
2695 $self->moniker_part_map->{$moniker_parts[$i]},
2697 $part, $moniker_parts[$i],
2699 if (length $moniker_part) {
2700 push @all_parts, $moniker_part;
2704 if ($i != $name_idx || $v >= 8) {
2705 $part = $self->_to_identifier('monikers', $part, '_', 1);
2708 if ($i == $name_idx && $v == 5) {
2709 $part = Lingua::EN::Inflect::Number::to_S($part);
2712 my @part_parts = map lc, $v > 6 ?
2713 # use v8 semantics for all moniker parts except name
2714 ($i == $name_idx ? split_name $part, $v : split_name $part)
2715 : split /[\W_]+/, $part;
2717 if ($i == $name_idx && $v >= 6) {
2718 my $as_phrase = join ' ', @part_parts;
2720 my $inflected = ($self->naming->{monikers}||'') eq 'plural' ?
2721 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2723 ($self->naming->{monikers}||'') eq 'preserve' ?
2726 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2728 @part_parts = split /\s+/, $inflected;
2731 push @all_parts, join '', map ucfirst, @part_parts;
2734 return join $self->moniker_part_separator, @all_parts;
2737 sub _table2moniker {
2738 my ( $self, $table ) = @_;
2740 $self->_run_user_map(
2742 sub { $self->_default_table2moniker( shift ) },
2747 sub _load_relationships {
2748 my ($self, $tables) = @_;
2752 foreach my $table (@$tables) {
2753 my $local_moniker = $self->monikers->{$table->sql_name};
2755 my $tbl_fk_info = $self->_table_fk_info($table);
2757 foreach my $fkdef (@$tbl_fk_info) {
2758 $fkdef->{local_table} = $table;
2759 $fkdef->{local_moniker} = $local_moniker;
2760 $fkdef->{remote_source} =
2761 $self->monikers->{$fkdef->{remote_table}->sql_name};
2763 my $tbl_uniq_info = $self->_table_uniq_info($table);
2765 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2768 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2770 foreach my $src_class (sort keys %$rel_stmts) {
2772 my @src_stmts = map $_->[2],
2778 ($_->{method} eq 'many_to_many' ? 1 : 0),
2781 ], @{ $rel_stmts->{$src_class} };
2783 foreach my $stmt (@src_stmts) {
2784 $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2790 my ($self, $table) = @_;
2792 my $table_moniker = $self->monikers->{$table->sql_name};
2793 my $table_class = $self->classes->{$table->sql_name};
2795 my @roles = @{ $self->result_roles || [] };
2796 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2797 if exists $self->result_roles_map->{$table_moniker};
2800 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2802 $self->_with($table_class, @roles);
2806 # Overload these in driver class:
2808 # Returns an arrayref of column names
2809 sub _table_columns { croak "ABSTRACT METHOD" }
2811 # Returns arrayref of pk col names
2812 sub _table_pk_info { croak "ABSTRACT METHOD" }
2814 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2815 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2817 # Returns an arrayref of foreign key constraints, each
2818 # being a hashref with 3 keys:
2819 # local_columns (arrayref), remote_columns (arrayref), remote_table
2820 sub _table_fk_info { croak "ABSTRACT METHOD" }
2822 # Returns an array of lower case table names
2823 sub _tables_list { croak "ABSTRACT METHOD" }
2825 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2831 # generate the pod for this statement, storing it with $self->_pod
2832 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2834 my $args = dump(@_);
2835 $args = '(' . $args . ')' if @_ < 2;
2836 my $stmt = $method . $args . q{;};
2838 warn qq|$class\->$stmt\n| if $self->debug;
2839 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2843 sub _make_pod_heading {
2844 my ($self, $class) = @_;
2846 return '' if not $self->generate_pod;
2848 my $table = $self->class_to_table->{$class};
2851 my $pcm = $self->pod_comment_mode;
2852 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2853 $comment = $self->__table_comment($table);
2854 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2855 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2856 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2858 $pod .= "=head1 NAME\n\n";
2860 my $table_descr = $class;
2861 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2863 $pod .= "$table_descr\n\n";
2865 if ($comment and $comment_in_desc) {
2866 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2873 # generates the accompanying pod for a DBIC class method statement,
2874 # storing it with $self->_pod
2880 if ($method eq 'table') {
2882 $table = $$table if ref $table eq 'SCALAR';
2883 $self->_pod($class, "=head1 TABLE: C<$table>");
2884 $self->_pod_cut($class);
2886 elsif ( $method eq 'add_columns' ) {
2887 $self->_pod( $class, "=head1 ACCESSORS" );
2888 my $col_counter = 0;
2890 while( my ($name,$attrs) = splice @cols,0,2 ) {
2892 $self->_pod( $class, '=head2 ' . $name );
2893 $self->_pod( $class,
2895 my $s = $attrs->{$_};
2896 $s = !defined $s ? 'undef' :
2897 length($s) == 0 ? '(empty string)' :
2898 ref($s) eq 'SCALAR' ? $$s :
2899 ref($s) ? dumper_squashed $s :
2900 looks_like_number($s) ? $s : qq{'$s'};
2903 } sort keys %$attrs,
2905 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2906 $self->_pod( $class, $comment );
2909 $self->_pod_cut( $class );
2910 } elsif ( $method =~ /^(?:belongs_to|has_many|might_have)\z/ ) {
2911 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2912 my ( $accessor, $rel_class ) = @_;
2913 $self->_pod( $class, "=head2 $accessor" );
2914 $self->_pod( $class, 'Type: ' . $method );
2915 $self->_pod( $class, "Related object: L<$rel_class>" );
2916 $self->_pod_cut( $class );
2917 $self->{_relations_started} { $class } = 1;
2918 } elsif ( $method eq 'many_to_many' ) {
2919 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2920 my ( $accessor, $rel1, $rel2 ) = @_;
2921 $self->_pod( $class, "=head2 $accessor" );
2922 $self->_pod( $class, 'Type: many_to_many' );
2923 $self->_pod( $class, "Composing rels: L</$rel1> -> $rel2" );
2924 $self->_pod_cut( $class );
2925 $self->{_relations_started} { $class } = 1;
2927 elsif ($method eq 'add_unique_constraint') {
2928 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2929 unless $self->{_uniqs_started}{$class};
2931 my ($name, $cols) = @_;
2933 $self->_pod($class, "=head2 C<$name>");
2934 $self->_pod($class, '=over 4');
2936 foreach my $col (@$cols) {
2937 $self->_pod($class, "=item \* L</$col>");
2940 $self->_pod($class, '=back');
2941 $self->_pod_cut($class);
2943 $self->{_uniqs_started}{$class} = 1;
2945 elsif ($method eq 'set_primary_key') {
2946 $self->_pod($class, "=head1 PRIMARY KEY");
2947 $self->_pod($class, '=over 4');
2949 foreach my $col (@_) {
2950 $self->_pod($class, "=item \* L</$col>");
2953 $self->_pod($class, '=back');
2954 $self->_pod_cut($class);
2958 sub _pod_class_list {
2959 my ($self, $class, $title, @classes) = @_;
2961 return unless @classes && $self->generate_pod;
2963 $self->_pod($class, "=head1 $title");
2964 $self->_pod($class, '=over 4');
2966 foreach my $link (@classes) {
2967 $self->_pod($class, "=item * L<$link>");
2970 $self->_pod($class, '=back');
2971 $self->_pod_cut($class);
2974 sub _base_class_pod {
2975 my ($self, $base_class) = @_;
2977 return '' unless $self->generate_pod;
2980 =head1 BASE CLASS: L<$base_class>
2987 sub _filter_comment {
2988 my ($self, $txt) = @_;
2990 $txt = '' if not defined $txt;
2992 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2997 sub __table_comment {
3000 if (my $code = $self->can('_table_comment')) {
3001 return $self->_filter_comment($self->$code(@_));
3007 sub __column_comment {
3010 if (my $code = $self->can('_column_comment')) {
3011 return $self->_filter_comment($self->$code(@_));
3017 # Stores a POD documentation
3019 my ($self, $class, $stmt) = @_;
3020 $self->_raw_stmt( $class, "\n" . $stmt );
3024 my ($self, $class ) = @_;
3025 $self->_raw_stmt( $class, "\n=cut\n" );
3028 # Store a raw source line for a class (for dumping purposes)
3030 my ($self, $class, $stmt) = @_;
3031 push(@{$self->{_dump_storage}->{$class}}, $stmt);
3034 # Like above, but separately for the externally loaded stuff
3036 my ($self, $class, $stmt) = @_;
3037 push(@{$self->{_ext_storage}->{$class}}, $stmt);
3040 sub _custom_column_info {
3041 my ( $self, $table_name, $column_name, $column_info ) = @_;
3043 if (my $code = $self->custom_column_info) {
3044 return $code->($table_name, $column_name, $column_info) || {};
3049 sub _datetime_column_info {
3050 my ( $self, $table_name, $column_name, $column_info ) = @_;
3052 my $type = $column_info->{data_type} || '';
3053 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
3054 or ($type =~ /date|timestamp/i)) {
3055 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
3056 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
3062 my ($self, $name) = @_;
3064 return $self->preserve_case ? $name : lc($name);
3068 my ($self, $name) = @_;
3070 return $self->preserve_case ? $name : uc($name);
3074 my ($self, $table) = @_;
3077 my $schema = $self->schema;
3078 # in older DBIC it's a private method
3079 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
3080 $schema->$unregister(delete $self->monikers->{$table->sql_name});
3081 delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}};
3082 delete $self->_tables->{$table->sql_name};
3086 # remove the dump dir from @INC on destruction
3090 @INC = grep $_ ne $self->dump_directory, @INC;
3095 Returns a hashref of loaded table to moniker mappings. There will
3096 be two entries for each table, the original name and the "normalized"
3097 name, in the case that the two are different (such as databases
3098 that like uppercase table names, or preserve your original mixed-case
3099 definitions, or what-have-you).
3103 Returns a hashref of table to class mappings. In some cases it will
3104 contain multiple entries per table for the original and normalized table
3105 names, as above in L</monikers>.
3107 =head1 NON-ENGLISH DATABASES
3109 If you use the loader on a database with table and column names in a language
3110 other than English, you will want to turn off the English language specific
3113 To do so, use something like this in your loader options:
3115 naming => { monikers => 'v4' },
3116 inflect_singular => sub { "$_[0]_rel" },
3117 inflect_plural => sub { "$_[0]_rel" },
3119 =head1 COLUMN ACCESSOR COLLISIONS
3121 Occasionally you may have a column name that collides with a perl method, such
3122 as C<can>. In such cases, the default action is to set the C<accessor> of the
3123 column spec to C<undef>.
3125 You can then name the accessor yourself by placing code such as the following
3128 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
3130 Another option is to use the L</col_collision_map> option.
3132 =head1 RELATIONSHIP NAME COLLISIONS
3134 In very rare cases, you may get a collision between a generated relationship
3135 name and a method in your Result class, for example if you have a foreign key
3136 called C<belongs_to>.
3138 This is a problem because relationship names are also relationship accessor
3139 methods in L<DBIx::Class>.
3141 The default behavior is to append C<_rel> to the relationship name and print
3142 out a warning that refers to this text.
3144 You can also control the renaming with the L</rel_collision_map> option.
3148 L<DBIx::Class::Schema::Loader>, L<dbicdump>
3152 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
3156 This library is free software; you can redistribute it and/or modify it under
3157 the same terms as Perl itself.
3162 # vim:et sts=4 sw=4 tw=0: