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.07041';
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::EM::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) = @_;
1018 None of these methods are intended for direct invocation by regular
1019 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
1020 L<DBIx::Class::Schema::Loader>.
1024 # ensure that a piece of object data is a valid arrayref, creating
1025 # an empty one or encapsulating whatever's there.
1026 sub _ensure_arrayref {
1031 $self->{$_} = [ $self->{$_} ]
1032 unless ref $self->{$_} eq 'ARRAY';
1038 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
1039 by L<DBIx::Class::Schema::Loader>.
1044 my ( $class, %args ) = @_;
1046 if (exists $args{column_accessor_map}) {
1047 $args{col_accessor_map} = delete $args{column_accessor_map};
1050 my $self = { %args };
1052 # don't lose undef options
1053 for (values %$self) {
1054 $_ = 0 unless defined $_;
1057 bless $self => $class;
1059 if (my $config_file = $self->config_file) {
1060 my $config_opts = do $config_file;
1062 croak "Error reading config from $config_file: $@" if $@;
1064 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
1066 while (my ($k, $v) = each %$config_opts) {
1067 $self->{$k} = $v unless exists $self->{$k};
1071 if (defined $self->{result_component_map}) {
1072 if (defined $self->result_components_map) {
1073 croak "Specify only one of result_components_map or result_component_map";
1075 $self->result_components_map($self->{result_component_map})
1078 if (defined $self->{result_role_map}) {
1079 if (defined $self->result_roles_map) {
1080 croak "Specify only one of result_roles_map or result_role_map";
1082 $self->result_roles_map($self->{result_role_map})
1085 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
1086 if ((not defined $self->use_moose) || (not $self->use_moose))
1087 && ((defined $self->result_roles) || (defined $self->result_roles_map));
1089 $self->_ensure_arrayref(qw/schema_components
1091 additional_base_classes
1097 $self->_validate_class_args;
1099 croak "result_components_map must be a hash"
1100 if defined $self->result_components_map
1101 && ref $self->result_components_map ne 'HASH';
1103 if ($self->result_components_map) {
1104 my %rc_map = %{ $self->result_components_map };
1105 foreach my $moniker (keys %rc_map) {
1106 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
1108 $self->result_components_map(\%rc_map);
1111 $self->result_components_map({});
1113 $self->_validate_result_components_map;
1115 croak "result_roles_map must be a hash"
1116 if defined $self->result_roles_map
1117 && ref $self->result_roles_map ne 'HASH';
1119 if ($self->result_roles_map) {
1120 my %rr_map = %{ $self->result_roles_map };
1121 foreach my $moniker (keys %rr_map) {
1122 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
1124 $self->result_roles_map(\%rr_map);
1126 $self->result_roles_map({});
1128 $self->_validate_result_roles_map;
1130 if ($self->use_moose) {
1131 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
1132 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
1133 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
1137 $self->{_tables} = {};
1138 $self->{monikers} = {};
1139 $self->{moniker_to_table} = {};
1140 $self->{class_to_table} = {};
1141 $self->{classes} = {};
1142 $self->{_upgrading_classes} = {};
1143 $self->{generated_classes} = [];
1145 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
1146 $self->{schema} ||= $self->{schema_class};
1147 $self->{table_comments_table} ||= 'table_comments';
1148 $self->{column_comments_table} ||= 'column_comments';
1150 croak "dump_overwrite is deprecated. Please read the"
1151 . " DBIx::Class::Schema::Loader::Base documentation"
1152 if $self->{dump_overwrite};
1154 $self->{dynamic} = ! $self->{dump_directory};
1156 croak "dry_run can only be used with static schema generation"
1157 if $self->dynamic and $self->dry_run;
1159 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
1164 $self->{dump_directory} ||= $self->{temp_directory};
1166 $self->real_dump_directory($self->{dump_directory});
1168 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
1169 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
1171 if (not defined $self->naming) {
1172 $self->naming_set(0);
1175 $self->naming_set(1);
1178 if ((not ref $self->naming) && defined $self->naming) {
1179 my $naming_ver = $self->naming;
1181 relationships => $naming_ver,
1182 monikers => $naming_ver,
1183 column_accessors => $naming_ver,
1186 elsif (ref $self->naming eq 'HASH' && exists $self->naming->{ALL}) {
1187 my $val = delete $self->naming->{ALL};
1189 $self->naming->{$_} = $val
1190 foreach qw/relationships monikers column_accessors/;
1193 if ($self->naming) {
1194 foreach my $key (qw/relationships monikers column_accessors/) {
1195 $self->naming->{$key} = $CURRENT_V if ($self->naming->{$key}||'') eq 'current';
1198 $self->{naming} ||= {};
1200 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
1201 croak 'custom_column_info must be a CODE ref';
1204 $self->_check_back_compat;
1206 $self->use_namespaces(1) unless defined $self->use_namespaces;
1207 $self->generate_pod(1) unless defined $self->generate_pod;
1208 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
1209 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
1211 if (my $col_collision_map = $self->col_collision_map) {
1212 if (my $reftype = ref $col_collision_map) {
1213 if ($reftype ne 'HASH') {
1214 croak "Invalid type $reftype for option 'col_collision_map'";
1218 $self->col_collision_map({ '(.*)' => $col_collision_map });
1222 if (my $rel_collision_map = $self->rel_collision_map) {
1223 if (my $reftype = ref $rel_collision_map) {
1224 if ($reftype ne 'HASH') {
1225 croak "Invalid type $reftype for option 'rel_collision_map'";
1229 $self->rel_collision_map({ '(.*)' => $rel_collision_map });
1233 if (defined(my $rel_name_map = $self->rel_name_map)) {
1234 my $reftype = ref $rel_name_map;
1235 if ($reftype ne 'HASH' && $reftype ne 'CODE') {
1236 croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
1240 if (defined(my $filter = $self->filter_generated_code)) {
1241 my $reftype = ref $filter;
1242 if ($reftype && $reftype ne 'CODE') {
1243 croak "Invalid type $reftype for option 'filter_generated_code, must be a scalar or a CODE reference";
1247 if (defined $self->db_schema) {
1248 if (ref $self->db_schema eq 'ARRAY') {
1249 if (@{ $self->db_schema } > 1 && not defined $self->{qualify_objects}) {
1250 $self->{qualify_objects} = 1;
1252 elsif (@{ $self->db_schema } == 0) {
1253 $self->{db_schema} = undef;
1256 elsif (not ref $self->db_schema) {
1257 if ($self->db_schema eq '%' && not defined $self->{qualify_objects}) {
1258 $self->{qualify_objects} = 1;
1261 $self->{db_schema} = [ $self->db_schema ];
1265 if (not $self->moniker_parts) {
1266 $self->moniker_parts(['name']);
1269 if (not ref $self->moniker_parts) {
1270 $self->moniker_parts([ $self->moniker_parts ]);
1272 if (ref $self->moniker_parts ne 'ARRAY') {
1273 croak 'moniker_parts must be an arrayref';
1275 if ((firstidx { $_ eq 'name' } @{ $self->moniker_parts }) == -1) {
1276 croak "moniker_parts option *must* contain 'name'";
1280 if (not defined $self->moniker_part_separator) {
1281 $self->moniker_part_separator('');
1283 if (not defined $self->moniker_part_map) {
1284 $self->moniker_part_map({}),
1290 sub _check_back_compat {
1293 # dynamic schemas will always be in 0.04006 mode, unless overridden
1294 if ($self->dynamic) {
1295 # just in case, though no one is likely to dump a dynamic schema
1296 $self->schema_version_to_dump('0.04006');
1298 if (not $self->naming_set) {
1299 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1301 Dynamic schema detected, will run in 0.04006 mode.
1303 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1304 to disable this warning.
1306 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1311 $self->_upgrading_from('v4');
1314 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
1315 $self->use_namespaces(1);
1318 $self->naming->{relationships} ||= 'v4';
1319 $self->naming->{monikers} ||= 'v4';
1321 if ($self->use_namespaces) {
1322 $self->_upgrading_from_load_classes(1);
1325 $self->use_namespaces(0);
1331 # otherwise check if we need backcompat mode for a static schema
1332 my $filename = $self->get_dump_filename($self->schema_class);
1333 return unless -e $filename;
1335 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
1336 $self->_parse_generated_file($filename);
1338 return unless $old_ver;
1340 # determine if the existing schema was dumped with use_moose => 1
1341 if (! defined $self->use_moose) {
1342 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
1345 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
1347 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
1348 my $ds = eval $result_namespace;
1350 Could not eval expression '$result_namespace' for result_namespace from
1353 $result_namespace = $ds || '';
1355 if ($load_classes && (not defined $self->use_namespaces)) {
1356 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1358 'load_classes;' static schema detected, turning off 'use_namespaces'.
1360 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
1361 variable to disable this warning.
1363 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1366 $self->use_namespaces(0);
1368 elsif ($load_classes && $self->use_namespaces) {
1369 $self->_upgrading_from_load_classes(1);
1371 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
1372 $self->_downgrading_to_load_classes(
1373 $result_namespace || 'Result'
1376 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
1377 if (not $self->result_namespace) {
1378 $self->result_namespace($result_namespace || 'Result');
1380 elsif ($result_namespace ne $self->result_namespace) {
1381 $self->_rewriting_result_namespace(
1382 $result_namespace || 'Result'
1387 # XXX when we go past .0 this will need fixing
1388 my ($v) = $old_ver =~ /([1-9])/;
1391 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
1393 if (not %{ $self->naming }) {
1394 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1396 Version $old_ver static schema detected, turning on backcompat mode.
1398 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1399 to disable this warning.
1401 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
1403 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
1404 from version 0.04006.
1407 $self->naming->{relationships} ||= $v;
1408 $self->naming->{monikers} ||= $v;
1409 $self->naming->{column_accessors} ||= $v;
1411 $self->schema_version_to_dump($old_ver);
1414 $self->_upgrading_from($v);
1418 sub _validate_class_args {
1421 foreach my $k (@CLASS_ARGS) {
1422 next unless $self->$k;
1424 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
1425 $self->_validate_classes($k, \@classes);
1429 sub _validate_result_components_map {
1432 foreach my $classes (values %{ $self->result_components_map }) {
1433 $self->_validate_classes('result_components_map', $classes);
1437 sub _validate_result_roles_map {
1440 foreach my $classes (values %{ $self->result_roles_map }) {
1441 $self->_validate_classes('result_roles_map', $classes);
1445 sub _validate_classes {
1448 my $classes = shift;
1450 # make a copy to not destroy original
1451 my @classes = @$classes;
1453 foreach my $c (@classes) {
1454 # components default to being under the DBIx::Class namespace unless they
1455 # are preceded with a '+'
1456 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1457 $c = 'DBIx::Class::' . $c;
1460 # 1 == installed, 0 == not installed, undef == invalid classname
1461 my $installed = Class::Inspector->installed($c);
1462 if ( defined($installed) ) {
1463 if ( $installed == 0 ) {
1464 croak qq/$c, as specified in the loader option "$key", is not installed/;
1467 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1473 sub _find_file_in_inc {
1474 my ($self, $file) = @_;
1476 foreach my $prefix (@INC) {
1477 my $fullpath = File::Spec->catfile($prefix, $file);
1478 # abs_path pure-perl fallback warns for non-existent files
1479 local $SIG{__WARN__} = sigwarn_silencer(qr/^stat\(.*\Q$file\E\)/);
1480 return $fullpath if -f $fullpath
1481 # abs_path throws on Windows for nonexistent files
1482 and (try { Cwd::abs_path($fullpath) }) ne
1483 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1489 sub _find_class_in_inc {
1490 my ($self, $class) = @_;
1492 return $self->_find_file_in_inc(class_path($class));
1498 return $self->_upgrading_from
1499 || $self->_upgrading_from_load_classes
1500 || $self->_downgrading_to_load_classes
1501 || $self->_rewriting_result_namespace
1505 sub _rewrite_old_classnames {
1506 my ($self, $code) = @_;
1508 return $code unless $self->_rewriting;
1510 my %old_classes = reverse %{ $self->_upgrading_classes };
1512 my $re = join '|', keys %old_classes;
1513 $re = qr/\b($re)\b/;
1515 $code =~ s/$re/$old_classes{$1} || $1/eg;
1520 sub _load_external {
1521 my ($self, $class) = @_;
1523 return if $self->{skip_load_external};
1525 # so that we don't load our own classes, under any circumstances
1526 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1528 my $real_inc_path = $self->_find_class_in_inc($class);
1530 my $old_class = $self->_upgrading_classes->{$class}
1531 if $self->_rewriting;
1533 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1534 if $old_class && $old_class ne $class;
1536 return unless $real_inc_path || $old_real_inc_path;
1538 if ($real_inc_path) {
1539 # If we make it to here, we loaded an external definition
1540 warn qq/# Loaded external class definition for '$class'\n/
1543 my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path);
1545 if ($self->dynamic) { # load the class too
1546 eval_package_without_redefine_warnings($class, $code);
1549 $self->_ext_stmt($class,
1550 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1551 .qq|# They are now part of the custom portion of this file\n|
1552 .qq|# for you to hand-edit. If you do not either delete\n|
1553 .qq|# this section or remove that file from \@INC, this section\n|
1554 .qq|# will be repeated redundantly when you re-create this\n|
1555 .qq|# file again via Loader! See skip_load_external to disable\n|
1556 .qq|# this feature.\n|
1559 $self->_ext_stmt($class, $code);
1560 $self->_ext_stmt($class,
1561 qq|# End of lines loaded from '$real_inc_path' |
1565 if ($old_real_inc_path) {
1566 my $code = slurp_file $old_real_inc_path;
1568 $self->_ext_stmt($class, <<"EOF");
1570 # These lines were loaded from '$old_real_inc_path',
1571 # based on the Result class name that would have been created by an older
1572 # version of the Loader. For a static schema, this happens only once during
1573 # upgrade. See skip_load_external to disable this feature.
1576 $code = $self->_rewrite_old_classnames($code);
1578 if ($self->dynamic) {
1581 Detected external content in '$old_real_inc_path', a class name that would have
1582 been used by an older version of the Loader.
1584 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1585 new name of the Result.
1587 eval_package_without_redefine_warnings($class, $code);
1591 $self->_ext_stmt($class, $code);
1592 $self->_ext_stmt($class,
1593 qq|# End of lines loaded from '$old_real_inc_path' |
1600 Does the actual schema-construction work.
1607 $self->_load_tables(
1608 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1616 Rescan the database for changes. Returns a list of the newly added table
1619 The schema argument should be the schema class or object to be affected. It
1620 should probably be derived from the original schema_class used during L</load>.
1625 my ($self, $schema) = @_;
1627 $self->{schema} = $schema;
1628 $self->_relbuilder->{schema} = $schema;
1631 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1633 foreach my $table (@current) {
1634 if(!exists $self->_tables->{$table->sql_name}) {
1635 push(@created, $table);
1640 @current{map $_->sql_name, @current} = ();
1641 foreach my $table (values %{ $self->_tables }) {
1642 if (not exists $current{$table->sql_name}) {
1643 $self->_remove_table($table);
1647 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1649 my $loaded = $self->_load_tables(@current);
1651 foreach my $table (@created) {
1652 $self->monikers->{$table->sql_name} = $self->_table2moniker($table);
1655 return map { $self->monikers->{$_->sql_name} } @created;
1661 return if $self->{skip_relationships};
1663 return $self->{relbuilder} ||= do {
1664 my $relbuilder_suff =
1671 ->{$self->naming->{relationships}||$CURRENT_V} || '';
1673 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1674 $self->ensure_class_loaded($relbuilder_class);
1675 $relbuilder_class->new($self);
1680 my ($self, @tables) = @_;
1682 # Save the new tables to the tables list and compute monikers
1684 $self->_tables->{$_->sql_name} = $_;
1685 $self->monikers->{$_->sql_name} = $self->_table2moniker($_);
1688 # check for moniker clashes
1689 my $inverse_moniker_idx;
1690 foreach my $imtable (values %{ $self->_tables }) {
1691 push @{ $inverse_moniker_idx->{$self->monikers->{$imtable->sql_name}} }, $imtable;
1695 foreach my $moniker (keys %$inverse_moniker_idx) {
1696 my $imtables = $inverse_moniker_idx->{$moniker};
1697 if (@$imtables > 1) {
1698 my $different_databases =
1699 $imtables->[0]->can('database') && (uniq map $_->database||'', @$imtables) > 1;
1701 my $different_schemas =
1702 (uniq map $_->schema||'', @$imtables) > 1;
1704 if ($different_databases || $different_schemas) {
1705 my ($use_schema, $use_database) = (1, 0);
1707 if ($different_databases) {
1710 # If any monikers are in the same database, we have to distinguish by
1711 # both schema and database.
1713 $db_counts{$_}++ for map $_->database, @$imtables;
1714 $use_schema = any { $_ > 1 } values %db_counts;
1717 foreach my $tbl (@$imtables) { delete $self->monikers->{$tbl->sql_name}; }
1719 my $moniker_parts = [ @{ $self->moniker_parts } ];
1721 my $have_schema = any { $_ eq 'schema' } @{ $self->moniker_parts };
1722 my $have_database = any { $_ eq 'database' } @{ $self->moniker_parts };
1724 unshift @$moniker_parts, 'schema' if $use_schema && !$have_schema;
1725 unshift @$moniker_parts, 'database' if $use_database && !$have_database;
1727 local $self->{moniker_parts} = $moniker_parts;
1731 foreach my $tbl (@$imtables) { $new_monikers{$tbl->sql_name} = $self->_table2moniker($tbl); }
1732 foreach my $name (map $_->sql_name, @$imtables) { $self->monikers->{$name} = $new_monikers{$name}; }
1734 # check if there are still clashes
1737 while (my ($t, $m) = each %new_monikers) {
1738 push @{ $by_moniker{$m} }, $t;
1741 foreach my $m (grep @{ $by_moniker{$_} } > 1, keys %by_moniker) {
1742 push @clashes, sprintf ("tried disambiguating by moniker_parts, but tables %s still reduced to the same source moniker '%s'",
1743 join (', ', @{ $by_moniker{$m} }),
1749 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1750 join (', ', map $_->sql_name, @$imtables),
1758 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1759 . 'Change the naming style, or supply an explicit moniker_map: '
1760 . join ('; ', @clashes)
1765 foreach my $tbl (@tables) { $self->_make_src_class($tbl); }
1766 foreach my $tbl (@tables) { $self->_setup_src_meta($tbl); }
1768 if(!$self->skip_relationships) {
1769 # The relationship loader needs a working schema
1770 local $self->{quiet} = 1;
1771 local $self->{dump_directory} = $self->{temp_directory};
1772 local $self->{generated_classes} = [];
1773 local $self->{dry_run} = 0;
1774 $self->_reload_classes(\@tables);
1775 $self->_load_relationships(\@tables);
1777 # Remove that temp dir from INC so it doesn't get reloaded
1778 @INC = grep $_ ne $self->dump_directory, @INC;
1781 foreach my $tbl (@tables) { $self->_load_roles($tbl); }
1782 foreach my $tbl (map { $self->classes->{$_->sql_name} } @tables) { $self->_load_external($tbl); }
1784 # Reload without unloading first to preserve any symbols from external
1786 $self->_reload_classes(\@tables, { unload => 0 });
1788 # Drop temporary cache
1789 delete $self->{_cache};
1794 sub _reload_classes {
1795 my ($self, $tables, $opts) = @_;
1797 my @tables = @$tables;
1799 my $unload = $opts->{unload};
1800 $unload = 1 unless defined $unload;
1802 # so that we don't repeat custom sections
1803 @INC = grep $_ ne $self->dump_directory, @INC;
1805 $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables);
1807 unshift @INC, $self->dump_directory;
1809 return if $self->dry_run;
1812 my %have_source = map { $_ => $self->schema->source($_) }
1813 $self->schema->sources;
1815 for my $table (@tables) {
1816 my $moniker = $self->monikers->{$table->sql_name};
1817 my $class = $self->classes->{$table->sql_name};
1820 no warnings 'redefine';
1821 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1824 if (my $mc = $self->_moose_metaclass($class)) {
1827 Class::Unload->unload($class) if $unload;
1828 my ($source, $resultset_class);
1830 ($source = $have_source{$moniker})
1831 && ($resultset_class = $source->resultset_class)
1832 && ($resultset_class ne 'DBIx::Class::ResultSet')
1834 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1835 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1838 Class::Unload->unload($resultset_class) if $unload;
1839 $self->_reload_class($resultset_class) if $has_file;
1841 $self->_reload_class($class);
1843 push @to_register, [$moniker, $class];
1846 Class::C3->reinitialize;
1847 for (@to_register) {
1848 $self->schema->register_class(@$_);
1852 sub _moose_metaclass {
1853 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1857 my $mc = try { Class::MOP::class_of($class) }
1860 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1863 # We use this instead of ensure_class_loaded when there are package symbols we
1866 my ($self, $class) = @_;
1868 delete $INC{ +class_path($class) };
1871 eval_package_without_redefine_warnings ($class, "require $class");
1874 my $source = slurp_file $self->_get_dump_filename($class);
1875 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1879 sub _get_dump_filename {
1880 my ($self, $class) = (@_);
1882 $class =~ s{::}{/}g;
1883 return $self->dump_directory . q{/} . $class . q{.pm};
1886 =head2 get_dump_filename
1890 Returns the full path to the file for a class that the class has been or will
1891 be dumped to. This is a file in a temp dir for a dynamic schema.
1895 sub get_dump_filename {
1896 my ($self, $class) = (@_);
1898 local $self->{dump_directory} = $self->real_dump_directory;
1900 return $self->_get_dump_filename($class);
1903 sub _ensure_dump_subdirs {
1904 my ($self, $class) = (@_);
1906 return if $self->dry_run;
1908 my @name_parts = split(/::/, $class);
1909 pop @name_parts; # we don't care about the very last element,
1910 # which is a filename
1912 my $dir = $self->dump_directory;
1915 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1917 last if !@name_parts;
1918 $dir = File::Spec->catdir($dir, shift @name_parts);
1923 my ($self, @classes) = @_;
1925 my $schema_class = $self->schema_class;
1926 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1928 my $target_dir = $self->dump_directory;
1929 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1930 unless $self->dynamic or $self->quiet;
1934 . qq|package $schema_class;\n\n|
1935 . qq|# Created by DBIx::Class::Schema::Loader\n|
1936 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1939 = $self->only_autoclean
1940 ? 'namespace::autoclean'
1941 : 'MooseX::MarkAsMethods autoclean => 1'
1944 if ($self->use_moose) {
1946 $schema_text.= qq|use Moose;\nuse $autoclean;\nextends '$schema_base_class';\n\n|;
1949 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1952 my @schema_components = @{ $self->schema_components || [] };
1954 if (@schema_components) {
1955 my $schema_components = dump @schema_components;
1956 $schema_components = "($schema_components)" if @schema_components == 1;
1958 $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1961 if ($self->use_namespaces) {
1962 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1963 my $namespace_options;
1965 my @attr = qw/resultset_namespace default_resultset_class/;
1967 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1969 for my $attr (@attr) {
1971 my $code = dumper_squashed $self->$attr;
1972 $namespace_options .= qq| $attr => $code,\n|
1975 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1976 $schema_text .= qq|;\n|;
1979 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1983 local $self->{version_to_dump} = $self->schema_version_to_dump;
1984 $self->_write_classfile($schema_class, $schema_text, 1);
1987 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1989 foreach my $src_class (@classes) {
1992 . qq|package $src_class;\n\n|
1993 . qq|# Created by DBIx::Class::Schema::Loader\n|
1994 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1996 $src_text .= $self->_make_pod_heading($src_class);
1998 $src_text .= qq|use strict;\nuse warnings;\n\n|;
2000 $src_text .= $self->_base_class_pod($result_base_class)
2001 unless $result_base_class eq 'DBIx::Class::Core';
2003 if ($self->use_moose) {
2004 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse $autoclean;|;
2006 # these options 'use base' which is compile time
2007 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
2008 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
2011 $src_text .= qq|\nextends '$result_base_class';\n|;
2015 $src_text .= qq|use base '$result_base_class';\n|;
2018 $self->_write_classfile($src_class, $src_text);
2021 # remove Result dir if downgrading from use_namespaces, and there are no
2023 if (my $result_ns = $self->_downgrading_to_load_classes
2024 || $self->_rewriting_result_namespace) {
2025 my $result_namespace = $self->_result_namespace(
2030 (my $result_dir = $result_namespace) =~ s{::}{/}g;
2031 $result_dir = $self->dump_directory . '/' . $result_dir;
2033 unless (my @files = glob "$result_dir/*") {
2038 warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
2042 my ($self, $version, $ts) = @_;
2043 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
2044 . (defined($version) ? q| v| . $version : '')
2045 . (defined($ts) ? q| @ | . $ts : '')
2046 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
2049 sub _write_classfile {
2050 my ($self, $class, $text, $is_schema) = @_;
2052 my $filename = $self->_get_dump_filename($class);
2053 $self->_ensure_dump_subdirs($class);
2055 if (-f $filename && $self->really_erase_my_files && !$self->dry_run) {
2056 warn "Deleting existing file '$filename' due to "
2057 . "'really_erase_my_files' setting\n" unless $self->quiet;
2061 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
2062 = $self->_parse_generated_file($filename);
2064 if (! $old_gen && -f $filename) {
2065 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
2066 . " it does not appear to have been generated by Loader"
2069 my $custom_content = $old_custom || '';
2071 # Use custom content from a renamed class, the class names in it are
2073 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
2074 my $old_filename = $self->_get_dump_filename($renamed_class);
2076 if (-f $old_filename) {
2077 $custom_content = ($self->_parse_generated_file ($old_filename))[4];
2079 unlink $old_filename unless $self->dry_run;
2083 $custom_content ||= $self->_default_custom_content($is_schema);
2085 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
2086 # If there is already custom content, which does not have the Moose content, add it.
2087 if ($self->use_moose) {
2089 my $non_moose_custom_content = do {
2090 local $self->{use_moose} = 0;
2091 $self->_default_custom_content;
2094 if ($custom_content eq $non_moose_custom_content) {
2095 $custom_content = $self->_default_custom_content($is_schema);
2097 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
2098 $custom_content .= $self->_default_custom_content($is_schema);
2101 elsif (defined $self->use_moose && $old_gen) {
2102 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'
2103 if $old_gen =~ /use \s+ MooseX?\b/x;
2106 $custom_content = $self->_rewrite_old_classnames($custom_content);
2109 for @{$self->{_dump_storage}->{$class} || []};
2111 if ($self->filter_generated_code) {
2112 my $filter = $self->filter_generated_code;
2114 if (ref $filter eq 'CODE') {
2116 ($is_schema ? 'schema' : 'result'),
2122 my ($fh, $temp_file) = tempfile();
2124 binmode $fh, ':encoding(UTF-8)';
2128 open my $out, qq{$filter < "$temp_file"|}
2129 or croak "Could not open pipe to $filter: $!";
2131 $text = decode('UTF-8', do { local $/; <$out> });
2133 $text =~ s/$CR?$LF/\n/g;
2137 my $exit_code = $? >> 8;
2140 or croak "Could not remove temporary file '$temp_file': $!";
2142 if ($exit_code != 0) {
2143 croak "filter '$filter' exited non-zero: $exit_code";
2146 if (not $text or not $text =~ /\bpackage\b/) {
2147 warn("$class skipped due to filter") if $self->debug;
2152 # Check and see if the dump is in fact different
2156 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
2157 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
2158 return unless $self->_upgrading_from && $is_schema;
2162 push @{$self->generated_classes}, $class;
2164 return if $self->dry_run;
2166 $text .= $self->_sig_comment(
2167 $self->omit_version ? undef : $self->version_to_dump,
2168 $self->omit_timestamp ? undef : POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
2171 open(my $fh, '>:encoding(UTF-8)', $filename)
2172 or croak "Cannot open '$filename' for writing: $!";
2174 # Write the top half and its MD5 sum
2175 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
2177 # Write out anything loaded via external partial class file in @INC
2179 for @{$self->{_ext_storage}->{$class} || []};
2181 # Write out any custom content the user has added
2182 print $fh $custom_content;
2185 or croak "Error closing '$filename': $!";
2188 sub _default_moose_custom_content {
2189 my ($self, $is_schema) = @_;
2191 if (not $is_schema) {
2192 return qq|\n__PACKAGE__->meta->make_immutable;|;
2195 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
2198 sub _default_custom_content {
2199 my ($self, $is_schema) = @_;
2200 my $default = qq|\n\n# You can replace this text with custom|
2201 . qq| code or comments, and it will be preserved on regeneration|;
2202 if ($self->use_moose) {
2203 $default .= $self->_default_moose_custom_content($is_schema);
2205 $default .= qq|\n1;\n|;
2209 sub _parse_generated_file {
2210 my ($self, $fn) = @_;
2212 return unless -f $fn;
2214 open(my $fh, '<:encoding(UTF-8)', $fn)
2215 or croak "Cannot open '$fn' for reading: $!";
2218 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
2220 my ($md5, $ts, $ver, $gen);
2227 # Pull out the version and timestamp from the line above
2228 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader( v[\d.]+)?( @ [\d-]+ [\d:]+)?\r?\Z/m;
2229 $ver =~ s/^ v// if $ver;
2230 $ts =~ s/^ @ // if $ts;
2233 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"
2234 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
2243 my $custom = do { local $/; <$fh> }
2247 $custom =~ s/$CRLF|$LF/\n/g;
2251 return ($gen, $md5, $ver, $ts, $custom);
2259 warn "$target: use $_;" if $self->debug;
2260 $self->_raw_stmt($target, "use $_;");
2268 my $blist = join(q{ }, @_);
2270 return unless $blist;
2272 warn "$target: use base qw/$blist/;" if $self->debug;
2273 $self->_raw_stmt($target, "use base qw/$blist/;");
2280 my $rlist = join(q{, }, map { qq{'$_'} } @_);
2282 return unless $rlist;
2284 warn "$target: with $rlist;" if $self->debug;
2285 $self->_raw_stmt($target, "\nwith $rlist;");
2288 sub _result_namespace {
2289 my ($self, $schema_class, $ns) = @_;
2290 my @result_namespace;
2292 $ns = $ns->[0] if ref $ns;
2294 if ($ns =~ /^\+(.*)/) {
2295 # Fully qualified namespace
2296 @result_namespace = ($1)
2299 # Relative namespace
2300 @result_namespace = ($schema_class, $ns);
2303 return wantarray ? @result_namespace : join '::', @result_namespace;
2306 # Create class with applicable bases, setup monikers, etc
2307 sub _make_src_class {
2308 my ($self, $table) = @_;
2310 my $schema = $self->schema;
2311 my $schema_class = $self->schema_class;
2313 my $table_moniker = $self->monikers->{$table->sql_name};
2314 my @result_namespace = ($schema_class);
2315 if ($self->use_namespaces) {
2316 my $result_namespace = $self->result_namespace || 'Result';
2317 @result_namespace = $self->_result_namespace(
2322 my $table_class = join(q{::}, @result_namespace, $table_moniker);
2324 if ((my $upgrading_v = $self->_upgrading_from)
2325 || $self->_rewriting) {
2326 local $self->naming->{monikers} = $upgrading_v
2329 my @result_namespace = @result_namespace;
2330 if ($self->_upgrading_from_load_classes) {
2331 @result_namespace = ($schema_class);
2333 elsif (my $ns = $self->_downgrading_to_load_classes) {
2334 @result_namespace = $self->_result_namespace(
2339 elsif ($ns = $self->_rewriting_result_namespace) {
2340 @result_namespace = $self->_result_namespace(
2346 my $old_table_moniker = do {
2347 local $self->naming->{monikers} = $upgrading_v;
2348 $self->_table2moniker($table);
2351 my $old_class = join(q{::}, @result_namespace, $old_table_moniker);
2353 $self->_upgrading_classes->{$table_class} = $old_class
2354 unless $table_class eq $old_class;
2357 $self->classes->{$table->sql_name} = $table_class;
2358 $self->moniker_to_table->{$table_moniker} = $table;
2359 $self->class_to_table->{$table_class} = $table;
2361 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
2363 $self->_use ($table_class, @{$self->additional_classes});
2365 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
2367 $self->_inject($table_class, @{$self->left_base_classes});
2369 my @components = @{ $self->components || [] };
2371 push @components, @{ $self->result_components_map->{$table_moniker} }
2372 if exists $self->result_components_map->{$table_moniker};
2374 my @fq_components = @components;
2375 foreach my $component (@fq_components) {
2376 if ($component !~ s/^\+//) {
2377 $component = "DBIx::Class::$component";
2381 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
2383 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
2385 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
2387 $self->_inject($table_class, @{$self->additional_base_classes});
2390 sub _is_result_class_method {
2391 my ($self, $name, $table) = @_;
2393 my $table_moniker = $table ? $self->monikers->{$table->sql_name} : '';
2395 $self->_result_class_methods({})
2396 if not defined $self->_result_class_methods;
2398 if (not exists $self->_result_class_methods->{$table_moniker}) {
2399 my (@methods, %methods);
2400 my $base = $self->result_base_class || 'DBIx::Class::Core';
2402 my @components = @{ $self->components || [] };
2404 push @components, @{ $self->result_components_map->{$table_moniker} }
2405 if exists $self->result_components_map->{$table_moniker};
2407 for my $c (@components) {
2408 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
2411 my @roles = @{ $self->result_roles || [] };
2413 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2414 if exists $self->result_roles_map->{$table_moniker};
2416 for my $class ($base, @components,
2417 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
2418 $self->ensure_class_loaded($class);
2420 push @methods, @{ Class::Inspector->methods($class) || [] };
2423 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
2425 @methods{@methods} = ();
2427 $self->_result_class_methods->{$table_moniker} = \%methods;
2429 my $result_methods = $self->_result_class_methods->{$table_moniker};
2431 return exists $result_methods->{$name};
2434 sub _resolve_col_accessor_collisions {
2435 my ($self, $table, $col_info) = @_;
2437 while (my ($col, $info) = each %$col_info) {
2438 my $accessor = $info->{accessor} || $col;
2440 next if $accessor eq 'id'; # special case (very common column)
2442 if ($self->_is_result_class_method($accessor, $table)) {
2445 if (my $map = $self->col_collision_map) {
2446 for my $re (keys %$map) {
2447 if (my @matches = $col =~ /$re/) {
2448 $info->{accessor} = sprintf $map->{$re}, @matches;
2456 Column '$col' in table '$table' collides with an inherited method.
2457 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
2459 $info->{accessor} = undef;
2465 # use the same logic to run moniker_map, col_accessor_map
2467 my ( $self, $map, $default_code, $ident, @extra ) = @_;
2469 my $default_ident = $default_code->( $ident, @extra );
2471 if( $map && ref $map eq 'HASH' ) {
2472 if (my @parts = try{ @{ $ident } }) {
2473 my $part_map = $map;
2475 my $part = shift @parts;
2476 last unless exists $part_map->{ $part };
2477 if ( !ref $part_map->{ $part } && !@parts ) {
2478 $new_ident = $part_map->{ $part };
2481 elsif ( ref $part_map->{ $part } eq 'HASH' ) {
2482 $part_map = $part_map->{ $part };
2486 if( !$new_ident && !ref $map->{ $ident } ) {
2487 $new_ident = $map->{ $ident };
2490 elsif( $map && ref $map eq 'CODE' ) {
2493 croak "reentered map must be a hashref"
2494 unless 'HASH' eq ref($cb_map);
2495 return $self->_run_user_map($cb_map, $default_code, $ident, @extra);
2497 $new_ident = $map->( $ident, $default_ident, @extra, $cb );
2500 $new_ident ||= $default_ident;
2505 sub _default_column_accessor_name {
2506 my ( $self, $column_name ) = @_;
2508 my $preserve = ($self->naming->{column_accessors}||'') eq 'preserve';
2510 my $v = $self->_get_naming_v('column_accessors');
2512 my $accessor_name = $preserve ?
2513 $self->_to_identifier('column_accessors', $column_name) # assume CamelCase
2515 $self->_to_identifier('column_accessors', $column_name, '_');
2517 $accessor_name =~ s/\W+/_/g; # only if naming < v8, otherwise to_identifier
2521 return $accessor_name;
2523 elsif ($v < 7 || (not $self->preserve_case)) {
2524 # older naming just lc'd the col accessor and that's all.
2525 return lc $accessor_name;
2528 return join '_', map lc, split_name $column_name, $v;
2531 sub _make_column_accessor_name {
2532 my ($self, $column_name, $column_context_info ) = @_;
2534 my $accessor = $self->_run_user_map(
2535 $self->col_accessor_map,
2536 sub { $self->_default_column_accessor_name( shift ) },
2538 $column_context_info,
2544 sub _table_is_view {
2545 #my ($self, $table) = @_;
2549 # Set up metadata (cols, pks, etc)
2550 sub _setup_src_meta {
2551 my ($self, $table) = @_;
2553 my $schema = $self->schema;
2554 my $schema_class = $self->schema_class;
2556 my $table_class = $self->classes->{$table->sql_name};
2557 my $table_moniker = $self->monikers->{$table->sql_name};
2559 $self->_dbic_stmt($table_class, 'table_class', 'DBIx::Class::ResultSource::View')
2560 if $self->_table_is_view($table);
2562 $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
2564 my $cols = $self->_table_columns($table);
2565 my $col_info = $self->__columns_info_for($table);
2567 ### generate all the column accessor names
2568 while (my ($col, $info) = each %$col_info) {
2569 # hashref of other info that could be used by
2570 # user-defined accessor map functions
2572 table_class => $table_class,
2573 table_moniker => $table_moniker,
2574 table_name => $table, # bugwards compatibility, RT#84050
2576 full_table_name => $table->dbic_name,
2577 schema_class => $schema_class,
2578 column_info => $info,
2581 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2584 $self->_resolve_col_accessor_collisions($table, $col_info);
2586 # prune any redundant accessor names
2587 while (my ($col, $info) = each %$col_info) {
2588 no warnings 'uninitialized';
2589 delete $info->{accessor} if $info->{accessor} eq $col;
2592 my $fks = $self->_table_fk_info($table);
2594 foreach my $fkdef (@$fks) {
2595 for my $col (@{ $fkdef->{local_columns} }) {
2596 $col_info->{$col}{is_foreign_key} = 1;
2600 my $pks = $self->_table_pk_info($table) || [];
2602 my %uniq_tag; # used to eliminate duplicate uniqs
2604 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2606 my $uniqs = $self->_table_uniq_info($table) || [];
2609 foreach my $uniq (@$uniqs) {
2610 my ($name, $cols) = @$uniq;
2611 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2612 push @uniqs, [$name, $cols];
2615 my @non_nullable_uniqs = grep {
2616 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2619 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2620 my @by_colnum = sort { $b->[0] <=> $a->[0] }
2621 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2623 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2624 my @keys = map $_->[1], @by_colnum;
2628 # remove the uniq from list
2629 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2635 foreach my $pkcol (@$pks) {
2636 $col_info->{$pkcol}{is_nullable} = 0;
2642 map { $_, ($col_info->{$_}||{}) } @$cols
2645 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2648 # Sort unique constraints by constraint name for repeatable results (rels
2649 # are sorted as well elsewhere.)
2650 @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs;
2652 foreach my $uniq (@uniqs) {
2653 my ($name, $cols) = @$uniq;
2654 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2658 sub __columns_info_for {
2659 my ($self, $table) = @_;
2661 my $result = $self->_columns_info_for($table);
2663 while (my ($col, $info) = each %$result) {
2664 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
2665 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2667 $result->{$col} = $info;
2675 Returns a sorted list of loaded tables, using the original database table
2683 return values %{$self->_tables};
2687 my ($self, $naming_key) = @_;
2691 if (($self->naming->{$naming_key}||'') =~ /^v(\d+)\z/) {
2695 ($v) = $CURRENT_V =~ /^v(\d+)\z/;
2701 sub _to_identifier {
2702 my ($self, $naming_key, $name, $sep_char, $force) = @_;
2704 my $v = $self->_get_naming_v($naming_key);
2706 my $to_identifier = $self->naming->{force_ascii} ?
2707 \&String::ToIdentifier::EN::to_identifier
2708 : \&String::ToIdentifier::EN::Unicode::to_identifier;
2710 return $v >= 8 || $force ? $to_identifier->($name, $sep_char) : $name;
2713 # Make a moniker from a table
2714 sub _default_table2moniker {
2715 my ($self, $table) = @_;
2717 my $v = $self->_get_naming_v('monikers');
2719 my @moniker_parts = @{ $self->moniker_parts };
2720 my @name_parts = map $table->$_, @moniker_parts;
2722 my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
2726 foreach my $i (0 .. $#name_parts) {
2727 my $part = $name_parts[$i];
2729 my $moniker_part = $self->_run_user_map(
2730 $self->moniker_part_map->{$moniker_parts[$i]},
2732 $part, $moniker_parts[$i],
2734 if (length $moniker_part) {
2735 push @all_parts, $moniker_part;
2739 if ($i != $name_idx || $v >= 8) {
2740 $part = $self->_to_identifier('monikers', $part, '_', 1);
2743 if ($i == $name_idx && $v == 5) {
2744 $part = Lingua::EN::Inflect::Number::to_S($part);
2747 my @part_parts = map lc, $v > 6 ?
2748 # use v8 semantics for all moniker parts except name
2749 ($i == $name_idx ? split_name $part, $v : split_name $part)
2750 : split /[\W_]+/, $part;
2752 if ($i == $name_idx && $v >= 6) {
2753 my $as_phrase = join ' ', @part_parts;
2755 my $inflected = ($self->naming->{monikers}||'') eq 'plural' ?
2756 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2758 ($self->naming->{monikers}||'') eq 'preserve' ?
2761 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2763 @part_parts = split /\s+/, $inflected;
2766 push @all_parts, join '', map ucfirst, @part_parts;
2769 return join $self->moniker_part_separator, @all_parts;
2772 sub _table2moniker {
2773 my ( $self, $table ) = @_;
2775 $self->_run_user_map(
2777 sub { $self->_default_table2moniker( shift ) },
2782 sub _load_relationships {
2783 my ($self, $tables) = @_;
2787 foreach my $table (@$tables) {
2788 my $local_moniker = $self->monikers->{$table->sql_name};
2790 my $tbl_fk_info = $self->_table_fk_info($table);
2792 foreach my $fkdef (@$tbl_fk_info) {
2793 $fkdef->{local_table} = $table;
2794 $fkdef->{local_moniker} = $local_moniker;
2795 $fkdef->{remote_source} =
2796 $self->monikers->{$fkdef->{remote_table}->sql_name};
2798 my $tbl_uniq_info = $self->_table_uniq_info($table);
2800 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2803 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2805 foreach my $src_class (sort keys %$rel_stmts) {
2807 my @src_stmts = map $_->[2],
2813 ($_->{method} eq 'many_to_many' ? 1 : 0),
2816 ], @{ $rel_stmts->{$src_class} };
2818 foreach my $stmt (@src_stmts) {
2819 $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2825 my ($self, $table) = @_;
2827 my $table_moniker = $self->monikers->{$table->sql_name};
2828 my $table_class = $self->classes->{$table->sql_name};
2830 my @roles = @{ $self->result_roles || [] };
2831 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2832 if exists $self->result_roles_map->{$table_moniker};
2835 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2837 $self->_with($table_class, @roles);
2841 # Overload these in driver class:
2843 # Returns an arrayref of column names
2844 sub _table_columns { croak "ABSTRACT METHOD" }
2846 # Returns arrayref of pk col names
2847 sub _table_pk_info { croak "ABSTRACT METHOD" }
2849 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2850 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2852 # Returns an arrayref of foreign key constraints, each
2853 # being a hashref with 3 keys:
2854 # local_columns (arrayref), remote_columns (arrayref), remote_table
2855 sub _table_fk_info { croak "ABSTRACT METHOD" }
2857 # Returns an array of lower case table names
2858 sub _tables_list { croak "ABSTRACT METHOD" }
2860 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2866 # generate the pod for this statement, storing it with $self->_pod
2867 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2869 my $args = dump(@_);
2870 $args = '(' . $args . ')' if @_ < 2;
2871 my $stmt = $method . $args . q{;};
2873 warn qq|$class\->$stmt\n| if $self->debug;
2874 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2878 sub _make_pod_heading {
2879 my ($self, $class) = @_;
2881 return '' if not $self->generate_pod;
2883 my $table = $self->class_to_table->{$class};
2886 my $pcm = $self->pod_comment_mode;
2887 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2888 $comment = $self->__table_comment($table);
2889 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2890 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2891 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2893 $pod .= "=head1 NAME\n\n";
2895 my $table_descr = $class;
2896 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2898 $pod .= "$table_descr\n\n";
2900 if ($comment and $comment_in_desc) {
2901 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2908 # generates the accompanying pod for a DBIC class method statement,
2909 # storing it with $self->_pod
2915 if ($method eq 'table') {
2917 $table = $$table if ref $table eq 'SCALAR';
2918 $self->_pod($class, "=head1 TABLE: C<$table>");
2919 $self->_pod_cut($class);
2921 elsif ( $method eq 'add_columns' ) {
2922 $self->_pod( $class, "=head1 ACCESSORS" );
2923 my $col_counter = 0;
2925 while( my ($name,$attrs) = splice @cols,0,2 ) {
2927 $self->_pod( $class, '=head2 ' . $name );
2928 $self->_pod( $class,
2930 my $s = $attrs->{$_};
2931 $s = !defined $s ? 'undef' :
2932 length($s) == 0 ? '(empty string)' :
2933 ref($s) eq 'SCALAR' ? $$s :
2934 ref($s) ? dumper_squashed $s :
2935 looks_like_number($s) ? $s : qq{'$s'};
2938 } sort keys %$attrs,
2940 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2941 $self->_pod( $class, $comment );
2944 $self->_pod_cut( $class );
2945 } elsif ( $method =~ /^(?:belongs_to|has_many|might_have)\z/ ) {
2946 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2947 my ( $accessor, $rel_class ) = @_;
2948 $self->_pod( $class, "=head2 $accessor" );
2949 $self->_pod( $class, 'Type: ' . $method );
2950 $self->_pod( $class, "Related object: L<$rel_class>" );
2951 $self->_pod_cut( $class );
2952 $self->{_relations_started} { $class } = 1;
2953 } elsif ( $method eq 'many_to_many' ) {
2954 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2955 my ( $accessor, $rel1, $rel2 ) = @_;
2956 $self->_pod( $class, "=head2 $accessor" );
2957 $self->_pod( $class, 'Type: many_to_many' );
2958 $self->_pod( $class, "Composing rels: L</$rel1> -> $rel2" );
2959 $self->_pod_cut( $class );
2960 $self->{_relations_started} { $class } = 1;
2962 elsif ($method eq 'add_unique_constraint') {
2963 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2964 unless $self->{_uniqs_started}{$class};
2966 my ($name, $cols) = @_;
2968 $self->_pod($class, "=head2 C<$name>");
2969 $self->_pod($class, '=over 4');
2971 foreach my $col (@$cols) {
2972 $self->_pod($class, "=item \* L</$col>");
2975 $self->_pod($class, '=back');
2976 $self->_pod_cut($class);
2978 $self->{_uniqs_started}{$class} = 1;
2980 elsif ($method eq 'set_primary_key') {
2981 $self->_pod($class, "=head1 PRIMARY KEY");
2982 $self->_pod($class, '=over 4');
2984 foreach my $col (@_) {
2985 $self->_pod($class, "=item \* L</$col>");
2988 $self->_pod($class, '=back');
2989 $self->_pod_cut($class);
2993 sub _pod_class_list {
2994 my ($self, $class, $title, @classes) = @_;
2996 return unless @classes && $self->generate_pod;
2998 $self->_pod($class, "=head1 $title");
2999 $self->_pod($class, '=over 4');
3001 foreach my $link (@classes) {
3002 $self->_pod($class, "=item * L<$link>");
3005 $self->_pod($class, '=back');
3006 $self->_pod_cut($class);
3009 sub _base_class_pod {
3010 my ($self, $base_class) = @_;
3012 return '' unless $self->generate_pod;
3015 =head1 BASE CLASS: L<$base_class>
3022 sub _filter_comment {
3023 my ($self, $txt) = @_;
3025 $txt = '' if not defined $txt;
3027 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
3032 sub __table_comment {
3035 if (my $code = $self->can('_table_comment')) {
3036 return $self->_filter_comment($self->$code(@_));
3042 sub __column_comment {
3045 if (my $code = $self->can('_column_comment')) {
3046 return $self->_filter_comment($self->$code(@_));
3052 # Stores a POD documentation
3054 my ($self, $class, $stmt) = @_;
3055 $self->_raw_stmt( $class, "\n" . $stmt );
3059 my ($self, $class ) = @_;
3060 $self->_raw_stmt( $class, "\n=cut\n" );
3063 # Store a raw source line for a class (for dumping purposes)
3065 my ($self, $class, $stmt) = @_;
3066 push(@{$self->{_dump_storage}->{$class}}, $stmt);
3069 # Like above, but separately for the externally loaded stuff
3071 my ($self, $class, $stmt) = @_;
3072 push(@{$self->{_ext_storage}->{$class}}, $stmt);
3075 sub _custom_column_info {
3076 my ( $self, $table_name, $column_name, $column_info ) = @_;
3078 if (my $code = $self->custom_column_info) {
3079 return $code->($table_name, $column_name, $column_info) || {};
3084 sub _datetime_column_info {
3085 my ( $self, $table_name, $column_name, $column_info ) = @_;
3087 my $type = $column_info->{data_type} || '';
3088 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
3089 or ($type =~ /date|timestamp/i)) {
3090 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
3091 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
3097 my ($self, $name) = @_;
3099 return $self->preserve_case ? $name : lc($name);
3103 my ($self, $name) = @_;
3105 return $self->preserve_case ? $name : uc($name);
3109 my ($self, $table) = @_;
3112 my $schema = $self->schema;
3113 # in older DBIC it's a private method
3114 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
3115 $schema->$unregister(delete $self->monikers->{$table->sql_name});
3116 delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}};
3117 delete $self->_tables->{$table->sql_name};
3121 # remove the dump dir from @INC on destruction
3125 @INC = grep $_ ne $self->dump_directory, @INC;
3130 Returns a hashref of loaded table to moniker mappings. There will
3131 be two entries for each table, the original name and the "normalized"
3132 name, in the case that the two are different (such as databases
3133 that like uppercase table names, or preserve your original mixed-case
3134 definitions, or what-have-you).
3138 Returns a hashref of table to class mappings. In some cases it will
3139 contain multiple entries per table for the original and normalized table
3140 names, as above in L</monikers>.
3142 =head2 generated_classes
3144 Returns an arrayref of classes that were actually generated (i.e. not
3145 skipped because there were no changes).
3147 =head1 NON-ENGLISH DATABASES
3149 If you use the loader on a database with table and column names in a language
3150 other than English, you will want to turn off the English language specific
3153 To do so, use something like this in your loader options:
3155 naming => { monikers => 'v4' },
3156 inflect_singular => sub { "$_[0]_rel" },
3157 inflect_plural => sub { "$_[0]_rel" },
3159 =head1 COLUMN ACCESSOR COLLISIONS
3161 Occasionally you may have a column name that collides with a perl method, such
3162 as C<can>. In such cases, the default action is to set the C<accessor> of the
3163 column spec to C<undef>.
3165 You can then name the accessor yourself by placing code such as the following
3168 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
3170 Another option is to use the L</col_collision_map> option.
3172 =head1 RELATIONSHIP NAME COLLISIONS
3174 In very rare cases, you may get a collision between a generated relationship
3175 name and a method in your Result class, for example if you have a foreign key
3176 called C<belongs_to>.
3178 This is a problem because relationship names are also relationship accessor
3179 methods in L<DBIx::Class>.
3181 The default behavior is to append C<_rel> to the relationship name and print
3182 out a warning that refers to this text.
3184 You can also control the renaming with the L</rel_collision_map> option.
3188 L<DBIx::Class::Schema::Loader>, L<dbicdump>
3192 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
3196 This library is free software; you can redistribute it and/or modify it under
3197 the same terms as Perl itself.
3202 # vim:et sts=4 sw=4 tw=0: