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.07042';
34 __PACKAGE__->mk_group_ro_accessors('simple', qw/
41 additional_base_classes
57 default_resultset_class
63 overwrite_modifications
90 __PACKAGE__->mk_group_accessors('simple', qw/
92 schema_version_to_dump
94 _upgrading_from_load_classes
95 _downgrading_to_load_classes
96 _rewriting_result_namespace
101 pod_comment_spillover_length
107 result_components_map
109 datetime_undef_if_invalid
110 _result_class_methods
112 filter_generated_code
116 moniker_part_separator
120 my $CURRENT_V = 'v7';
123 schema_components schema_base_class result_base_class
124 additional_base_classes left_base_classes additional_classes components
130 my $CRLF = "\x0d\x0a";
134 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
138 See L<DBIx::Class::Schema::Loader>.
142 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
143 classes, and implements the common functionality between them.
145 =head1 CONSTRUCTOR OPTIONS
147 These constructor options are the base options for
148 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
150 =head2 skip_relationships
152 Skip setting up relationships. The default is to attempt the loading
155 =head2 skip_load_external
157 Skip loading of other classes in @INC. The default is to merge all other classes
158 with the same name found in @INC into the schema file we are creating.
162 Static schemas (ones dumped to disk) will, by default, use the new-style
163 relationship names and singularized Results, unless you're overwriting an
164 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
165 which case the backward compatible RelBuilder will be activated, and the
166 appropriate monikerization used.
172 will disable the backward-compatible RelBuilder and use
173 the new-style relationship names along with singularized Results, even when
174 overwriting a dump made with an earlier version.
176 The option also takes a hashref:
179 relationships => 'v8',
181 column_accessors => 'v8',
187 naming => { ALL => 'v8', force_ascii => 1 }
195 Set L</relationships>, L</monikers> and L</column_accessors> to the specified
200 How to name relationship accessors.
204 How to name Result classes.
206 =item column_accessors
208 How to name column accessors in Result classes.
212 For L</v8> mode and later, uses L<String::ToIdentifier::EN> instead of
213 L<String::ToIdentifier::EN::Unicode> to force monikers and other identifiers to
224 Latest style, whatever that happens to be.
228 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
232 Monikers singularized as whole words, C<might_have> relationships for FKs on
233 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
235 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
240 All monikers and relationships are inflected using
241 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
242 from relationship names.
244 In general, there is very little difference between v5 and v6 schemas.
248 This mode is identical to C<v6> mode, except that monikerization of CamelCase
249 table names is also done better (but best in v8.)
251 CamelCase column names in case-preserving mode will also be handled better
252 for relationship name inflection (but best in v8.) See L</preserve_case>.
254 In this mode, CamelCase L</column_accessors> are normalized based on case
255 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
261 The default mode is L</v7>, to get L</v8> mode, you have to specify it in
262 L</naming> explicitly until C<0.08> comes out.
264 L</monikers> and L</column_accessors> are created using
265 L<String::ToIdentifier::EN::Unicode> or L<String::ToIdentifier::EN> if
266 L</force_ascii> is set; this is only significant for names with non-C<\w>
267 characters such as C<.>.
269 CamelCase identifiers with words in all caps, e.g. C<VLANValidID> are supported
270 correctly in this mode.
272 For relationships, belongs_to accessors are made from column names by stripping
273 postfixes other than C<_id> as well, for example just C<Id>, C<_?ref>, C<_?cd>,
274 C<_?code> and C<_?num>, case insensitively.
278 For L</monikers>, this option does not inflect the table names but makes
279 monikers based on the actual name. For L</column_accessors> this option does
280 not normalize CamelCase column names to lowercase column accessors, but makes
281 accessors that are the same names as the columns (with any non-\w chars
282 replaced with underscores.)
286 For L</monikers>, singularizes the names using the most current inflector. This
287 is the same as setting the option to L</current>.
291 For L</monikers>, pluralizes the names, using the most current inflector.
295 Dynamic schemas will always default to the 0.04XXX relationship names and won't
296 singularize Results for backward compatibility, to activate the new RelBuilder
297 and singularization put this in your C<Schema.pm> file:
299 __PACKAGE__->naming('current');
301 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
302 next major version upgrade:
304 __PACKAGE__->naming('v7');
308 If true, will not print the usual C<Dumping manual schema ... Schema dump
309 completed.> messages. Does not affect warnings (except for warnings related to
310 L</really_erase_my_files>.)
314 If true, don't actually write out the generated files. This can only be
315 used with static schema generation.
319 By default POD will be generated for columns and relationships, using database
320 metadata for the text if available and supported.
322 Comment metadata can be stored in two ways.
324 The first is that you can create two tables named C<table_comments> and
325 C<column_comments> respectively. These tables must exist in the same database
326 and schema as the tables they describe. They both need to have columns named
327 C<table_name> and C<comment_text>. The second one needs to have a column named
328 C<column_name>. Then data stored in these tables will be used as a source of
329 metadata about tables and comments.
331 (If you wish you can change the name of these tables with the parameters
332 L</table_comments_table> and L</column_comments_table>.)
334 As a fallback you can use built-in commenting mechanisms. Currently this is
335 only supported for PostgreSQL, Oracle and MySQL. To create comments in
336 PostgreSQL you add statements of the form C<COMMENT ON TABLE some_table IS
337 '...'>, the same syntax is used in Oracle. To create comments in MySQL you add
338 C<COMMENT '...'> to the end of the column or table definition. Note that MySQL
339 restricts the length of comments, and also does not handle complex Unicode
342 Set this to C<0> to turn off all POD generation.
344 =head2 pod_comment_mode
346 Controls where table comments appear in the generated POD. Smaller table
347 comments are appended to the C<NAME> section of the documentation, and larger
348 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
349 section to be generated with the comment always, only use C<NAME>, or choose
350 the length threshold at which the comment is forced into the description.
356 Use C<NAME> section only.
360 Force C<DESCRIPTION> always.
364 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
369 =head2 pod_comment_spillover_length
371 When pod_comment_mode is set to C<auto>, this is the length of the comment at
372 which it will be forced into a separate description section.
376 =head2 table_comments_table
378 The table to look for comments about tables in. By default C<table_comments>.
379 See L</generate_pod> for details.
381 This must not be a fully qualified name, the table will be looked for in the
382 same database and schema as the table whose comment is being retrieved.
384 =head2 column_comments_table
386 The table to look for comments about columns in. By default C<column_comments>.
387 See L</generate_pod> for details.
389 This must not be a fully qualified name, the table will be looked for in the
390 same database and schema as the table/column whose comment is being retrieved.
392 =head2 relationship_attrs
394 Hashref of attributes to pass to each generated relationship, listed by type.
395 Also supports relationship type 'all', containing options to pass to all
396 generated relationships. Attributes set for more specific relationship types
397 override those set in 'all', and any attributes specified by this option
398 override the introspected attributes of the foreign key if any.
402 relationship_attrs => {
403 has_many => { cascade_delete => 1, cascade_copy => 1 },
404 might_have => { cascade_delete => 1, cascade_copy => 1 },
407 use this to turn L<DBIx::Class> cascades to on on your
408 L<has_many|DBIx::Class::Relationship/has_many> and
409 L<might_have|DBIx::Class::Relationship/might_have> relationships, they default
412 Can also be a coderef, for more precise control, in which case the coderef gets
413 this hash of parameters (as a list:)
415 rel_name # the name of the relationship
416 rel_type # the type of the relationship: 'belongs_to', 'has_many' or 'might_have'
417 local_source # the DBIx::Class::ResultSource object for the source the rel is *from*
418 remote_source # the DBIx::Class::ResultSource object for the source the rel is *to*
419 local_table # a DBIx::Class::Schema::Loader::Table object for the table of the source the rel is from
420 local_cols # an arrayref of column names of columns used in the rel in the source it is from
421 remote_table # a DBIx::Class::Schema::Loader::Table object for the table of the source the rel is to
422 remote_cols # an arrayref of column names of columns used in the rel in the source it is to
423 attrs # the attributes that would be set
425 it should return the new hashref of attributes, or nothing for no changes.
429 relationship_attrs => sub {
432 say "the relationship name is: $p{rel_name}";
433 say "the relationship is a: $p{rel_type}";
434 say "the local class is: ", $p{local_source}->result_class;
435 say "the remote class is: ", $p{remote_source}->result_class;
436 say "the local table is: ", $p{local_table}->sql_name;
437 say "the rel columns in the local table are: ", (join ", ", @{$p{local_cols}});
438 say "the remote table is: ", $p{remote_table}->sql_name;
439 say "the rel columns in the remote table are: ", (join ", ", @{$p{remote_cols}});
441 if ($p{local_table} eq 'dogs' && @{$p{local_cols}} == 1 && $p{local_cols}[0] eq 'name') {
442 $p{attrs}{could_be_snoopy} = 1;
448 These are the default attributes:
459 on_delete => 'CASCADE',
460 on_update => 'CASCADE',
464 For L<belongs_to|DBIx::Class::Relationship/belongs_to> relationships, these
465 defaults are overridden by the attributes introspected from the foreign key in
466 the database, if this information is available (and the driver is capable of
469 This information overrides the defaults mentioned above, and is then itself
470 overridden by the user's L</relationship_attrs> for C<belongs_to> if any are
473 In general, for most databases, for a plain foreign key with no rules, the
474 values for a L<belongs_to|DBIx::Class::Relationship/belongs_to> relationship
477 on_delete => 'NO ACTION',
478 on_update => 'NO ACTION',
481 In the cases where an attribute is not supported by the DB, a value matching
482 the actual behavior is used, for example Oracle does not support C<ON UPDATE>
483 rules, so C<on_update> is set to C<NO ACTION>. This is done so that the
484 behavior of the schema is preserved when cross deploying to a different RDBMS
485 such as SQLite for testing.
487 In the cases where the DB does not support C<DEFERRABLE> foreign keys, the
488 value is set to C<1> if L<DBIx::Class> has a working C<<
489 $storage->with_deferred_fk_checks >>. This is done so that the same
490 L<DBIx::Class> code can be used, and cross deployed from and to such databases.
494 If set to true, each constructive L<DBIx::Class> statement the loader
495 decides to execute will be C<warn>-ed before execution.
499 Set the name of the schema to load (schema in the sense that your database
502 Can be set to an arrayref of schema names for multiple schemas, or the special
503 value C<%> for all schemas.
505 For MSSQL, Sybase ASE, and Informix can be set to a hashref of databases as
506 keys and arrays of owners as values, set to the value:
510 for all owners in all databases.
512 Name clashes resulting from the same table name in different databases/schemas
513 will be resolved automatically by prefixing the moniker with the database
516 To prefix/suffix all monikers with the database and/or schema, see
521 The database table names are represented by the
522 L<DBIx::Class::Schema::Loader::Table> class in the loader, the
523 L<DBIx::Class::Schema::Loader::Table::Sybase> class for Sybase ASE and
524 L<DBIx::Class::Schema::Loader::Table::Informix> for Informix.
526 Monikers are created normally based on just the
527 L<name|DBIx::Class::Schema::Loader::DBObject/name> property, corresponding to
528 the table name, but can consist of other parts of the fully qualified name of
531 The L</moniker_parts> option is an arrayref of methods on the table class
532 corresponding to parts of the fully qualified table name, defaulting to
533 C<['name']>, in the order those parts are used to create the moniker name.
534 The parts are joined together using L</moniker_part_separator>.
536 The C<'name'> entry B<must> be present.
538 Below is a table of supported databases and possible L</moniker_parts>.
542 =item * DB2, Firebird, mysql, Oracle, Pg, SQLAnywhere, SQLite, MS Access
546 =item * Informix, MSSQL, Sybase ASE
548 C<database>, C<schema>, C<name>
552 =head2 moniker_part_separator
554 String used to join L</moniker_parts> when creating the moniker.
555 Defaults to the empty string. Use C<::> to get a separate namespace per
556 database and/or schema.
560 Only load matching tables.
564 Exclude matching tables.
566 These can be specified either as a regex (preferrably on the C<qr//>
567 form), or as an arrayref of arrayrefs. Regexes are matched against
568 the (unqualified) table name, while arrayrefs are matched according to
573 db_schema => [qw(some_schema other_schema)],
574 moniker_parts => [qw(schema name)],
576 [ qr/\Asome_schema\z/ => qr/\A(?:foo|bar)\z/ ],
577 [ qr/\Aother_schema\z/ => qr/\Abaz\z/ ],
580 In this case only the tables C<foo> and C<bar> in C<some_schema> and
581 C<baz> in C<other_schema> will be dumped.
585 Overrides the default table name to moniker translation. Either
591 a nested hashref, which will be traversed according to L</moniker_parts>
595 moniker_parts => [qw(schema name)],
602 In which case the table C<bar> in the C<foo> schema would get the moniker
607 a hashref of unqualified table name keys and moniker values
611 a coderef for a translator function taking a L<table
612 object|DBIx::Class::Schema::Loader::Table> argument (which stringifies to the
613 unqualified table name) and returning a scalar moniker
615 The function is also passed a coderef that can be called with either
616 of the hashref forms to get the moniker mapped accordingly. This is
617 useful if you need to handle some monikers specially, but want to use
618 the hashref form for the rest.
622 If the hash entry does not exist, or the function returns a false
623 value, the code falls back to default behavior for that table name.
625 The default behavior is to split on case transition and non-alphanumeric
626 boundaries, singularize the resulting phrase, then join the titlecased words
629 Table Name | Moniker Name
630 ---------------------------------
632 luser_group | LuserGroup
633 luser-opts | LuserOpt
634 stations_visited | StationVisited
635 routeChange | RouteChange
637 =head2 moniker_part_map
639 Map for overriding the monikerization of individual L</moniker_parts>.
640 The keys are the moniker part to override, the value is either a
641 hashref of coderef for mapping the corresponding part of the
642 moniker. If a coderef is used, it gets called with the moniker part
643 and the hash key the code ref was found under.
647 moniker_part_map => {
648 schema => sub { ... },
651 Given the table C<foo.bar>, the code ref would be called with the
652 arguments C<foo> and C<schema>, plus a coderef similar to the one
653 described in L</moniker_map>.
655 L</moniker_map> takes precedence over this.
657 =head2 col_accessor_map
659 Same as moniker_map, but for column accessor names. If a coderef is
660 passed, the code is called with arguments of
662 the name of the column in the underlying database,
663 default accessor name that DBICSL would ordinarily give this column,
665 table_class => name of the DBIC class we are building,
666 table_moniker => calculated moniker for this table (after moniker_map if present),
667 table => table object of interface DBIx::Class::Schema::Loader::Table,
668 full_table_name => schema-qualified name of the database table (RDBMS specific),
669 schema_class => name of the schema class we are building,
670 column_info => hashref of column info (data_type, is_nullable, etc),
672 coderef ref that can be called with a hashref map
674 the L<table object|DBIx::Class::Schema::Loader::Table> stringifies to the
675 unqualified table name.
679 Similar in idea to moniker_map, but different in the details. It can be
680 a hashref or a code ref.
682 If it is a hashref, keys can be either the default relationship name, or the
683 moniker. The keys that are the default relationship name should map to the
684 name you want to change the relationship to. Keys that are monikers should map
685 to hashes mapping relationship names to their translation. You can do both at
686 once, and the more specific moniker version will be picked up first. So, for
687 instance, you could have
696 and relationships that would have been named C<bar> will now be named C<baz>
697 except that in the table whose moniker is C<Foo> it will be named C<blat>.
699 If it is a coderef, it will be passed a hashref of this form:
702 name => default relationship name,
703 type => the relationship type eg: C<has_many>,
704 local_class => name of the DBIC class we are building,
705 local_moniker => moniker of the DBIC class we are building,
706 local_columns => columns in this table in the relationship,
707 remote_class => name of the DBIC class we are related to,
708 remote_moniker => moniker of the DBIC class we are related to,
709 remote_columns => columns in the other table in the relationship,
710 # for type => "many_to_many" only:
711 link_class => name of the DBIC class for the link table
712 link_moniker => moniker of the DBIC class for the link table
713 link_rel_name => name of the relationship to the link table
716 In addition it is passed a coderef that can be called with a hashref map.
718 DBICSL will try to use the value returned as the relationship name.
720 =head2 inflect_plural
722 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
723 if hash key does not exist or coderef returns false), but acts as a map
724 for pluralizing relationship names. The default behavior is to utilize
725 L<Lingua::EN::Inflect::Phrase/to_PL>.
727 =head2 inflect_singular
729 As L</inflect_plural> above, but for singularizing relationship names.
730 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
732 =head2 schema_base_class
734 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
736 =head2 schema_components
738 List of components to load into the Schema class.
740 =head2 result_base_class
742 Base class for your table classes (aka result classes). Defaults to
745 =head2 additional_base_classes
747 List of additional base classes all of your table classes will use.
749 =head2 left_base_classes
751 List of additional base classes all of your table classes will use
752 that need to be leftmost.
754 =head2 additional_classes
756 List of additional classes which all of your table classes will use.
760 List of additional components to be loaded into all of your Result
761 classes. A good example would be
762 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
764 =head2 result_components_map
766 A hashref of moniker keys and component values. Unlike L</components>, which
767 loads the given components into every Result class, this option allows you to
768 load certain components for specified Result classes. For example:
770 result_components_map => {
771 StationVisited => '+YourApp::Schema::Component::StationVisited',
773 '+YourApp::Schema::Component::RouteChange',
774 'InflateColumn::DateTime',
778 You may use this in conjunction with L</components>.
782 List of L<Moose> roles to be applied to all of your Result classes.
784 =head2 result_roles_map
786 A hashref of moniker keys and role values. Unlike L</result_roles>, which
787 applies the given roles to every Result class, this option allows you to apply
788 certain roles for specified Result classes. For example:
790 result_roles_map => {
792 'YourApp::Role::Building',
793 'YourApp::Role::Destination',
795 RouteChange => 'YourApp::Role::TripEvent',
798 You may use this in conjunction with L</result_roles>.
800 =head2 use_namespaces
802 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
805 Generate result class names suitable for
806 L<DBIx::Class::Schema/load_namespaces> and call that instead of
807 L<DBIx::Class::Schema/load_classes>. When using this option you can also
808 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
809 C<resultset_namespace>, C<default_resultset_class>), and they will be added
810 to the call (and the generated result class names adjusted appropriately).
812 =head2 dump_directory
814 The value of this option is a perl libdir pathname. Within
815 that directory this module will create a baseline manual
816 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
818 The created schema class will have the same classname as the one on
819 which you are setting this option (and the ResultSource classes will be
820 based on this name as well).
822 Normally you wouldn't hard-code this setting in your schema class, as it
823 is meant for one-time manual usage.
825 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
826 recommended way to access this functionality.
828 =head2 dump_overwrite
830 Deprecated. See L</really_erase_my_files> below, which does *not* mean
831 the same thing as the old C<dump_overwrite> setting from previous releases.
833 =head2 really_erase_my_files
835 Default false. If true, Loader will unconditionally delete any existing
836 files before creating the new ones from scratch when dumping a schema to disk.
838 The default behavior is instead to only replace the top portion of the
839 file, up to and including the final stanza which contains
840 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
841 leaving any customizations you placed after that as they were.
843 When C<really_erase_my_files> is not set, if the output file already exists,
844 but the aforementioned final stanza is not found, or the checksum
845 contained there does not match the generated contents, Loader will
846 croak and not touch the file.
848 You should really be using version control on your schema classes (and all
849 of the rest of your code for that matter). Don't blame me if a bug in this
850 code wipes something out when it shouldn't have, you've been warned.
852 =head2 overwrite_modifications
854 Default false. If false, when updating existing files, Loader will
855 refuse to modify any Loader-generated code that has been modified
856 since its last run (as determined by the checksum Loader put in its
859 If true, Loader will discard any manual modifications that have been
860 made to Loader-generated code.
862 Again, you should be using version control on your schema classes. Be
863 careful with this option.
867 Omit the package version from the signature comment.
869 =head2 omit_timestamp
871 Omit the creation timestamp from the signature comment.
873 =head2 custom_column_info
875 Hook for adding extra attributes to the
876 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
878 Must be a coderef that returns a hashref with the extra attributes.
880 Receives the L<table object|DBIx::Class::Schema::Loader::Table> (which
881 stringifies to the unqualified table name), column name and column_info.
885 custom_column_info => sub {
886 my ($table, $column_name, $column_info) = @_;
888 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
889 return { is_snoopy => 1 };
893 This attribute can also be used to set C<inflate_datetime> on a non-datetime
894 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
896 =head2 datetime_timezone
898 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
899 columns with the DATE/DATETIME/TIMESTAMP data_types.
901 =head2 datetime_locale
903 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
904 columns with the DATE/DATETIME/TIMESTAMP data_types.
906 =head2 datetime_undef_if_invalid
908 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
909 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
912 The default is recommended to deal with data such as C<00/00/00> which
913 sometimes ends up in such columns in MySQL.
917 File in Perl format, which should return a HASH reference, from which to read
922 Normally database names are lowercased and split by underscore, use this option
923 if you have CamelCase database names.
925 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
926 case-sensitive collation will turn this option on unconditionally.
928 B<NOTE:> L</naming> = C<v8> is highly recommended with this option as the
929 semantics of this mode are much improved for CamelCase database names.
931 L</naming> = C<v7> or greater is required with this option.
933 =head2 qualify_objects
935 Set to true to prepend the L</db_schema> to table names for C<<
936 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
938 This attribute is automatically set to true for multi db_schema configurations,
939 unless explicitly set to false by the user.
943 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
944 L<MooseX::MarkAsMethods> (or L<namespace::autoclean>, see below). The default
945 content after the md5 sum also makes the classes immutable.
947 It is safe to upgrade your existing Schema to this option.
949 =head2 only_autoclean
951 By default, we use L<MooseX::MarkAsMethods> to remove imported functions from
952 your generated classes. It uses L<namespace::autoclean> to do this, after
953 telling your object's metaclass that any operator L<overload>s in your class
954 are methods, which will cause namespace::autoclean to spare them from removal.
956 This prevents the "Hey, where'd my overloads go?!" effect.
958 If you don't care about operator overloads, enabling this option falls back to
959 just using L<namespace::autoclean> itself.
961 If none of the above made any sense, or you don't have some pressing need to
962 only use L<namespace::autoclean>, leaving this set to the default is
965 =head2 col_collision_map
967 This option controls how accessors for column names which collide with perl
968 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
970 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
971 strings which are compiled to regular expressions that map to
972 L<sprintf|perlfunc/sprintf> formats.
976 col_collision_map => 'column_%s'
978 col_collision_map => { '(.*)' => 'column_%s' }
980 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
982 =head2 rel_collision_map
984 Works just like L</col_collision_map>, but for relationship names/accessors
985 rather than column names/accessors.
987 The default is to just append C<_rel> to the relationship name, see
988 L</RELATIONSHIP NAME COLLISIONS>.
990 =head2 uniq_to_primary
992 Automatically promotes the largest unique constraints with non-nullable columns
993 on tables to primary keys, assuming there is only one largest unique
996 =head2 filter_generated_code
998 An optional hook that lets you filter the generated text for various classes
999 through a function that change it in any way that you want. The function will
1000 receive the type of file, C<schema> or C<result>, class and code; and returns
1001 the new code to use instead. For instance you could add custom comments, or do
1002 anything else that you want.
1004 The option can also be set to a string, which is then used as a filter program,
1007 If this exists but fails to return text matching C</\bpackage\b/>, no file will
1010 filter_generated_code => sub {
1011 my ($type, $class, $text) = @_;
1016 You can also use this option to set L<perltidy markers|perltidy/Skipping
1017 Selected Sections of Code> in your generated classes. This will leave
1018 the generated code in the default format, but will allow you to tidy
1019 your classes at any point in future, without worrying about changing the
1020 portions of the file which are checksummed, since C<perltidy> will just
1021 ignore all text between the markers.
1023 filter_generated_code => sub {
1024 return "#<<<\n$_[2]\n#>>>";
1029 None of these methods are intended for direct invocation by regular
1030 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
1031 L<DBIx::Class::Schema::Loader>.
1035 # ensure that a piece of object data is a valid arrayref, creating
1036 # an empty one or encapsulating whatever's there.
1037 sub _ensure_arrayref {
1042 $self->{$_} = [ $self->{$_} ]
1043 unless ref $self->{$_} eq 'ARRAY';
1049 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
1050 by L<DBIx::Class::Schema::Loader>.
1055 my ( $class, %args ) = @_;
1057 if (exists $args{column_accessor_map}) {
1058 $args{col_accessor_map} = delete $args{column_accessor_map};
1061 my $self = { %args };
1063 # don't lose undef options
1064 for (values %$self) {
1065 $_ = 0 unless defined $_;
1068 bless $self => $class;
1070 if (my $config_file = $self->config_file) {
1071 my $config_opts = do $config_file;
1073 croak "Error reading config from $config_file: $@" if $@;
1075 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
1077 while (my ($k, $v) = each %$config_opts) {
1078 $self->{$k} = $v unless exists $self->{$k};
1082 if (defined $self->{result_component_map}) {
1083 if (defined $self->result_components_map) {
1084 croak "Specify only one of result_components_map or result_component_map";
1086 $self->result_components_map($self->{result_component_map})
1089 if (defined $self->{result_role_map}) {
1090 if (defined $self->result_roles_map) {
1091 croak "Specify only one of result_roles_map or result_role_map";
1093 $self->result_roles_map($self->{result_role_map})
1096 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
1097 if ((not defined $self->use_moose) || (not $self->use_moose))
1098 && ((defined $self->result_roles) || (defined $self->result_roles_map));
1100 $self->_ensure_arrayref(qw/schema_components
1102 additional_base_classes
1108 $self->_validate_class_args;
1110 croak "result_components_map must be a hash"
1111 if defined $self->result_components_map
1112 && ref $self->result_components_map ne 'HASH';
1114 if ($self->result_components_map) {
1115 my %rc_map = %{ $self->result_components_map };
1116 foreach my $moniker (keys %rc_map) {
1117 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
1119 $self->result_components_map(\%rc_map);
1122 $self->result_components_map({});
1124 $self->_validate_result_components_map;
1126 croak "result_roles_map must be a hash"
1127 if defined $self->result_roles_map
1128 && ref $self->result_roles_map ne 'HASH';
1130 if ($self->result_roles_map) {
1131 my %rr_map = %{ $self->result_roles_map };
1132 foreach my $moniker (keys %rr_map) {
1133 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
1135 $self->result_roles_map(\%rr_map);
1137 $self->result_roles_map({});
1139 $self->_validate_result_roles_map;
1141 if ($self->use_moose) {
1142 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
1143 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
1144 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
1148 $self->{_tables} = {};
1149 $self->{monikers} = {};
1150 $self->{moniker_to_table} = {};
1151 $self->{class_to_table} = {};
1152 $self->{classes} = {};
1153 $self->{_upgrading_classes} = {};
1154 $self->{generated_classes} = [];
1156 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
1157 $self->{schema} ||= $self->{schema_class};
1158 $self->{table_comments_table} ||= 'table_comments';
1159 $self->{column_comments_table} ||= 'column_comments';
1161 croak "dump_overwrite is deprecated. Please read the"
1162 . " DBIx::Class::Schema::Loader::Base documentation"
1163 if $self->{dump_overwrite};
1165 $self->{dynamic} = ! $self->{dump_directory};
1167 croak "dry_run can only be used with static schema generation"
1168 if $self->dynamic and $self->dry_run;
1170 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
1175 $self->{dump_directory} ||= $self->{temp_directory};
1177 $self->real_dump_directory($self->{dump_directory});
1179 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
1180 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
1182 if (not defined $self->naming) {
1183 $self->naming_set(0);
1186 $self->naming_set(1);
1189 if ((not ref $self->naming) && defined $self->naming) {
1190 my $naming_ver = $self->naming;
1192 relationships => $naming_ver,
1193 monikers => $naming_ver,
1194 column_accessors => $naming_ver,
1197 elsif (ref $self->naming eq 'HASH' && exists $self->naming->{ALL}) {
1198 my $val = delete $self->naming->{ALL};
1200 $self->naming->{$_} = $val
1201 foreach qw/relationships monikers column_accessors/;
1204 if ($self->naming) {
1205 foreach my $key (qw/relationships monikers column_accessors/) {
1206 $self->naming->{$key} = $CURRENT_V if ($self->naming->{$key}||'') eq 'current';
1209 $self->{naming} ||= {};
1211 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
1212 croak 'custom_column_info must be a CODE ref';
1215 $self->_check_back_compat;
1217 $self->use_namespaces(1) unless defined $self->use_namespaces;
1218 $self->generate_pod(1) unless defined $self->generate_pod;
1219 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
1220 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
1222 if (my $col_collision_map = $self->col_collision_map) {
1223 if (my $reftype = ref $col_collision_map) {
1224 if ($reftype ne 'HASH') {
1225 croak "Invalid type $reftype for option 'col_collision_map'";
1229 $self->col_collision_map({ '(.*)' => $col_collision_map });
1233 if (my $rel_collision_map = $self->rel_collision_map) {
1234 if (my $reftype = ref $rel_collision_map) {
1235 if ($reftype ne 'HASH') {
1236 croak "Invalid type $reftype for option 'rel_collision_map'";
1240 $self->rel_collision_map({ '(.*)' => $rel_collision_map });
1244 if (defined(my $rel_name_map = $self->rel_name_map)) {
1245 my $reftype = ref $rel_name_map;
1246 if ($reftype ne 'HASH' && $reftype ne 'CODE') {
1247 croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
1251 if (defined(my $filter = $self->filter_generated_code)) {
1252 my $reftype = ref $filter;
1253 if ($reftype && $reftype ne 'CODE') {
1254 croak "Invalid type $reftype for option 'filter_generated_code, must be a scalar or a CODE reference";
1258 if (defined $self->db_schema) {
1259 if (ref $self->db_schema eq 'ARRAY') {
1260 if (@{ $self->db_schema } > 1 && not defined $self->{qualify_objects}) {
1261 $self->{qualify_objects} = 1;
1263 elsif (@{ $self->db_schema } == 0) {
1264 $self->{db_schema} = undef;
1267 elsif (not ref $self->db_schema) {
1268 if ($self->db_schema eq '%' && not defined $self->{qualify_objects}) {
1269 $self->{qualify_objects} = 1;
1272 $self->{db_schema} = [ $self->db_schema ];
1276 if (not $self->moniker_parts) {
1277 $self->moniker_parts(['name']);
1280 if (not ref $self->moniker_parts) {
1281 $self->moniker_parts([ $self->moniker_parts ]);
1283 if (ref $self->moniker_parts ne 'ARRAY') {
1284 croak 'moniker_parts must be an arrayref';
1286 if ((firstidx { $_ eq 'name' } @{ $self->moniker_parts }) == -1) {
1287 croak "moniker_parts option *must* contain 'name'";
1291 if (not defined $self->moniker_part_separator) {
1292 $self->moniker_part_separator('');
1294 if (not defined $self->moniker_part_map) {
1295 $self->moniker_part_map({}),
1301 sub _check_back_compat {
1304 # dynamic schemas will always be in 0.04006 mode, unless overridden
1305 if ($self->dynamic) {
1306 # just in case, though no one is likely to dump a dynamic schema
1307 $self->schema_version_to_dump('0.04006');
1309 if (not $self->naming_set) {
1310 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1312 Dynamic schema detected, will run in 0.04006 mode.
1314 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1315 to disable this warning.
1317 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1322 $self->_upgrading_from('v4');
1325 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
1326 $self->use_namespaces(1);
1329 $self->naming->{relationships} ||= 'v4';
1330 $self->naming->{monikers} ||= 'v4';
1332 if ($self->use_namespaces) {
1333 $self->_upgrading_from_load_classes(1);
1336 $self->use_namespaces(0);
1342 # otherwise check if we need backcompat mode for a static schema
1343 my $filename = $self->get_dump_filename($self->schema_class);
1344 return unless -e $filename;
1346 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
1347 $self->_parse_generated_file($filename);
1349 return unless $old_ver;
1351 # determine if the existing schema was dumped with use_moose => 1
1352 if (! defined $self->use_moose) {
1353 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
1356 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
1358 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
1359 my $ds = eval $result_namespace;
1361 Could not eval expression '$result_namespace' for result_namespace from
1364 $result_namespace = $ds || '';
1366 if ($load_classes && (not defined $self->use_namespaces)) {
1367 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1369 'load_classes;' static schema detected, turning off 'use_namespaces'.
1371 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
1372 variable to disable this warning.
1374 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1377 $self->use_namespaces(0);
1379 elsif ($load_classes && $self->use_namespaces) {
1380 $self->_upgrading_from_load_classes(1);
1382 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
1383 $self->_downgrading_to_load_classes(
1384 $result_namespace || 'Result'
1387 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
1388 if (not $self->result_namespace) {
1389 $self->result_namespace($result_namespace || 'Result');
1391 elsif ($result_namespace ne $self->result_namespace) {
1392 $self->_rewriting_result_namespace(
1393 $result_namespace || 'Result'
1398 # XXX when we go past .0 this will need fixing
1399 my ($v) = $old_ver =~ /([1-9])/;
1402 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
1404 if (not %{ $self->naming }) {
1405 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1407 Version $old_ver static schema detected, turning on backcompat mode.
1409 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1410 to disable this warning.
1412 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
1414 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
1415 from version 0.04006.
1418 $self->naming->{relationships} ||= $v;
1419 $self->naming->{monikers} ||= $v;
1420 $self->naming->{column_accessors} ||= $v;
1422 $self->schema_version_to_dump($old_ver);
1425 $self->_upgrading_from($v);
1429 sub _validate_class_args {
1432 foreach my $k (@CLASS_ARGS) {
1433 next unless $self->$k;
1435 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
1436 $self->_validate_classes($k, \@classes);
1440 sub _validate_result_components_map {
1443 foreach my $classes (values %{ $self->result_components_map }) {
1444 $self->_validate_classes('result_components_map', $classes);
1448 sub _validate_result_roles_map {
1451 foreach my $classes (values %{ $self->result_roles_map }) {
1452 $self->_validate_classes('result_roles_map', $classes);
1456 sub _validate_classes {
1459 my $classes = shift;
1461 # make a copy to not destroy original
1462 my @classes = @$classes;
1464 foreach my $c (@classes) {
1465 # components default to being under the DBIx::Class namespace unless they
1466 # are preceded with a '+'
1467 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1468 $c = 'DBIx::Class::' . $c;
1471 # 1 == installed, 0 == not installed, undef == invalid classname
1472 my $installed = Class::Inspector->installed($c);
1473 if ( defined($installed) ) {
1474 if ( $installed == 0 ) {
1475 croak qq/$c, as specified in the loader option "$key", is not installed/;
1478 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1484 sub _find_file_in_inc {
1485 my ($self, $file) = @_;
1487 foreach my $prefix (@INC) {
1488 my $fullpath = File::Spec->catfile($prefix, $file);
1489 # abs_path pure-perl fallback warns for non-existent files
1490 local $SIG{__WARN__} = sigwarn_silencer(qr/^stat\(.*\Q$file\E\)/);
1491 return $fullpath if -f $fullpath
1492 # abs_path throws on Windows for nonexistent files
1493 and (try { Cwd::abs_path($fullpath) }) ne
1494 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1500 sub _find_class_in_inc {
1501 my ($self, $class) = @_;
1503 return $self->_find_file_in_inc(class_path($class));
1509 return $self->_upgrading_from
1510 || $self->_upgrading_from_load_classes
1511 || $self->_downgrading_to_load_classes
1512 || $self->_rewriting_result_namespace
1516 sub _rewrite_old_classnames {
1517 my ($self, $code) = @_;
1519 return $code unless $self->_rewriting;
1521 my %old_classes = reverse %{ $self->_upgrading_classes };
1523 my $re = join '|', keys %old_classes;
1524 $re = qr/\b($re)\b/;
1526 $code =~ s/$re/$old_classes{$1} || $1/eg;
1531 sub _load_external {
1532 my ($self, $class) = @_;
1534 return if $self->{skip_load_external};
1536 # so that we don't load our own classes, under any circumstances
1537 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1539 my $real_inc_path = $self->_find_class_in_inc($class);
1541 my $old_class = $self->_upgrading_classes->{$class}
1542 if $self->_rewriting;
1544 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1545 if $old_class && $old_class ne $class;
1547 return unless $real_inc_path || $old_real_inc_path;
1549 if ($real_inc_path) {
1550 # If we make it to here, we loaded an external definition
1551 warn qq/# Loaded external class definition for '$class'\n/
1554 my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path);
1556 if ($self->dynamic) { # load the class too
1557 eval_package_without_redefine_warnings($class, $code);
1560 $self->_ext_stmt($class,
1561 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1562 .qq|# They are now part of the custom portion of this file\n|
1563 .qq|# for you to hand-edit. If you do not either delete\n|
1564 .qq|# this section or remove that file from \@INC, this section\n|
1565 .qq|# will be repeated redundantly when you re-create this\n|
1566 .qq|# file again via Loader! See skip_load_external to disable\n|
1567 .qq|# this feature.\n|
1570 $self->_ext_stmt($class, $code);
1571 $self->_ext_stmt($class,
1572 qq|# End of lines loaded from '$real_inc_path' |
1576 if ($old_real_inc_path) {
1577 my $code = slurp_file $old_real_inc_path;
1579 $self->_ext_stmt($class, <<"EOF");
1581 # These lines were loaded from '$old_real_inc_path',
1582 # based on the Result class name that would have been created by an older
1583 # version of the Loader. For a static schema, this happens only once during
1584 # upgrade. See skip_load_external to disable this feature.
1587 $code = $self->_rewrite_old_classnames($code);
1589 if ($self->dynamic) {
1592 Detected external content in '$old_real_inc_path', a class name that would have
1593 been used by an older version of the Loader.
1595 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1596 new name of the Result.
1598 eval_package_without_redefine_warnings($class, $code);
1602 $self->_ext_stmt($class, $code);
1603 $self->_ext_stmt($class,
1604 qq|# End of lines loaded from '$old_real_inc_path' |
1611 Does the actual schema-construction work.
1618 $self->_load_tables(
1619 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1627 Rescan the database for changes. Returns a list of the newly added table
1630 The schema argument should be the schema class or object to be affected. It
1631 should probably be derived from the original schema_class used during L</load>.
1636 my ($self, $schema) = @_;
1638 $self->{schema} = $schema;
1639 $self->_relbuilder->{schema} = $schema;
1642 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1644 foreach my $table (@current) {
1645 if(!exists $self->_tables->{$table->sql_name}) {
1646 push(@created, $table);
1651 @current{map $_->sql_name, @current} = ();
1652 foreach my $table (values %{ $self->_tables }) {
1653 if (not exists $current{$table->sql_name}) {
1654 $self->_remove_table($table);
1658 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1660 my $loaded = $self->_load_tables(@current);
1662 foreach my $table (@created) {
1663 $self->monikers->{$table->sql_name} = $self->_table2moniker($table);
1666 return map { $self->monikers->{$_->sql_name} } @created;
1672 return if $self->{skip_relationships};
1674 return $self->{relbuilder} ||= do {
1675 my $relbuilder_suff =
1682 ->{$self->naming->{relationships}||$CURRENT_V} || '';
1684 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1685 $self->ensure_class_loaded($relbuilder_class);
1686 $relbuilder_class->new($self);
1691 my ($self, @tables) = @_;
1693 # Save the new tables to the tables list and compute monikers
1695 $self->_tables->{$_->sql_name} = $_;
1696 $self->monikers->{$_->sql_name} = $self->_table2moniker($_);
1699 # check for moniker clashes
1700 my $inverse_moniker_idx;
1701 foreach my $imtable (values %{ $self->_tables }) {
1702 push @{ $inverse_moniker_idx->{$self->monikers->{$imtable->sql_name}} }, $imtable;
1706 foreach my $moniker (keys %$inverse_moniker_idx) {
1707 my $imtables = $inverse_moniker_idx->{$moniker};
1708 if (@$imtables > 1) {
1709 my $different_databases =
1710 $imtables->[0]->can('database') && (uniq map $_->database||'', @$imtables) > 1;
1712 my $different_schemas =
1713 (uniq map $_->schema||'', @$imtables) > 1;
1715 if ($different_databases || $different_schemas) {
1716 my ($use_schema, $use_database) = (1, 0);
1718 if ($different_databases) {
1721 # If any monikers are in the same database, we have to distinguish by
1722 # both schema and database.
1724 $db_counts{$_}++ for map $_->database, @$imtables;
1725 $use_schema = any { $_ > 1 } values %db_counts;
1728 foreach my $tbl (@$imtables) { delete $self->monikers->{$tbl->sql_name}; }
1730 my $moniker_parts = [ @{ $self->moniker_parts } ];
1732 my $have_schema = any { $_ eq 'schema' } @{ $self->moniker_parts };
1733 my $have_database = any { $_ eq 'database' } @{ $self->moniker_parts };
1735 unshift @$moniker_parts, 'schema' if $use_schema && !$have_schema;
1736 unshift @$moniker_parts, 'database' if $use_database && !$have_database;
1738 local $self->{moniker_parts} = $moniker_parts;
1742 foreach my $tbl (@$imtables) { $new_monikers{$tbl->sql_name} = $self->_table2moniker($tbl); }
1743 foreach my $name (map $_->sql_name, @$imtables) { $self->monikers->{$name} = $new_monikers{$name}; }
1745 # check if there are still clashes
1748 while (my ($t, $m) = each %new_monikers) {
1749 push @{ $by_moniker{$m} }, $t;
1752 foreach my $m (grep @{ $by_moniker{$_} } > 1, keys %by_moniker) {
1753 push @clashes, sprintf ("tried disambiguating by moniker_parts, but tables %s still reduced to the same source moniker '%s'",
1754 join (', ', @{ $by_moniker{$m} }),
1760 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1761 join (', ', map $_->sql_name, @$imtables),
1769 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1770 . 'Change the naming style, or supply an explicit moniker_map: '
1771 . join ('; ', @clashes)
1776 foreach my $tbl (@tables) { $self->_make_src_class($tbl); }
1777 foreach my $tbl (@tables) { $self->_setup_src_meta($tbl); }
1779 if(!$self->skip_relationships) {
1780 # The relationship loader needs a working schema
1781 local $self->{quiet} = 1;
1782 local $self->{dump_directory} = $self->{temp_directory};
1783 local $self->{generated_classes} = [];
1784 local $self->{dry_run} = 0;
1785 $self->_reload_classes(\@tables);
1786 $self->_load_relationships(\@tables);
1788 # Remove that temp dir from INC so it doesn't get reloaded
1789 @INC = grep $_ ne $self->dump_directory, @INC;
1792 foreach my $tbl (@tables) { $self->_load_roles($tbl); }
1793 foreach my $tbl (map { $self->classes->{$_->sql_name} } @tables) { $self->_load_external($tbl); }
1795 # Reload without unloading first to preserve any symbols from external
1797 $self->_reload_classes(\@tables, { unload => 0 });
1799 # Drop temporary cache
1800 delete $self->{_cache};
1805 sub _reload_classes {
1806 my ($self, $tables, $opts) = @_;
1808 my @tables = @$tables;
1810 my $unload = $opts->{unload};
1811 $unload = 1 unless defined $unload;
1813 # so that we don't repeat custom sections
1814 @INC = grep $_ ne $self->dump_directory, @INC;
1816 $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables);
1818 unshift @INC, $self->dump_directory;
1820 return if $self->dry_run;
1823 my %have_source = map { $_ => $self->schema->source($_) }
1824 $self->schema->sources;
1826 for my $table (@tables) {
1827 my $moniker = $self->monikers->{$table->sql_name};
1828 my $class = $self->classes->{$table->sql_name};
1831 no warnings 'redefine';
1832 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1835 if (my $mc = $self->_moose_metaclass($class)) {
1838 Class::Unload->unload($class) if $unload;
1839 my ($source, $resultset_class);
1841 ($source = $have_source{$moniker})
1842 && ($resultset_class = $source->resultset_class)
1843 && ($resultset_class ne 'DBIx::Class::ResultSet')
1845 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1846 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1849 Class::Unload->unload($resultset_class) if $unload;
1850 $self->_reload_class($resultset_class) if $has_file;
1852 $self->_reload_class($class);
1854 push @to_register, [$moniker, $class];
1857 Class::C3->reinitialize;
1858 for (@to_register) {
1859 $self->schema->register_class(@$_);
1863 sub _moose_metaclass {
1864 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1868 my $mc = try { Class::MOP::class_of($class) }
1871 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1874 # We use this instead of ensure_class_loaded when there are package symbols we
1877 my ($self, $class) = @_;
1879 delete $INC{ +class_path($class) };
1882 eval_package_without_redefine_warnings ($class, "require $class");
1885 my $source = slurp_file $self->_get_dump_filename($class);
1886 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1890 sub _get_dump_filename {
1891 my ($self, $class) = (@_);
1893 $class =~ s{::}{/}g;
1894 return $self->dump_directory . q{/} . $class . q{.pm};
1897 =head2 get_dump_filename
1901 Returns the full path to the file for a class that the class has been or will
1902 be dumped to. This is a file in a temp dir for a dynamic schema.
1906 sub get_dump_filename {
1907 my ($self, $class) = (@_);
1909 local $self->{dump_directory} = $self->real_dump_directory;
1911 return $self->_get_dump_filename($class);
1914 sub _ensure_dump_subdirs {
1915 my ($self, $class) = (@_);
1917 return if $self->dry_run;
1919 my @name_parts = split(/::/, $class);
1920 pop @name_parts; # we don't care about the very last element,
1921 # which is a filename
1923 my $dir = $self->dump_directory;
1926 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1928 last if !@name_parts;
1929 $dir = File::Spec->catdir($dir, shift @name_parts);
1934 my ($self, @classes) = @_;
1936 my $schema_class = $self->schema_class;
1937 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1939 my $target_dir = $self->dump_directory;
1940 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1941 unless $self->dynamic or $self->quiet;
1945 . qq|package $schema_class;\n\n|
1946 . qq|# Created by DBIx::Class::Schema::Loader\n|
1947 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1950 = $self->only_autoclean
1951 ? 'namespace::autoclean'
1952 : 'MooseX::MarkAsMethods autoclean => 1'
1955 if ($self->use_moose) {
1957 $schema_text.= qq|use Moose;\nuse $autoclean;\nextends '$schema_base_class';\n\n|;
1960 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1963 my @schema_components = @{ $self->schema_components || [] };
1965 if (@schema_components) {
1966 my $schema_components = dump @schema_components;
1967 $schema_components = "($schema_components)" if @schema_components == 1;
1969 $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1972 if ($self->use_namespaces) {
1973 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1974 my $namespace_options;
1976 my @attr = qw/resultset_namespace default_resultset_class/;
1978 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1980 for my $attr (@attr) {
1982 my $code = dumper_squashed $self->$attr;
1983 $namespace_options .= qq| $attr => $code,\n|
1986 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1987 $schema_text .= qq|;\n|;
1990 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1994 local $self->{version_to_dump} = $self->schema_version_to_dump;
1995 $self->_write_classfile($schema_class, $schema_text, 1);
1998 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
2000 foreach my $src_class (@classes) {
2003 . qq|package $src_class;\n\n|
2004 . qq|# Created by DBIx::Class::Schema::Loader\n|
2005 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
2007 $src_text .= $self->_make_pod_heading($src_class);
2009 $src_text .= qq|use strict;\nuse warnings;\n\n|;
2011 $src_text .= $self->_base_class_pod($result_base_class)
2012 unless $result_base_class eq 'DBIx::Class::Core';
2014 if ($self->use_moose) {
2015 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse $autoclean;|;
2017 # these options 'use base' which is compile time
2018 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
2019 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
2022 $src_text .= qq|\nextends '$result_base_class';\n|;
2026 $src_text .= qq|use base '$result_base_class';\n|;
2029 $self->_write_classfile($src_class, $src_text);
2032 # remove Result dir if downgrading from use_namespaces, and there are no
2034 if (my $result_ns = $self->_downgrading_to_load_classes
2035 || $self->_rewriting_result_namespace) {
2036 my $result_namespace = $self->_result_namespace(
2041 (my $result_dir = $result_namespace) =~ s{::}{/}g;
2042 $result_dir = $self->dump_directory . '/' . $result_dir;
2044 unless (my @files = glob "$result_dir/*") {
2049 warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
2053 my ($self, $version, $ts) = @_;
2054 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
2055 . (defined($version) ? q| v| . $version : '')
2056 . (defined($ts) ? q| @ | . $ts : '')
2057 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
2060 sub _write_classfile {
2061 my ($self, $class, $text, $is_schema) = @_;
2063 my $filename = $self->_get_dump_filename($class);
2064 $self->_ensure_dump_subdirs($class);
2066 if (-f $filename && $self->really_erase_my_files && !$self->dry_run) {
2067 warn "Deleting existing file '$filename' due to "
2068 . "'really_erase_my_files' setting\n" unless $self->quiet;
2072 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
2073 = $self->_parse_generated_file($filename);
2075 if (! $old_gen && -f $filename) {
2076 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
2077 . " it does not appear to have been generated by Loader"
2080 my $custom_content = $old_custom || '';
2082 # Use custom content from a renamed class, the class names in it are
2084 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
2085 my $old_filename = $self->_get_dump_filename($renamed_class);
2087 if (-f $old_filename) {
2088 $custom_content = ($self->_parse_generated_file ($old_filename))[4];
2090 unlink $old_filename unless $self->dry_run;
2094 $custom_content ||= $self->_default_custom_content($is_schema);
2096 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
2097 # If there is already custom content, which does not have the Moose content, add it.
2098 if ($self->use_moose) {
2100 my $non_moose_custom_content = do {
2101 local $self->{use_moose} = 0;
2102 $self->_default_custom_content;
2105 if ($custom_content eq $non_moose_custom_content) {
2106 $custom_content = $self->_default_custom_content($is_schema);
2108 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
2109 $custom_content .= $self->_default_custom_content($is_schema);
2112 elsif (defined $self->use_moose && $old_gen) {
2113 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'
2114 if $old_gen =~ /use \s+ MooseX?\b/x;
2117 $custom_content = $self->_rewrite_old_classnames($custom_content);
2120 for @{$self->{_dump_storage}->{$class} || []};
2122 if ($self->filter_generated_code) {
2123 my $filter = $self->filter_generated_code;
2125 if (ref $filter eq 'CODE') {
2127 ($is_schema ? 'schema' : 'result'),
2133 my ($fh, $temp_file) = tempfile();
2135 binmode $fh, ':encoding(UTF-8)';
2139 open my $out, qq{$filter < "$temp_file"|}
2140 or croak "Could not open pipe to $filter: $!";
2142 $text = decode('UTF-8', do { local $/; <$out> });
2144 $text =~ s/$CR?$LF/\n/g;
2148 my $exit_code = $? >> 8;
2151 or croak "Could not remove temporary file '$temp_file': $!";
2153 if ($exit_code != 0) {
2154 croak "filter '$filter' exited non-zero: $exit_code";
2157 if (not $text or not $text =~ /\bpackage\b/) {
2158 warn("$class skipped due to filter") if $self->debug;
2163 # Check and see if the dump is in fact different
2167 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
2168 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
2169 return unless $self->_upgrading_from && $is_schema;
2173 push @{$self->generated_classes}, $class;
2175 return if $self->dry_run;
2177 $text .= $self->_sig_comment(
2178 $self->omit_version ? undef : $self->version_to_dump,
2179 $self->omit_timestamp ? undef : POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
2182 open(my $fh, '>:encoding(UTF-8)', $filename)
2183 or croak "Cannot open '$filename' for writing: $!";
2185 # Write the top half and its MD5 sum
2186 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
2188 # Write out anything loaded via external partial class file in @INC
2190 for @{$self->{_ext_storage}->{$class} || []};
2192 # Write out any custom content the user has added
2193 print $fh $custom_content;
2196 or croak "Error closing '$filename': $!";
2199 sub _default_moose_custom_content {
2200 my ($self, $is_schema) = @_;
2202 if (not $is_schema) {
2203 return qq|\n__PACKAGE__->meta->make_immutable;|;
2206 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
2209 sub _default_custom_content {
2210 my ($self, $is_schema) = @_;
2211 my $default = qq|\n\n# You can replace this text with custom|
2212 . qq| code or comments, and it will be preserved on regeneration|;
2213 if ($self->use_moose) {
2214 $default .= $self->_default_moose_custom_content($is_schema);
2216 $default .= qq|\n1;\n|;
2220 sub _parse_generated_file {
2221 my ($self, $fn) = @_;
2223 return unless -f $fn;
2225 open(my $fh, '<:encoding(UTF-8)', $fn)
2226 or croak "Cannot open '$fn' for reading: $!";
2229 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
2231 my ($md5, $ts, $ver, $gen);
2238 # Pull out the version and timestamp from the line above
2239 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader( v[\d.]+)?( @ [\d-]+ [\d:]+)?\r?\Z/m;
2240 $ver =~ s/^ v// if $ver;
2241 $ts =~ s/^ @ // if $ts;
2244 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"
2245 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
2254 my $custom = do { local $/; <$fh> }
2258 $custom =~ s/$CRLF|$LF/\n/g;
2262 return ($gen, $md5, $ver, $ts, $custom);
2270 warn "$target: use $_;" if $self->debug;
2271 $self->_raw_stmt($target, "use $_;");
2279 my $blist = join(q{ }, @_);
2281 return unless $blist;
2283 warn "$target: use base qw/$blist/;" if $self->debug;
2284 $self->_raw_stmt($target, "use base qw/$blist/;");
2291 my $rlist = join(q{, }, map { qq{'$_'} } @_);
2293 return unless $rlist;
2295 warn "$target: with $rlist;" if $self->debug;
2296 $self->_raw_stmt($target, "\nwith $rlist;");
2299 sub _result_namespace {
2300 my ($self, $schema_class, $ns) = @_;
2301 my @result_namespace;
2303 $ns = $ns->[0] if ref $ns;
2305 if ($ns =~ /^\+(.*)/) {
2306 # Fully qualified namespace
2307 @result_namespace = ($1)
2310 # Relative namespace
2311 @result_namespace = ($schema_class, $ns);
2314 return wantarray ? @result_namespace : join '::', @result_namespace;
2317 # Create class with applicable bases, setup monikers, etc
2318 sub _make_src_class {
2319 my ($self, $table) = @_;
2321 my $schema = $self->schema;
2322 my $schema_class = $self->schema_class;
2324 my $table_moniker = $self->monikers->{$table->sql_name};
2325 my @result_namespace = ($schema_class);
2326 if ($self->use_namespaces) {
2327 my $result_namespace = $self->result_namespace || 'Result';
2328 @result_namespace = $self->_result_namespace(
2333 my $table_class = join(q{::}, @result_namespace, $table_moniker);
2335 if ((my $upgrading_v = $self->_upgrading_from)
2336 || $self->_rewriting) {
2337 local $self->naming->{monikers} = $upgrading_v
2340 my @result_namespace = @result_namespace;
2341 if ($self->_upgrading_from_load_classes) {
2342 @result_namespace = ($schema_class);
2344 elsif (my $ns = $self->_downgrading_to_load_classes) {
2345 @result_namespace = $self->_result_namespace(
2350 elsif ($ns = $self->_rewriting_result_namespace) {
2351 @result_namespace = $self->_result_namespace(
2357 my $old_table_moniker = do {
2358 local $self->naming->{monikers} = $upgrading_v;
2359 $self->_table2moniker($table);
2362 my $old_class = join(q{::}, @result_namespace, $old_table_moniker);
2364 $self->_upgrading_classes->{$table_class} = $old_class
2365 unless $table_class eq $old_class;
2368 $self->classes->{$table->sql_name} = $table_class;
2369 $self->moniker_to_table->{$table_moniker} = $table;
2370 $self->class_to_table->{$table_class} = $table;
2372 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
2374 $self->_use ($table_class, @{$self->additional_classes});
2376 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
2378 $self->_inject($table_class, @{$self->left_base_classes});
2380 my @components = @{ $self->components || [] };
2382 push @components, @{ $self->result_components_map->{$table_moniker} }
2383 if exists $self->result_components_map->{$table_moniker};
2385 my @fq_components = @components;
2386 foreach my $component (@fq_components) {
2387 if ($component !~ s/^\+//) {
2388 $component = "DBIx::Class::$component";
2392 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
2394 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
2396 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
2398 $self->_inject($table_class, @{$self->additional_base_classes});
2401 sub _is_result_class_method {
2402 my ($self, $name, $table) = @_;
2404 my $table_moniker = $table ? $self->monikers->{$table->sql_name} : '';
2406 $self->_result_class_methods({})
2407 if not defined $self->_result_class_methods;
2409 if (not exists $self->_result_class_methods->{$table_moniker}) {
2410 my (@methods, %methods);
2411 my $base = $self->result_base_class || 'DBIx::Class::Core';
2413 my @components = @{ $self->components || [] };
2415 push @components, @{ $self->result_components_map->{$table_moniker} }
2416 if exists $self->result_components_map->{$table_moniker};
2418 for my $c (@components) {
2419 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
2422 my @roles = @{ $self->result_roles || [] };
2424 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2425 if exists $self->result_roles_map->{$table_moniker};
2427 for my $class ($base, @components,
2428 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
2429 $self->ensure_class_loaded($class);
2431 push @methods, @{ Class::Inspector->methods($class) || [] };
2434 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
2436 @methods{@methods} = ();
2438 $self->_result_class_methods->{$table_moniker} = \%methods;
2440 my $result_methods = $self->_result_class_methods->{$table_moniker};
2442 return exists $result_methods->{$name};
2445 sub _resolve_col_accessor_collisions {
2446 my ($self, $table, $col_info) = @_;
2448 while (my ($col, $info) = each %$col_info) {
2449 my $accessor = $info->{accessor} || $col;
2451 next if $accessor eq 'id'; # special case (very common column)
2453 if ($self->_is_result_class_method($accessor, $table)) {
2456 if (my $map = $self->col_collision_map) {
2457 for my $re (keys %$map) {
2458 if (my @matches = $col =~ /$re/) {
2459 $info->{accessor} = sprintf $map->{$re}, @matches;
2467 Column '$col' in table '$table' collides with an inherited method.
2468 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
2470 $info->{accessor} = undef;
2476 # use the same logic to run moniker_map, col_accessor_map
2478 my ( $self, $map, $default_code, $ident, @extra ) = @_;
2480 my $default_ident = $default_code->( $ident, @extra );
2482 if( $map && ref $map eq 'HASH' ) {
2483 if (my @parts = try{ @{ $ident } }) {
2484 my $part_map = $map;
2486 my $part = shift @parts;
2487 last unless exists $part_map->{ $part };
2488 if ( !ref $part_map->{ $part } && !@parts ) {
2489 $new_ident = $part_map->{ $part };
2492 elsif ( ref $part_map->{ $part } eq 'HASH' ) {
2493 $part_map = $part_map->{ $part };
2497 if( !$new_ident && !ref $map->{ $ident } ) {
2498 $new_ident = $map->{ $ident };
2501 elsif( $map && ref $map eq 'CODE' ) {
2504 croak "reentered map must be a hashref"
2505 unless 'HASH' eq ref($cb_map);
2506 return $self->_run_user_map($cb_map, $default_code, $ident, @extra);
2508 $new_ident = $map->( $ident, $default_ident, @extra, $cb );
2511 $new_ident ||= $default_ident;
2516 sub _default_column_accessor_name {
2517 my ( $self, $column_name ) = @_;
2519 my $preserve = ($self->naming->{column_accessors}||'') eq 'preserve';
2521 my $v = $self->_get_naming_v('column_accessors');
2523 my $accessor_name = $preserve ?
2524 $self->_to_identifier('column_accessors', $column_name) # assume CamelCase
2526 $self->_to_identifier('column_accessors', $column_name, '_');
2528 $accessor_name =~ s/\W+/_/g; # only if naming < v8, otherwise to_identifier
2532 return $accessor_name;
2534 elsif ($v < 7 || (not $self->preserve_case)) {
2535 # older naming just lc'd the col accessor and that's all.
2536 return lc $accessor_name;
2539 return join '_', map lc, split_name $column_name, $v;
2542 sub _make_column_accessor_name {
2543 my ($self, $column_name, $column_context_info ) = @_;
2545 my $accessor = $self->_run_user_map(
2546 $self->col_accessor_map,
2547 sub { $self->_default_column_accessor_name( shift ) },
2549 $column_context_info,
2555 sub _table_is_view {
2556 #my ($self, $table) = @_;
2560 # Set up metadata (cols, pks, etc)
2561 sub _setup_src_meta {
2562 my ($self, $table) = @_;
2564 my $schema = $self->schema;
2565 my $schema_class = $self->schema_class;
2567 my $table_class = $self->classes->{$table->sql_name};
2568 my $table_moniker = $self->monikers->{$table->sql_name};
2570 $self->_dbic_stmt($table_class, 'table_class', 'DBIx::Class::ResultSource::View')
2571 if $self->_table_is_view($table);
2573 $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
2575 my $cols = $self->_table_columns($table);
2576 my $col_info = $self->__columns_info_for($table);
2578 ### generate all the column accessor names
2579 while (my ($col, $info) = each %$col_info) {
2580 # hashref of other info that could be used by
2581 # user-defined accessor map functions
2583 table_class => $table_class,
2584 table_moniker => $table_moniker,
2585 table_name => $table, # bugwards compatibility, RT#84050
2587 full_table_name => $table->dbic_name,
2588 schema_class => $schema_class,
2589 column_info => $info,
2592 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2595 $self->_resolve_col_accessor_collisions($table, $col_info);
2597 # prune any redundant accessor names
2598 while (my ($col, $info) = each %$col_info) {
2599 no warnings 'uninitialized';
2600 delete $info->{accessor} if $info->{accessor} eq $col;
2603 my $fks = $self->_table_fk_info($table);
2605 foreach my $fkdef (@$fks) {
2606 for my $col (@{ $fkdef->{local_columns} }) {
2607 $col_info->{$col}{is_foreign_key} = 1;
2611 my $pks = $self->_table_pk_info($table) || [];
2613 my %uniq_tag; # used to eliminate duplicate uniqs
2615 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2617 my $uniqs = $self->_table_uniq_info($table) || [];
2620 foreach my $uniq (@$uniqs) {
2621 my ($name, $cols) = @$uniq;
2622 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2623 push @uniqs, [$name, $cols];
2626 my @non_nullable_uniqs = grep {
2627 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2630 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2631 my @by_colnum = sort { $b->[0] <=> $a->[0] }
2632 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2634 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2635 my @keys = map $_->[1], @by_colnum;
2639 # remove the uniq from list
2640 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2646 foreach my $pkcol (@$pks) {
2647 $col_info->{$pkcol}{is_nullable} = 0;
2653 map { $_, ($col_info->{$_}||{}) } @$cols
2656 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2659 # Sort unique constraints by constraint name for repeatable results (rels
2660 # are sorted as well elsewhere.)
2661 @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs;
2663 foreach my $uniq (@uniqs) {
2664 my ($name, $cols) = @$uniq;
2665 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2669 sub __columns_info_for {
2670 my ($self, $table) = @_;
2672 my $result = $self->_columns_info_for($table);
2674 while (my ($col, $info) = each %$result) {
2675 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
2676 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2678 $result->{$col} = $info;
2686 Returns a sorted list of loaded tables, using the original database table
2694 return values %{$self->_tables};
2698 my ($self, $naming_key) = @_;
2702 if (($self->naming->{$naming_key}||'') =~ /^v(\d+)\z/) {
2706 ($v) = $CURRENT_V =~ /^v(\d+)\z/;
2712 sub _to_identifier {
2713 my ($self, $naming_key, $name, $sep_char, $force) = @_;
2715 my $v = $self->_get_naming_v($naming_key);
2717 my $to_identifier = $self->naming->{force_ascii} ?
2718 \&String::ToIdentifier::EN::to_identifier
2719 : \&String::ToIdentifier::EN::Unicode::to_identifier;
2721 return $v >= 8 || $force ? $to_identifier->($name, $sep_char) : $name;
2724 # Make a moniker from a table
2725 sub _default_table2moniker {
2726 my ($self, $table) = @_;
2728 my $v = $self->_get_naming_v('monikers');
2730 my @moniker_parts = @{ $self->moniker_parts };
2731 my @name_parts = map $table->$_, @moniker_parts;
2733 my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
2737 foreach my $i (0 .. $#name_parts) {
2738 my $part = $name_parts[$i];
2740 my $moniker_part = $self->_run_user_map(
2741 $self->moniker_part_map->{$moniker_parts[$i]},
2743 $part, $moniker_parts[$i],
2745 if (length $moniker_part) {
2746 push @all_parts, $moniker_part;
2750 if ($i != $name_idx || $v >= 8) {
2751 $part = $self->_to_identifier('monikers', $part, '_', 1);
2754 if ($i == $name_idx && $v == 5) {
2755 $part = Lingua::EN::Inflect::Number::to_S($part);
2758 my @part_parts = map lc, $v > 6 ?
2759 # use v8 semantics for all moniker parts except name
2760 ($i == $name_idx ? split_name $part, $v : split_name $part)
2761 : split /[\W_]+/, $part;
2763 if ($i == $name_idx && $v >= 6) {
2764 my $as_phrase = join ' ', @part_parts;
2766 my $inflected = ($self->naming->{monikers}||'') eq 'plural' ?
2767 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2769 ($self->naming->{monikers}||'') eq 'preserve' ?
2772 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2774 @part_parts = split /\s+/, $inflected;
2777 push @all_parts, join '', map ucfirst, @part_parts;
2780 return join $self->moniker_part_separator, @all_parts;
2783 sub _table2moniker {
2784 my ( $self, $table ) = @_;
2786 $self->_run_user_map(
2788 sub { $self->_default_table2moniker( shift ) },
2793 sub _load_relationships {
2794 my ($self, $tables) = @_;
2798 foreach my $table (@$tables) {
2799 my $local_moniker = $self->monikers->{$table->sql_name};
2801 my $tbl_fk_info = $self->_table_fk_info($table);
2803 foreach my $fkdef (@$tbl_fk_info) {
2804 $fkdef->{local_table} = $table;
2805 $fkdef->{local_moniker} = $local_moniker;
2806 $fkdef->{remote_source} =
2807 $self->monikers->{$fkdef->{remote_table}->sql_name};
2809 my $tbl_uniq_info = $self->_table_uniq_info($table);
2811 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2814 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2816 foreach my $src_class (sort keys %$rel_stmts) {
2818 my @src_stmts = map $_->[2],
2824 ($_->{method} eq 'many_to_many' ? 1 : 0),
2827 ], @{ $rel_stmts->{$src_class} };
2829 foreach my $stmt (@src_stmts) {
2830 $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2836 my ($self, $table) = @_;
2838 my $table_moniker = $self->monikers->{$table->sql_name};
2839 my $table_class = $self->classes->{$table->sql_name};
2841 my @roles = @{ $self->result_roles || [] };
2842 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2843 if exists $self->result_roles_map->{$table_moniker};
2846 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2848 $self->_with($table_class, @roles);
2852 # Overload these in driver class:
2854 # Returns an arrayref of column names
2855 sub _table_columns { croak "ABSTRACT METHOD" }
2857 # Returns arrayref of pk col names
2858 sub _table_pk_info { croak "ABSTRACT METHOD" }
2860 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2861 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2863 # Returns an arrayref of foreign key constraints, each
2864 # being a hashref with 3 keys:
2865 # local_columns (arrayref), remote_columns (arrayref), remote_table
2866 sub _table_fk_info { croak "ABSTRACT METHOD" }
2868 # Returns an array of lower case table names
2869 sub _tables_list { croak "ABSTRACT METHOD" }
2871 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2877 # generate the pod for this statement, storing it with $self->_pod
2878 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2880 my $args = dump(@_);
2881 $args = '(' . $args . ')' if @_ < 2;
2882 my $stmt = $method . $args . q{;};
2884 warn qq|$class\->$stmt\n| if $self->debug;
2885 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2889 sub _make_pod_heading {
2890 my ($self, $class) = @_;
2892 return '' if not $self->generate_pod;
2894 my $table = $self->class_to_table->{$class};
2897 my $pcm = $self->pod_comment_mode;
2898 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2899 $comment = $self->__table_comment($table);
2900 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2901 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2902 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2904 $pod .= "=head1 NAME\n\n";
2906 my $table_descr = $class;
2907 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2909 $pod .= "$table_descr\n\n";
2911 if ($comment and $comment_in_desc) {
2912 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2919 # generates the accompanying pod for a DBIC class method statement,
2920 # storing it with $self->_pod
2926 if ($method eq 'table') {
2928 $table = $$table if ref $table eq 'SCALAR';
2929 $self->_pod($class, "=head1 TABLE: C<$table>");
2930 $self->_pod_cut($class);
2932 elsif ( $method eq 'add_columns' ) {
2933 $self->_pod( $class, "=head1 ACCESSORS" );
2934 my $col_counter = 0;
2936 while( my ($name,$attrs) = splice @cols,0,2 ) {
2938 $self->_pod( $class, '=head2 ' . $name );
2939 $self->_pod( $class,
2941 my $s = $attrs->{$_};
2942 $s = !defined $s ? 'undef' :
2943 length($s) == 0 ? '(empty string)' :
2944 ref($s) eq 'SCALAR' ? $$s :
2945 ref($s) ? dumper_squashed $s :
2946 looks_like_number($s) ? $s : qq{'$s'};
2949 } sort keys %$attrs,
2951 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2952 $self->_pod( $class, $comment );
2955 $self->_pod_cut( $class );
2956 } elsif ( $method =~ /^(?:belongs_to|has_many|might_have)\z/ ) {
2957 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2958 my ( $accessor, $rel_class ) = @_;
2959 $self->_pod( $class, "=head2 $accessor" );
2960 $self->_pod( $class, 'Type: ' . $method );
2961 $self->_pod( $class, "Related object: L<$rel_class>" );
2962 $self->_pod_cut( $class );
2963 $self->{_relations_started} { $class } = 1;
2964 } elsif ( $method eq 'many_to_many' ) {
2965 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2966 my ( $accessor, $rel1, $rel2 ) = @_;
2967 $self->_pod( $class, "=head2 $accessor" );
2968 $self->_pod( $class, 'Type: many_to_many' );
2969 $self->_pod( $class, "Composing rels: L</$rel1> -> $rel2" );
2970 $self->_pod_cut( $class );
2971 $self->{_relations_started} { $class } = 1;
2973 elsif ($method eq 'add_unique_constraint') {
2974 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2975 unless $self->{_uniqs_started}{$class};
2977 my ($name, $cols) = @_;
2979 $self->_pod($class, "=head2 C<$name>");
2980 $self->_pod($class, '=over 4');
2982 foreach my $col (@$cols) {
2983 $self->_pod($class, "=item \* L</$col>");
2986 $self->_pod($class, '=back');
2987 $self->_pod_cut($class);
2989 $self->{_uniqs_started}{$class} = 1;
2991 elsif ($method eq 'set_primary_key') {
2992 $self->_pod($class, "=head1 PRIMARY KEY");
2993 $self->_pod($class, '=over 4');
2995 foreach my $col (@_) {
2996 $self->_pod($class, "=item \* L</$col>");
2999 $self->_pod($class, '=back');
3000 $self->_pod_cut($class);
3004 sub _pod_class_list {
3005 my ($self, $class, $title, @classes) = @_;
3007 return unless @classes && $self->generate_pod;
3009 $self->_pod($class, "=head1 $title");
3010 $self->_pod($class, '=over 4');
3012 foreach my $link (@classes) {
3013 $self->_pod($class, "=item * L<$link>");
3016 $self->_pod($class, '=back');
3017 $self->_pod_cut($class);
3020 sub _base_class_pod {
3021 my ($self, $base_class) = @_;
3023 return '' unless $self->generate_pod;
3025 return "\n=head1 BASE CLASS: L<$base_class>\n\n=cut\n\n";
3028 sub _filter_comment {
3029 my ($self, $txt) = @_;
3031 $txt = '' if not defined $txt;
3033 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
3038 sub __table_comment {
3041 if (my $code = $self->can('_table_comment')) {
3042 return $self->_filter_comment($self->$code(@_));
3048 sub __column_comment {
3051 if (my $code = $self->can('_column_comment')) {
3052 return $self->_filter_comment($self->$code(@_));
3058 # Stores a POD documentation
3060 my ($self, $class, $stmt) = @_;
3061 $self->_raw_stmt( $class, "\n" . $stmt );
3065 my ($self, $class ) = @_;
3066 $self->_raw_stmt( $class, "\n=cut\n" );
3069 # Store a raw source line for a class (for dumping purposes)
3071 my ($self, $class, $stmt) = @_;
3072 push(@{$self->{_dump_storage}->{$class}}, $stmt);
3075 # Like above, but separately for the externally loaded stuff
3077 my ($self, $class, $stmt) = @_;
3078 push(@{$self->{_ext_storage}->{$class}}, $stmt);
3081 sub _custom_column_info {
3082 my ( $self, $table_name, $column_name, $column_info ) = @_;
3084 if (my $code = $self->custom_column_info) {
3085 return $code->($table_name, $column_name, $column_info) || {};
3090 sub _datetime_column_info {
3091 my ( $self, $table_name, $column_name, $column_info ) = @_;
3093 my $type = $column_info->{data_type} || '';
3094 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
3095 or ($type =~ /date|timestamp/i)) {
3096 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
3097 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
3103 my ($self, $name) = @_;
3105 return $self->preserve_case ? $name : lc($name);
3109 my ($self, $name) = @_;
3111 return $self->preserve_case ? $name : uc($name);
3115 my ($self, $table) = @_;
3118 my $schema = $self->schema;
3119 # in older DBIC it's a private method
3120 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
3121 $schema->$unregister(delete $self->monikers->{$table->sql_name});
3122 delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}};
3123 delete $self->_tables->{$table->sql_name};
3127 # remove the dump dir from @INC on destruction
3131 @INC = grep $_ ne $self->dump_directory, @INC;
3136 Returns a hashref of loaded table to moniker mappings. There will
3137 be two entries for each table, the original name and the "normalized"
3138 name, in the case that the two are different (such as databases
3139 that like uppercase table names, or preserve your original mixed-case
3140 definitions, or what-have-you).
3144 Returns a hashref of table to class mappings. In some cases it will
3145 contain multiple entries per table for the original and normalized table
3146 names, as above in L</monikers>.
3148 =head2 generated_classes
3150 Returns an arrayref of classes that were actually generated (i.e. not
3151 skipped because there were no changes).
3153 =head1 NON-ENGLISH DATABASES
3155 If you use the loader on a database with table and column names in a language
3156 other than English, you will want to turn off the English language specific
3159 To do so, use something like this in your loader options:
3161 naming => { monikers => 'v4' },
3162 inflect_singular => sub { "$_[0]_rel" },
3163 inflect_plural => sub { "$_[0]_rel" },
3165 =head1 COLUMN ACCESSOR COLLISIONS
3167 Occasionally you may have a column name that collides with a perl method, such
3168 as C<can>. In such cases, the default action is to set the C<accessor> of the
3169 column spec to C<undef>.
3171 You can then name the accessor yourself by placing code such as the following
3174 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
3176 Another option is to use the L</col_collision_map> option.
3178 =head1 RELATIONSHIP NAME COLLISIONS
3180 In very rare cases, you may get a collision between a generated relationship
3181 name and a method in your Result class, for example if you have a foreign key
3182 called C<belongs_to>.
3184 This is a problem because relationship names are also relationship accessor
3185 methods in L<DBIx::Class>.
3187 The default behavior is to append C<_rel> to the relationship name and print
3188 out a warning that refers to this text.
3190 You can also control the renaming with the L</rel_collision_map> option.
3194 L<DBIx::Class::Schema::Loader>, L<dbicdump>
3198 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
3202 This library is free software; you can redistribute it and/or modify it under
3203 the same terms as Perl itself.
3208 # vim:et sts=4 sw=4 tw=0: