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.07039';
34 __PACKAGE__->mk_group_ro_accessors('simple', qw/
41 additional_base_classes
57 default_resultset_class
63 overwrite_modifications
88 __PACKAGE__->mk_group_accessors('simple', qw/
90 schema_version_to_dump
92 _upgrading_from_load_classes
93 _downgrading_to_load_classes
94 _rewriting_result_namespace
99 pod_comment_spillover_length
105 result_components_map
107 datetime_undef_if_invalid
108 _result_class_methods
110 filter_generated_code
114 moniker_part_separator
118 my $CURRENT_V = 'v7';
121 schema_components schema_base_class result_base_class
122 additional_base_classes left_base_classes additional_classes components
128 my $CRLF = "\x0d\x0a";
132 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
136 See L<DBIx::Class::Schema::Loader>.
140 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
141 classes, and implements the common functionality between them.
143 =head1 CONSTRUCTOR OPTIONS
145 These constructor options are the base options for
146 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
148 =head2 skip_relationships
150 Skip setting up relationships. The default is to attempt the loading
153 =head2 skip_load_external
155 Skip loading of other classes in @INC. The default is to merge all other classes
156 with the same name found in @INC into the schema file we are creating.
160 Static schemas (ones dumped to disk) will, by default, use the new-style
161 relationship names and singularized Results, unless you're overwriting an
162 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
163 which case the backward compatible RelBuilder will be activated, and the
164 appropriate monikerization used.
170 will disable the backward-compatible RelBuilder and use
171 the new-style relationship names along with singularized Results, even when
172 overwriting a dump made with an earlier version.
174 The option also takes a hashref:
177 relationships => 'v8',
179 column_accessors => 'v8',
185 naming => { ALL => 'v8', force_ascii => 1 }
193 Set L</relationships>, L</monikers> and L</column_accessors> to the specified
198 How to name relationship accessors.
202 How to name Result classes.
204 =item column_accessors
206 How to name column accessors in Result classes.
210 For L</v8> mode and later, uses L<String::ToIdentifier::EN> instead of
211 L<String::ToIdentifier::EM::Unicode> to force monikers and other identifiers to
222 Latest style, whatever that happens to be.
226 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
230 Monikers singularized as whole words, C<might_have> relationships for FKs on
231 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
233 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
238 All monikers and relationships are inflected using
239 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
240 from relationship names.
242 In general, there is very little difference between v5 and v6 schemas.
246 This mode is identical to C<v6> mode, except that monikerization of CamelCase
247 table names is also done better (but best in v8.)
249 CamelCase column names in case-preserving mode will also be handled better
250 for relationship name inflection (but best in v8.) See L</preserve_case>.
252 In this mode, CamelCase L</column_accessors> are normalized based on case
253 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
259 The default mode is L</v7>, to get L</v8> mode, you have to specify it in
260 L</naming> explicitly until C<0.08> comes out.
262 L</monikers> and L</column_accessors> are created using
263 L<String::ToIdentifier::EN::Unicode> or L<String::ToIdentifier::EN> if
264 L</force_ascii> is set; this is only significant for names with non-C<\w>
265 characters such as C<.>.
267 CamelCase identifiers with words in all caps, e.g. C<VLANValidID> are supported
268 correctly in this mode.
270 For relationships, belongs_to accessors are made from column names by stripping
271 postfixes other than C<_id> as well, for example just C<Id>, C<_?ref>, C<_?cd>,
272 C<_?code> and C<_?num>, case insensitively.
276 For L</monikers>, this option does not inflect the table names but makes
277 monikers based on the actual name. For L</column_accessors> this option does
278 not normalize CamelCase column names to lowercase column accessors, but makes
279 accessors that are the same names as the columns (with any non-\w chars
280 replaced with underscores.)
284 For L</monikers>, singularizes the names using the most current inflector. This
285 is the same as setting the option to L</current>.
289 For L</monikers>, pluralizes the names, using the most current inflector.
293 Dynamic schemas will always default to the 0.04XXX relationship names and won't
294 singularize Results for backward compatibility, to activate the new RelBuilder
295 and singularization put this in your C<Schema.pm> file:
297 __PACKAGE__->naming('current');
299 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
300 next major version upgrade:
302 __PACKAGE__->naming('v7');
306 If true, will not print the usual C<Dumping manual schema ... Schema dump
307 completed.> messages. Does not affect warnings (except for warnings related to
308 L</really_erase_my_files>.)
312 If true, don't actually write out the generated files. This can only be
313 used with static schema generation.
317 By default POD will be generated for columns and relationships, using database
318 metadata for the text if available and supported.
320 Comment metadata can be stored in two ways.
322 The first is that you can create two tables named C<table_comments> and
323 C<column_comments> respectively. These tables must exist in the same database
324 and schema as the tables they describe. They both need to have columns named
325 C<table_name> and C<comment_text>. The second one needs to have a column named
326 C<column_name>. Then data stored in these tables will be used as a source of
327 metadata about tables and comments.
329 (If you wish you can change the name of these tables with the parameters
330 L</table_comments_table> and L</column_comments_table>.)
332 As a fallback you can use built-in commenting mechanisms. Currently this is
333 only supported for PostgreSQL, Oracle and MySQL. To create comments in
334 PostgreSQL you add statements of the form C<COMMENT ON TABLE some_table IS
335 '...'>, the same syntax is used in Oracle. To create comments in MySQL you add
336 C<COMMENT '...'> to the end of the column or table definition. Note that MySQL
337 restricts the length of comments, and also does not handle complex Unicode
340 Set this to C<0> to turn off all POD generation.
342 =head2 pod_comment_mode
344 Controls where table comments appear in the generated POD. Smaller table
345 comments are appended to the C<NAME> section of the documentation, and larger
346 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
347 section to be generated with the comment always, only use C<NAME>, or choose
348 the length threshold at which the comment is forced into the description.
354 Use C<NAME> section only.
358 Force C<DESCRIPTION> always.
362 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
367 =head2 pod_comment_spillover_length
369 When pod_comment_mode is set to C<auto>, this is the length of the comment at
370 which it will be forced into a separate description section.
374 =head2 table_comments_table
376 The table to look for comments about tables in. By default C<table_comments>.
377 See L</generate_pod> for details.
379 This must not be a fully qualified name, the table will be looked for in the
380 same database and schema as the table whose comment is being retrieved.
382 =head2 column_comments_table
384 The table to look for comments about columns in. By default C<column_comments>.
385 See L</generate_pod> for details.
387 This must not be a fully qualified name, the table will be looked for in the
388 same database and schema as the table/column whose comment is being retrieved.
390 =head2 relationship_attrs
392 Hashref of attributes to pass to each generated relationship, listed by type.
393 Also supports relationship type 'all', containing options to pass to all
394 generated relationships. Attributes set for more specific relationship types
395 override those set in 'all', and any attributes specified by this option
396 override the introspected attributes of the foreign key if any.
400 relationship_attrs => {
401 has_many => { cascade_delete => 1, cascade_copy => 1 },
402 might_have => { cascade_delete => 1, cascade_copy => 1 },
405 use this to turn L<DBIx::Class> cascades to on on your
406 L<has_many|DBIx::Class::Relationship/has_many> and
407 L<might_have|DBIx::Class::Relationship/might_have> relationships, they default
410 Can also be a coderef, for more precise control, in which case the coderef gets
411 this hash of parameters (as a list:)
413 rel_name # the name of the relationship
414 rel_type # the type of the relationship: 'belongs_to', 'has_many' or 'might_have'
415 local_source # the DBIx::Class::ResultSource object for the source the rel is *from*
416 remote_source # the DBIx::Class::ResultSource object for the source the rel is *to*
417 local_table # a DBIx::Class::Schema::Loader::Table object for the table of the source the rel is from
418 local_cols # an arrayref of column names of columns used in the rel in the source it is from
419 remote_table # a DBIx::Class::Schema::Loader::Table object for the table of the source the rel is to
420 remote_cols # an arrayref of column names of columns used in the rel in the source it is to
421 attrs # the attributes that would be set
423 it should return the new hashref of attributes, or nothing for no changes.
427 relationship_attrs => sub {
430 say "the relationship name is: $p{rel_name}";
431 say "the relationship is a: $p{rel_type}";
432 say "the local class is: ", $p{local_source}->result_class;
433 say "the remote class is: ", $p{remote_source}->result_class;
434 say "the local table is: ", $p{local_table}->sql_name;
435 say "the rel columns in the local table are: ", (join ", ", @{$p{local_cols}});
436 say "the remote table is: ", $p{remote_table}->sql_name;
437 say "the rel columns in the remote table are: ", (join ", ", @{$p{remote_cols}});
439 if ($p{local_table} eq 'dogs' && @{$p{local_cols}} == 1 && $p{local_cols}[0] eq 'name') {
440 $p{attrs}{could_be_snoopy} = 1;
446 These are the default attributes:
457 on_delete => 'CASCADE',
458 on_update => 'CASCADE',
462 For L<belongs_to|DBIx::Class::Relationship/belongs_to> relationships, these
463 defaults are overridden by the attributes introspected from the foreign key in
464 the database, if this information is available (and the driver is capable of
467 This information overrides the defaults mentioned above, and is then itself
468 overridden by the user's L</relationship_attrs> for C<belongs_to> if any are
471 In general, for most databases, for a plain foreign key with no rules, the
472 values for a L<belongs_to|DBIx::Class::Relationship/belongs_to> relationship
475 on_delete => 'NO ACTION',
476 on_update => 'NO ACTION',
479 In the cases where an attribute is not supported by the DB, a value matching
480 the actual behavior is used, for example Oracle does not support C<ON UPDATE>
481 rules, so C<on_update> is set to C<NO ACTION>. This is done so that the
482 behavior of the schema is preserved when cross deploying to a different RDBMS
483 such as SQLite for testing.
485 In the cases where the DB does not support C<DEFERRABLE> foreign keys, the
486 value is set to C<1> if L<DBIx::Class> has a working C<<
487 $storage->with_deferred_fk_checks >>. This is done so that the same
488 L<DBIx::Class> code can be used, and cross deployed from and to such databases.
492 If set to true, each constructive L<DBIx::Class> statement the loader
493 decides to execute will be C<warn>-ed before execution.
497 Set the name of the schema to load (schema in the sense that your database
500 Can be set to an arrayref of schema names for multiple schemas, or the special
501 value C<%> for all schemas.
503 For MSSQL, Sybase ASE, and Informix can be set to a hashref of databases as
504 keys and arrays of owners as values, set to the value:
508 for all owners in all databases.
510 Name clashes resulting from the same table name in different databases/schemas
511 will be resolved automatically by prefixing the moniker with the database
514 To prefix/suffix all monikers with the database and/or schema, see
519 The database table names are represented by the
520 L<DBIx::Class::Schema::Loader::Table> class in the loader, the
521 L<DBIx::Class::Schema::Loader::Table::Sybase> class for Sybase ASE and
522 L<DBIx::Class::Schema::Loader::Table::Informix> for Informix.
524 Monikers are created normally based on just the
525 L<name|DBIx::Class::Schema::Loader::DBObject/name> property, corresponding to
526 the table name, but can consist of other parts of the fully qualified name of
529 The L</moniker_parts> option is an arrayref of methods on the table class
530 corresponding to parts of the fully qualified table name, defaulting to
531 C<['name']>, in the order those parts are used to create the moniker name.
532 The parts are joined together using L</moniker_part_separator>.
534 The C<'name'> entry B<must> be present.
536 Below is a table of supported databases and possible L</moniker_parts>.
540 =item * DB2, Firebird, mysql, Oracle, Pg, SQLAnywhere, SQLite, MS Access
544 =item * Informix, MSSQL, Sybase ASE
546 C<database>, C<schema>, C<name>
550 =head2 moniker_part_separator
552 String used to join L</moniker_parts> when creating the moniker.
553 Defaults to the empty string. Use C<::> to get a separate namespace per
554 database and/or schema.
558 Only load matching tables.
562 Exclude matching tables.
564 These can be specified either as a regex (preferrably on the C<qr//>
565 form), or as an arrayref of arrayrefs. Regexes are matched against
566 the (unqualified) table name, while arrayrefs are matched according to
571 db_schema => [qw(some_schema other_schema)],
572 moniker_parts => [qw(schema name)],
574 [ qr/\Asome_schema\z/ => qr/\A(?:foo|bar)\z/ ],
575 [ qr/\Aother_schema\z/ => qr/\Abaz\z/ ],
578 In this case only the tables C<foo> and C<bar> in C<some_schema> and
579 C<baz> in C<other_schema> will be dumped.
583 Overrides the default table name to moniker translation. Either
589 a nested hashref, which will be traversed according to L</moniker_parts>
593 moniker_parts => [qw(schema name)],
600 In which case the table C<bar> in the C<foo> schema would get the moniker
605 a hashref of unqualified table name keys and moniker values
609 a coderef for a translator function taking a L<table
610 object|DBIx::Class::Schema::Loader::Table> argument (which stringifies to the
611 unqualified table name) and returning a scalar moniker
613 The function is also passed a coderef that can be called with either
614 of the hashref forms to get the moniker mapped accordingly. This is
615 useful if you need to handle some monikers specially, but want to use
616 the hashref form for the rest.
620 If the hash entry does not exist, or the function returns a false
621 value, the code falls back to default behavior for that table name.
623 The default behavior is to split on case transition and non-alphanumeric
624 boundaries, singularize the resulting phrase, then join the titlecased words
627 Table Name | Moniker Name
628 ---------------------------------
630 luser_group | LuserGroup
631 luser-opts | LuserOpt
632 stations_visited | StationVisited
633 routeChange | RouteChange
635 =head2 moniker_part_map
637 Map for overriding the monikerization of individual L</moniker_parts>.
638 The keys are the moniker part to override, the value is either a
639 hashref of coderef for mapping the corresponding part of the
640 moniker. If a coderef is used, it gets called with the moniker part
641 and the hash key the code ref was found under.
645 moniker_part_map => {
646 schema => sub { ... },
649 Given the table C<foo.bar>, the code ref would be called with the
650 arguments C<foo> and C<schema>, plus a coderef similar to the one
651 described in L</moniker_map>.
653 L</moniker_map> takes precedence over this.
655 =head2 col_accessor_map
657 Same as moniker_map, but for column accessor names. If a coderef is
658 passed, the code is called with arguments of
660 the name of the column in the underlying database,
661 default accessor name that DBICSL would ordinarily give this column,
663 table_class => name of the DBIC class we are building,
664 table_moniker => calculated moniker for this table (after moniker_map if present),
665 table => table object of interface DBIx::Class::Schema::Loader::Table,
666 full_table_name => schema-qualified name of the database table (RDBMS specific),
667 schema_class => name of the schema class we are building,
668 column_info => hashref of column info (data_type, is_nullable, etc),
670 coderef ref that can be called with a hashref map
672 the L<table object|DBIx::Class::Schema::Loader::Table> stringifies to the
673 unqualified table name.
677 Similar in idea to moniker_map, but different in the details. It can be
678 a hashref or a code ref.
680 If it is a hashref, keys can be either the default relationship name, or the
681 moniker. The keys that are the default relationship name should map to the
682 name you want to change the relationship to. Keys that are monikers should map
683 to hashes mapping relationship names to their translation. You can do both at
684 once, and the more specific moniker version will be picked up first. So, for
685 instance, you could have
694 and relationships that would have been named C<bar> will now be named C<baz>
695 except that in the table whose moniker is C<Foo> it will be named C<blat>.
697 If it is a coderef, it will be passed a hashref of this form:
700 name => default relationship name,
701 type => the relationship type eg: C<has_many>,
702 local_class => name of the DBIC class we are building,
703 local_moniker => moniker of the DBIC class we are building,
704 local_columns => columns in this table in the relationship,
705 remote_class => name of the DBIC class we are related to,
706 remote_moniker => moniker of the DBIC class we are related to,
707 remote_columns => columns in the other table in the relationship,
708 # for type => "many_to_many" only:
709 link_class => name of the DBIC class for the link table
710 link_moniker => moniker of the DBIC class for the link table
711 link_rel_name => name of the relationship to the link table
714 In addition it is passed a coderef that can be called with a hashref map.
716 DBICSL will try to use the value returned as the relationship name.
718 =head2 inflect_plural
720 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
721 if hash key does not exist or coderef returns false), but acts as a map
722 for pluralizing relationship names. The default behavior is to utilize
723 L<Lingua::EN::Inflect::Phrase/to_PL>.
725 =head2 inflect_singular
727 As L</inflect_plural> above, but for singularizing relationship names.
728 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
730 =head2 schema_base_class
732 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
734 =head2 schema_components
736 List of components to load into the Schema class.
738 =head2 result_base_class
740 Base class for your table classes (aka result classes). Defaults to
743 =head2 additional_base_classes
745 List of additional base classes all of your table classes will use.
747 =head2 left_base_classes
749 List of additional base classes all of your table classes will use
750 that need to be leftmost.
752 =head2 additional_classes
754 List of additional classes which all of your table classes will use.
758 List of additional components to be loaded into all of your Result
759 classes. A good example would be
760 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
762 =head2 result_components_map
764 A hashref of moniker keys and component values. Unlike L</components>, which
765 loads the given components into every Result class, this option allows you to
766 load certain components for specified Result classes. For example:
768 result_components_map => {
769 StationVisited => '+YourApp::Schema::Component::StationVisited',
771 '+YourApp::Schema::Component::RouteChange',
772 'InflateColumn::DateTime',
776 You may use this in conjunction with L</components>.
780 List of L<Moose> roles to be applied to all of your Result classes.
782 =head2 result_roles_map
784 A hashref of moniker keys and role values. Unlike L</result_roles>, which
785 applies the given roles to every Result class, this option allows you to apply
786 certain roles for specified Result classes. For example:
788 result_roles_map => {
790 'YourApp::Role::Building',
791 'YourApp::Role::Destination',
793 RouteChange => 'YourApp::Role::TripEvent',
796 You may use this in conjunction with L</result_roles>.
798 =head2 use_namespaces
800 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
803 Generate result class names suitable for
804 L<DBIx::Class::Schema/load_namespaces> and call that instead of
805 L<DBIx::Class::Schema/load_classes>. When using this option you can also
806 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
807 C<resultset_namespace>, C<default_resultset_class>), and they will be added
808 to the call (and the generated result class names adjusted appropriately).
810 =head2 dump_directory
812 The value of this option is a perl libdir pathname. Within
813 that directory this module will create a baseline manual
814 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
816 The created schema class will have the same classname as the one on
817 which you are setting this option (and the ResultSource classes will be
818 based on this name as well).
820 Normally you wouldn't hard-code this setting in your schema class, as it
821 is meant for one-time manual usage.
823 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
824 recommended way to access this functionality.
826 =head2 dump_overwrite
828 Deprecated. See L</really_erase_my_files> below, which does *not* mean
829 the same thing as the old C<dump_overwrite> setting from previous releases.
831 =head2 really_erase_my_files
833 Default false. If true, Loader will unconditionally delete any existing
834 files before creating the new ones from scratch when dumping a schema to disk.
836 The default behavior is instead to only replace the top portion of the
837 file, up to and including the final stanza which contains
838 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
839 leaving any customizations you placed after that as they were.
841 When C<really_erase_my_files> is not set, if the output file already exists,
842 but the aforementioned final stanza is not found, or the checksum
843 contained there does not match the generated contents, Loader will
844 croak and not touch the file.
846 You should really be using version control on your schema classes (and all
847 of the rest of your code for that matter). Don't blame me if a bug in this
848 code wipes something out when it shouldn't have, you've been warned.
850 =head2 overwrite_modifications
852 Default false. If false, when updating existing files, Loader will
853 refuse to modify any Loader-generated code that has been modified
854 since its last run (as determined by the checksum Loader put in its
857 If true, Loader will discard any manual modifications that have been
858 made to Loader-generated code.
860 Again, you should be using version control on your schema classes. Be
861 careful with this option.
863 =head2 custom_column_info
865 Hook for adding extra attributes to the
866 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
868 Must be a coderef that returns a hashref with the extra attributes.
870 Receives the L<table object|DBIx::Class::Schema::Loader::Table> (which
871 stringifies to the unqualified table name), column name and column_info.
875 custom_column_info => sub {
876 my ($table, $column_name, $column_info) = @_;
878 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
879 return { is_snoopy => 1 };
883 This attribute can also be used to set C<inflate_datetime> on a non-datetime
884 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
886 =head2 datetime_timezone
888 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
889 columns with the DATE/DATETIME/TIMESTAMP data_types.
891 =head2 datetime_locale
893 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
894 columns with the DATE/DATETIME/TIMESTAMP data_types.
896 =head2 datetime_undef_if_invalid
898 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
899 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
902 The default is recommended to deal with data such as C<00/00/00> which
903 sometimes ends up in such columns in MySQL.
907 File in Perl format, which should return a HASH reference, from which to read
912 Normally database names are lowercased and split by underscore, use this option
913 if you have CamelCase database names.
915 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
916 case-sensitive collation will turn this option on unconditionally.
918 B<NOTE:> L</naming> = C<v8> is highly recommended with this option as the
919 semantics of this mode are much improved for CamelCase database names.
921 L</naming> = C<v7> or greater is required with this option.
923 =head2 qualify_objects
925 Set to true to prepend the L</db_schema> to table names for C<<
926 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
928 This attribute is automatically set to true for multi db_schema configurations,
929 unless explicitly set to false by the user.
933 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
934 L<MooseX::MarkAsMethods> (or L<namespace::autoclean>, see below). The default
935 content after the md5 sum also makes the classes immutable.
937 It is safe to upgrade your existing Schema to this option.
939 =head2 only_autoclean
941 By default, we use L<MooseX::MarkAsMethods> to remove imported functions from
942 your generated classes. It uses L<namespace::autoclean> to do this, after
943 telling your object's metaclass that any operator L<overload>s in your class
944 are methods, which will cause namespace::autoclean to spare them from removal.
946 This prevents the "Hey, where'd my overloads go?!" effect.
948 If you don't care about operator overloads, enabling this option falls back to
949 just using L<namespace::autoclean> itself.
951 If none of the above made any sense, or you don't have some pressing need to
952 only use L<namespace::autoclean>, leaving this set to the default is
955 =head2 col_collision_map
957 This option controls how accessors for column names which collide with perl
958 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
960 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
961 strings which are compiled to regular expressions that map to
962 L<sprintf|perlfunc/sprintf> formats.
966 col_collision_map => 'column_%s'
968 col_collision_map => { '(.*)' => 'column_%s' }
970 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
972 =head2 rel_collision_map
974 Works just like L</col_collision_map>, but for relationship names/accessors
975 rather than column names/accessors.
977 The default is to just append C<_rel> to the relationship name, see
978 L</RELATIONSHIP NAME COLLISIONS>.
980 =head2 uniq_to_primary
982 Automatically promotes the largest unique constraints with non-nullable columns
983 on tables to primary keys, assuming there is only one largest unique
986 =head2 filter_generated_code
988 An optional hook that lets you filter the generated text for various classes
989 through a function that change it in any way that you want. The function will
990 receive the type of file, C<schema> or C<result>, class and code; and returns
991 the new code to use instead. For instance you could add custom comments, or do
992 anything else that you want.
994 The option can also be set to a string, which is then used as a filter program,
997 If this exists but fails to return text matching C</\bpackage\b/>, no file will
1000 filter_generated_code => sub {
1001 my ($type, $class, $text) = @_;
1008 None of these methods are intended for direct invocation by regular
1009 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
1010 L<DBIx::Class::Schema::Loader>.
1014 # ensure that a piece of object data is a valid arrayref, creating
1015 # an empty one or encapsulating whatever's there.
1016 sub _ensure_arrayref {
1021 $self->{$_} = [ $self->{$_} ]
1022 unless ref $self->{$_} eq 'ARRAY';
1028 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
1029 by L<DBIx::Class::Schema::Loader>.
1034 my ( $class, %args ) = @_;
1036 if (exists $args{column_accessor_map}) {
1037 $args{col_accessor_map} = delete $args{column_accessor_map};
1040 my $self = { %args };
1042 # don't lose undef options
1043 for (values %$self) {
1044 $_ = 0 unless defined $_;
1047 bless $self => $class;
1049 if (my $config_file = $self->config_file) {
1050 my $config_opts = do $config_file;
1052 croak "Error reading config from $config_file: $@" if $@;
1054 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
1056 while (my ($k, $v) = each %$config_opts) {
1057 $self->{$k} = $v unless exists $self->{$k};
1061 if (defined $self->{result_component_map}) {
1062 if (defined $self->result_components_map) {
1063 croak "Specify only one of result_components_map or result_component_map";
1065 $self->result_components_map($self->{result_component_map})
1068 if (defined $self->{result_role_map}) {
1069 if (defined $self->result_roles_map) {
1070 croak "Specify only one of result_roles_map or result_role_map";
1072 $self->result_roles_map($self->{result_role_map})
1075 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
1076 if ((not defined $self->use_moose) || (not $self->use_moose))
1077 && ((defined $self->result_roles) || (defined $self->result_roles_map));
1079 $self->_ensure_arrayref(qw/schema_components
1081 additional_base_classes
1087 $self->_validate_class_args;
1089 croak "result_components_map must be a hash"
1090 if defined $self->result_components_map
1091 && ref $self->result_components_map ne 'HASH';
1093 if ($self->result_components_map) {
1094 my %rc_map = %{ $self->result_components_map };
1095 foreach my $moniker (keys %rc_map) {
1096 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
1098 $self->result_components_map(\%rc_map);
1101 $self->result_components_map({});
1103 $self->_validate_result_components_map;
1105 croak "result_roles_map must be a hash"
1106 if defined $self->result_roles_map
1107 && ref $self->result_roles_map ne 'HASH';
1109 if ($self->result_roles_map) {
1110 my %rr_map = %{ $self->result_roles_map };
1111 foreach my $moniker (keys %rr_map) {
1112 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
1114 $self->result_roles_map(\%rr_map);
1116 $self->result_roles_map({});
1118 $self->_validate_result_roles_map;
1120 if ($self->use_moose) {
1121 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
1122 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
1123 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
1127 $self->{_tables} = {};
1128 $self->{monikers} = {};
1129 $self->{moniker_to_table} = {};
1130 $self->{class_to_table} = {};
1131 $self->{classes} = {};
1132 $self->{_upgrading_classes} = {};
1133 $self->{generated_classes} = [];
1135 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
1136 $self->{schema} ||= $self->{schema_class};
1137 $self->{table_comments_table} ||= 'table_comments';
1138 $self->{column_comments_table} ||= 'column_comments';
1140 croak "dump_overwrite is deprecated. Please read the"
1141 . " DBIx::Class::Schema::Loader::Base documentation"
1142 if $self->{dump_overwrite};
1144 $self->{dynamic} = ! $self->{dump_directory};
1146 croak "dry_run can only be used with static schema generation"
1147 if $self->dynamic and $self->dry_run;
1149 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
1154 $self->{dump_directory} ||= $self->{temp_directory};
1156 $self->real_dump_directory($self->{dump_directory});
1158 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
1159 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
1161 if (not defined $self->naming) {
1162 $self->naming_set(0);
1165 $self->naming_set(1);
1168 if ((not ref $self->naming) && defined $self->naming) {
1169 my $naming_ver = $self->naming;
1171 relationships => $naming_ver,
1172 monikers => $naming_ver,
1173 column_accessors => $naming_ver,
1176 elsif (ref $self->naming eq 'HASH' && exists $self->naming->{ALL}) {
1177 my $val = delete $self->naming->{ALL};
1179 $self->naming->{$_} = $val
1180 foreach qw/relationships monikers column_accessors/;
1183 if ($self->naming) {
1184 foreach my $key (qw/relationships monikers column_accessors/) {
1185 $self->naming->{$key} = $CURRENT_V if ($self->naming->{$key}||'') eq 'current';
1188 $self->{naming} ||= {};
1190 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
1191 croak 'custom_column_info must be a CODE ref';
1194 $self->_check_back_compat;
1196 $self->use_namespaces(1) unless defined $self->use_namespaces;
1197 $self->generate_pod(1) unless defined $self->generate_pod;
1198 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
1199 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
1201 if (my $col_collision_map = $self->col_collision_map) {
1202 if (my $reftype = ref $col_collision_map) {
1203 if ($reftype ne 'HASH') {
1204 croak "Invalid type $reftype for option 'col_collision_map'";
1208 $self->col_collision_map({ '(.*)' => $col_collision_map });
1212 if (my $rel_collision_map = $self->rel_collision_map) {
1213 if (my $reftype = ref $rel_collision_map) {
1214 if ($reftype ne 'HASH') {
1215 croak "Invalid type $reftype for option 'rel_collision_map'";
1219 $self->rel_collision_map({ '(.*)' => $rel_collision_map });
1223 if (defined(my $rel_name_map = $self->rel_name_map)) {
1224 my $reftype = ref $rel_name_map;
1225 if ($reftype ne 'HASH' && $reftype ne 'CODE') {
1226 croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
1230 if (defined(my $filter = $self->filter_generated_code)) {
1231 my $reftype = ref $filter;
1232 if ($reftype && $reftype ne 'CODE') {
1233 croak "Invalid type $reftype for option 'filter_generated_code, must be a scalar or a CODE reference";
1237 if (defined $self->db_schema) {
1238 if (ref $self->db_schema eq 'ARRAY') {
1239 if (@{ $self->db_schema } > 1 && not defined $self->{qualify_objects}) {
1240 $self->{qualify_objects} = 1;
1242 elsif (@{ $self->db_schema } == 0) {
1243 $self->{db_schema} = undef;
1246 elsif (not ref $self->db_schema) {
1247 if ($self->db_schema eq '%' && not defined $self->{qualify_objects}) {
1248 $self->{qualify_objects} = 1;
1251 $self->{db_schema} = [ $self->db_schema ];
1255 if (not $self->moniker_parts) {
1256 $self->moniker_parts(['name']);
1259 if (not ref $self->moniker_parts) {
1260 $self->moniker_parts([ $self->moniker_parts ]);
1262 if (ref $self->moniker_parts ne 'ARRAY') {
1263 croak 'moniker_parts must be an arrayref';
1265 if ((firstidx { $_ eq 'name' } @{ $self->moniker_parts }) == -1) {
1266 croak "moniker_parts option *must* contain 'name'";
1270 if (not defined $self->moniker_part_separator) {
1271 $self->moniker_part_separator('');
1273 if (not defined $self->moniker_part_map) {
1274 $self->moniker_part_map({}),
1280 sub _check_back_compat {
1283 # dynamic schemas will always be in 0.04006 mode, unless overridden
1284 if ($self->dynamic) {
1285 # just in case, though no one is likely to dump a dynamic schema
1286 $self->schema_version_to_dump('0.04006');
1288 if (not $self->naming_set) {
1289 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1291 Dynamic schema detected, will run in 0.04006 mode.
1293 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1294 to disable this warning.
1296 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1301 $self->_upgrading_from('v4');
1304 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
1305 $self->use_namespaces(1);
1308 $self->naming->{relationships} ||= 'v4';
1309 $self->naming->{monikers} ||= 'v4';
1311 if ($self->use_namespaces) {
1312 $self->_upgrading_from_load_classes(1);
1315 $self->use_namespaces(0);
1321 # otherwise check if we need backcompat mode for a static schema
1322 my $filename = $self->get_dump_filename($self->schema_class);
1323 return unless -e $filename;
1325 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
1326 $self->_parse_generated_file($filename);
1328 return unless $old_ver;
1330 # determine if the existing schema was dumped with use_moose => 1
1331 if (! defined $self->use_moose) {
1332 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
1335 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
1337 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
1338 my $ds = eval $result_namespace;
1340 Could not eval expression '$result_namespace' for result_namespace from
1343 $result_namespace = $ds || '';
1345 if ($load_classes && (not defined $self->use_namespaces)) {
1346 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1348 'load_classes;' static schema detected, turning off 'use_namespaces'.
1350 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
1351 variable to disable this warning.
1353 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1356 $self->use_namespaces(0);
1358 elsif ($load_classes && $self->use_namespaces) {
1359 $self->_upgrading_from_load_classes(1);
1361 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
1362 $self->_downgrading_to_load_classes(
1363 $result_namespace || 'Result'
1366 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
1367 if (not $self->result_namespace) {
1368 $self->result_namespace($result_namespace || 'Result');
1370 elsif ($result_namespace ne $self->result_namespace) {
1371 $self->_rewriting_result_namespace(
1372 $result_namespace || 'Result'
1377 # XXX when we go past .0 this will need fixing
1378 my ($v) = $old_ver =~ /([1-9])/;
1381 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
1383 if (not %{ $self->naming }) {
1384 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1386 Version $old_ver static schema detected, turning on backcompat mode.
1388 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1389 to disable this warning.
1391 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
1393 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
1394 from version 0.04006.
1397 $self->naming->{relationships} ||= $v;
1398 $self->naming->{monikers} ||= $v;
1399 $self->naming->{column_accessors} ||= $v;
1401 $self->schema_version_to_dump($old_ver);
1404 $self->_upgrading_from($v);
1408 sub _validate_class_args {
1411 foreach my $k (@CLASS_ARGS) {
1412 next unless $self->$k;
1414 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
1415 $self->_validate_classes($k, \@classes);
1419 sub _validate_result_components_map {
1422 foreach my $classes (values %{ $self->result_components_map }) {
1423 $self->_validate_classes('result_components_map', $classes);
1427 sub _validate_result_roles_map {
1430 foreach my $classes (values %{ $self->result_roles_map }) {
1431 $self->_validate_classes('result_roles_map', $classes);
1435 sub _validate_classes {
1438 my $classes = shift;
1440 # make a copy to not destroy original
1441 my @classes = @$classes;
1443 foreach my $c (@classes) {
1444 # components default to being under the DBIx::Class namespace unless they
1445 # are preceded with a '+'
1446 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1447 $c = 'DBIx::Class::' . $c;
1450 # 1 == installed, 0 == not installed, undef == invalid classname
1451 my $installed = Class::Inspector->installed($c);
1452 if ( defined($installed) ) {
1453 if ( $installed == 0 ) {
1454 croak qq/$c, as specified in the loader option "$key", is not installed/;
1457 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1463 sub _find_file_in_inc {
1464 my ($self, $file) = @_;
1466 foreach my $prefix (@INC) {
1467 my $fullpath = File::Spec->catfile($prefix, $file);
1468 # abs_path pure-perl fallback warns for non-existent files
1469 local $SIG{__WARN__} = sigwarn_silencer(qr/^stat\(.*\Q$file\E\)/);
1470 return $fullpath if -f $fullpath
1471 # abs_path throws on Windows for nonexistent files
1472 and (try { Cwd::abs_path($fullpath) }) ne
1473 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1479 sub _find_class_in_inc {
1480 my ($self, $class) = @_;
1482 return $self->_find_file_in_inc(class_path($class));
1488 return $self->_upgrading_from
1489 || $self->_upgrading_from_load_classes
1490 || $self->_downgrading_to_load_classes
1491 || $self->_rewriting_result_namespace
1495 sub _rewrite_old_classnames {
1496 my ($self, $code) = @_;
1498 return $code unless $self->_rewriting;
1500 my %old_classes = reverse %{ $self->_upgrading_classes };
1502 my $re = join '|', keys %old_classes;
1503 $re = qr/\b($re)\b/;
1505 $code =~ s/$re/$old_classes{$1} || $1/eg;
1510 sub _load_external {
1511 my ($self, $class) = @_;
1513 return if $self->{skip_load_external};
1515 # so that we don't load our own classes, under any circumstances
1516 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1518 my $real_inc_path = $self->_find_class_in_inc($class);
1520 my $old_class = $self->_upgrading_classes->{$class}
1521 if $self->_rewriting;
1523 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1524 if $old_class && $old_class ne $class;
1526 return unless $real_inc_path || $old_real_inc_path;
1528 if ($real_inc_path) {
1529 # If we make it to here, we loaded an external definition
1530 warn qq/# Loaded external class definition for '$class'\n/
1533 my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path);
1535 if ($self->dynamic) { # load the class too
1536 eval_package_without_redefine_warnings($class, $code);
1539 $self->_ext_stmt($class,
1540 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1541 .qq|# They are now part of the custom portion of this file\n|
1542 .qq|# for you to hand-edit. If you do not either delete\n|
1543 .qq|# this section or remove that file from \@INC, this section\n|
1544 .qq|# will be repeated redundantly when you re-create this\n|
1545 .qq|# file again via Loader! See skip_load_external to disable\n|
1546 .qq|# this feature.\n|
1549 $self->_ext_stmt($class, $code);
1550 $self->_ext_stmt($class,
1551 qq|# End of lines loaded from '$real_inc_path' |
1555 if ($old_real_inc_path) {
1556 my $code = slurp_file $old_real_inc_path;
1558 $self->_ext_stmt($class, <<"EOF");
1560 # These lines were loaded from '$old_real_inc_path',
1561 # based on the Result class name that would have been created by an older
1562 # version of the Loader. For a static schema, this happens only once during
1563 # upgrade. See skip_load_external to disable this feature.
1566 $code = $self->_rewrite_old_classnames($code);
1568 if ($self->dynamic) {
1571 Detected external content in '$old_real_inc_path', a class name that would have
1572 been used by an older version of the Loader.
1574 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1575 new name of the Result.
1577 eval_package_without_redefine_warnings($class, $code);
1581 $self->_ext_stmt($class, $code);
1582 $self->_ext_stmt($class,
1583 qq|# End of lines loaded from '$old_real_inc_path' |
1590 Does the actual schema-construction work.
1597 $self->_load_tables(
1598 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1606 Rescan the database for changes. Returns a list of the newly added table
1609 The schema argument should be the schema class or object to be affected. It
1610 should probably be derived from the original schema_class used during L</load>.
1615 my ($self, $schema) = @_;
1617 $self->{schema} = $schema;
1618 $self->_relbuilder->{schema} = $schema;
1621 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1623 foreach my $table (@current) {
1624 if(!exists $self->_tables->{$table->sql_name}) {
1625 push(@created, $table);
1630 @current{map $_->sql_name, @current} = ();
1631 foreach my $table (values %{ $self->_tables }) {
1632 if (not exists $current{$table->sql_name}) {
1633 $self->_remove_table($table);
1637 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1639 my $loaded = $self->_load_tables(@current);
1641 foreach my $table (@created) {
1642 $self->monikers->{$table->sql_name} = $self->_table2moniker($table);
1645 return map { $self->monikers->{$_->sql_name} } @created;
1651 return if $self->{skip_relationships};
1653 return $self->{relbuilder} ||= do {
1654 my $relbuilder_suff =
1661 ->{$self->naming->{relationships}||$CURRENT_V} || '';
1663 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1664 $self->ensure_class_loaded($relbuilder_class);
1665 $relbuilder_class->new($self);
1670 my ($self, @tables) = @_;
1672 # Save the new tables to the tables list and compute monikers
1674 $self->_tables->{$_->sql_name} = $_;
1675 $self->monikers->{$_->sql_name} = $self->_table2moniker($_);
1678 # check for moniker clashes
1679 my $inverse_moniker_idx;
1680 foreach my $imtable (values %{ $self->_tables }) {
1681 push @{ $inverse_moniker_idx->{$self->monikers->{$imtable->sql_name}} }, $imtable;
1685 foreach my $moniker (keys %$inverse_moniker_idx) {
1686 my $imtables = $inverse_moniker_idx->{$moniker};
1687 if (@$imtables > 1) {
1688 my $different_databases =
1689 $imtables->[0]->can('database') && (uniq map $_->database||'', @$imtables) > 1;
1691 my $different_schemas =
1692 (uniq map $_->schema||'', @$imtables) > 1;
1694 if ($different_databases || $different_schemas) {
1695 my ($use_schema, $use_database) = (1, 0);
1697 if ($different_databases) {
1700 # If any monikers are in the same database, we have to distinguish by
1701 # both schema and database.
1703 $db_counts{$_}++ for map $_->database, @$imtables;
1704 $use_schema = any { $_ > 1 } values %db_counts;
1707 foreach my $tbl (@$imtables) { delete $self->monikers->{$tbl->sql_name}; }
1709 my $moniker_parts = [ @{ $self->moniker_parts } ];
1711 my $have_schema = any { $_ eq 'schema' } @{ $self->moniker_parts };
1712 my $have_database = any { $_ eq 'database' } @{ $self->moniker_parts };
1714 unshift @$moniker_parts, 'schema' if $use_schema && !$have_schema;
1715 unshift @$moniker_parts, 'database' if $use_database && !$have_database;
1717 local $self->{moniker_parts} = $moniker_parts;
1721 foreach my $tbl (@$imtables) { $new_monikers{$tbl->sql_name} = $self->_table2moniker($tbl); }
1722 foreach my $name (map $_->sql_name, @$imtables) { $self->monikers->{$name} = $new_monikers{$name}; }
1724 # check if there are still clashes
1727 while (my ($t, $m) = each %new_monikers) {
1728 push @{ $by_moniker{$m} }, $t;
1731 foreach my $m (grep @{ $by_moniker{$_} } > 1, keys %by_moniker) {
1732 push @clashes, sprintf ("tried disambiguating by moniker_parts, but tables %s still reduced to the same source moniker '%s'",
1733 join (', ', @{ $by_moniker{$m} }),
1739 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1740 join (', ', map $_->sql_name, @$imtables),
1748 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1749 . 'Change the naming style, or supply an explicit moniker_map: '
1750 . join ('; ', @clashes)
1755 foreach my $tbl (@tables) { $self->_make_src_class($tbl); }
1756 foreach my $tbl (@tables) { $self->_setup_src_meta($tbl); }
1758 if(!$self->skip_relationships) {
1759 # The relationship loader needs a working schema
1760 local $self->{quiet} = 1;
1761 local $self->{dump_directory} = $self->{temp_directory};
1762 local $self->{generated_classes} = [];
1763 local $self->{dry_run} = 0;
1764 $self->_reload_classes(\@tables);
1765 $self->_load_relationships(\@tables);
1767 # Remove that temp dir from INC so it doesn't get reloaded
1768 @INC = grep $_ ne $self->dump_directory, @INC;
1771 foreach my $tbl (@tables) { $self->_load_roles($tbl); }
1772 foreach my $tbl (map { $self->classes->{$_->sql_name} } @tables) { $self->_load_external($tbl); }
1774 # Reload without unloading first to preserve any symbols from external
1776 $self->_reload_classes(\@tables, { unload => 0 });
1778 # Drop temporary cache
1779 delete $self->{_cache};
1784 sub _reload_classes {
1785 my ($self, $tables, $opts) = @_;
1787 my @tables = @$tables;
1789 my $unload = $opts->{unload};
1790 $unload = 1 unless defined $unload;
1792 # so that we don't repeat custom sections
1793 @INC = grep $_ ne $self->dump_directory, @INC;
1795 $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables);
1797 unshift @INC, $self->dump_directory;
1799 return if $self->dry_run;
1802 my %have_source = map { $_ => $self->schema->source($_) }
1803 $self->schema->sources;
1805 for my $table (@tables) {
1806 my $moniker = $self->monikers->{$table->sql_name};
1807 my $class = $self->classes->{$table->sql_name};
1810 no warnings 'redefine';
1811 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1814 if (my $mc = $self->_moose_metaclass($class)) {
1817 Class::Unload->unload($class) if $unload;
1818 my ($source, $resultset_class);
1820 ($source = $have_source{$moniker})
1821 && ($resultset_class = $source->resultset_class)
1822 && ($resultset_class ne 'DBIx::Class::ResultSet')
1824 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1825 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1828 Class::Unload->unload($resultset_class) if $unload;
1829 $self->_reload_class($resultset_class) if $has_file;
1831 $self->_reload_class($class);
1833 push @to_register, [$moniker, $class];
1836 Class::C3->reinitialize;
1837 for (@to_register) {
1838 $self->schema->register_class(@$_);
1842 sub _moose_metaclass {
1843 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1847 my $mc = try { Class::MOP::class_of($class) }
1850 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1853 # We use this instead of ensure_class_loaded when there are package symbols we
1856 my ($self, $class) = @_;
1858 delete $INC{ +class_path($class) };
1861 eval_package_without_redefine_warnings ($class, "require $class");
1864 my $source = slurp_file $self->_get_dump_filename($class);
1865 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1869 sub _get_dump_filename {
1870 my ($self, $class) = (@_);
1872 $class =~ s{::}{/}g;
1873 return $self->dump_directory . q{/} . $class . q{.pm};
1876 =head2 get_dump_filename
1880 Returns the full path to the file for a class that the class has been or will
1881 be dumped to. This is a file in a temp dir for a dynamic schema.
1885 sub get_dump_filename {
1886 my ($self, $class) = (@_);
1888 local $self->{dump_directory} = $self->real_dump_directory;
1890 return $self->_get_dump_filename($class);
1893 sub _ensure_dump_subdirs {
1894 my ($self, $class) = (@_);
1896 return if $self->dry_run;
1898 my @name_parts = split(/::/, $class);
1899 pop @name_parts; # we don't care about the very last element,
1900 # which is a filename
1902 my $dir = $self->dump_directory;
1905 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1907 last if !@name_parts;
1908 $dir = File::Spec->catdir($dir, shift @name_parts);
1913 my ($self, @classes) = @_;
1915 my $schema_class = $self->schema_class;
1916 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1918 my $target_dir = $self->dump_directory;
1919 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1920 unless $self->dynamic or $self->quiet;
1924 . qq|package $schema_class;\n\n|
1925 . qq|# Created by DBIx::Class::Schema::Loader\n|
1926 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1929 = $self->only_autoclean
1930 ? 'namespace::autoclean'
1931 : 'MooseX::MarkAsMethods autoclean => 1'
1934 if ($self->use_moose) {
1936 $schema_text.= qq|use Moose;\nuse $autoclean;\nextends '$schema_base_class';\n\n|;
1939 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1942 my @schema_components = @{ $self->schema_components || [] };
1944 if (@schema_components) {
1945 my $schema_components = dump @schema_components;
1946 $schema_components = "($schema_components)" if @schema_components == 1;
1948 $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1951 if ($self->use_namespaces) {
1952 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1953 my $namespace_options;
1955 my @attr = qw/resultset_namespace default_resultset_class/;
1957 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1959 for my $attr (@attr) {
1961 my $code = dumper_squashed $self->$attr;
1962 $namespace_options .= qq| $attr => $code,\n|
1965 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1966 $schema_text .= qq|;\n|;
1969 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1973 local $self->{version_to_dump} = $self->schema_version_to_dump;
1974 $self->_write_classfile($schema_class, $schema_text, 1);
1977 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1979 foreach my $src_class (@classes) {
1982 . qq|package $src_class;\n\n|
1983 . qq|# Created by DBIx::Class::Schema::Loader\n|
1984 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1986 $src_text .= $self->_make_pod_heading($src_class);
1988 $src_text .= qq|use strict;\nuse warnings;\n\n|;
1990 $src_text .= $self->_base_class_pod($result_base_class)
1991 unless $result_base_class eq 'DBIx::Class::Core';
1993 if ($self->use_moose) {
1994 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse $autoclean;|;
1996 # these options 'use base' which is compile time
1997 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1998 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
2001 $src_text .= qq|\nextends '$result_base_class';\n|;
2005 $src_text .= qq|use base '$result_base_class';\n|;
2008 $self->_write_classfile($src_class, $src_text);
2011 # remove Result dir if downgrading from use_namespaces, and there are no
2013 if (my $result_ns = $self->_downgrading_to_load_classes
2014 || $self->_rewriting_result_namespace) {
2015 my $result_namespace = $self->_result_namespace(
2020 (my $result_dir = $result_namespace) =~ s{::}{/}g;
2021 $result_dir = $self->dump_directory . '/' . $result_dir;
2023 unless (my @files = glob "$result_dir/*") {
2028 warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
2032 my ($self, $version, $ts) = @_;
2033 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
2036 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
2039 sub _write_classfile {
2040 my ($self, $class, $text, $is_schema) = @_;
2042 my $filename = $self->_get_dump_filename($class);
2043 $self->_ensure_dump_subdirs($class);
2045 if (-f $filename && $self->really_erase_my_files && !$self->dry_run) {
2046 warn "Deleting existing file '$filename' due to "
2047 . "'really_erase_my_files' setting\n" unless $self->quiet;
2051 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
2052 = $self->_parse_generated_file($filename);
2054 if (! $old_gen && -f $filename) {
2055 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
2056 . " it does not appear to have been generated by Loader"
2059 my $custom_content = $old_custom || '';
2061 # Use custom content from a renamed class, the class names in it are
2063 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
2064 my $old_filename = $self->_get_dump_filename($renamed_class);
2066 if (-f $old_filename) {
2067 $custom_content = ($self->_parse_generated_file ($old_filename))[4];
2069 unlink $old_filename unless $self->dry_run;
2073 $custom_content ||= $self->_default_custom_content($is_schema);
2075 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
2076 # If there is already custom content, which does not have the Moose content, add it.
2077 if ($self->use_moose) {
2079 my $non_moose_custom_content = do {
2080 local $self->{use_moose} = 0;
2081 $self->_default_custom_content;
2084 if ($custom_content eq $non_moose_custom_content) {
2085 $custom_content = $self->_default_custom_content($is_schema);
2087 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
2088 $custom_content .= $self->_default_custom_content($is_schema);
2091 elsif (defined $self->use_moose && $old_gen) {
2092 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'
2093 if $old_gen =~ /use \s+ MooseX?\b/x;
2096 $custom_content = $self->_rewrite_old_classnames($custom_content);
2099 for @{$self->{_dump_storage}->{$class} || []};
2101 if ($self->filter_generated_code) {
2102 my $filter = $self->filter_generated_code;
2104 if (ref $filter eq 'CODE') {
2106 ($is_schema ? 'schema' : 'result'),
2112 my ($fh, $temp_file) = tempfile();
2114 binmode $fh, ':encoding(UTF-8)';
2118 open my $out, qq{$filter < "$temp_file"|}
2119 or croak "Could not open pipe to $filter: $!";
2121 $text = decode('UTF-8', do { local $/; <$out> });
2123 $text =~ s/$CR?$LF/\n/g;
2127 my $exit_code = $? >> 8;
2130 or croak "Could not remove temporary file '$temp_file': $!";
2132 if ($exit_code != 0) {
2133 croak "filter '$filter' exited non-zero: $exit_code";
2136 if (not $text or not $text =~ /\bpackage\b/) {
2137 warn("$class skipped due to filter") if $self->debug;
2142 # Check and see if the dump is in fact different
2146 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
2147 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
2148 return unless $self->_upgrading_from && $is_schema;
2152 push @{$self->generated_classes}, $class;
2154 return if $self->dry_run;
2156 $text .= $self->_sig_comment(
2157 $self->version_to_dump,
2158 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
2161 open(my $fh, '>:encoding(UTF-8)', $filename)
2162 or croak "Cannot open '$filename' for writing: $!";
2164 # Write the top half and its MD5 sum
2165 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
2167 # Write out anything loaded via external partial class file in @INC
2169 for @{$self->{_ext_storage}->{$class} || []};
2171 # Write out any custom content the user has added
2172 print $fh $custom_content;
2175 or croak "Error closing '$filename': $!";
2178 sub _default_moose_custom_content {
2179 my ($self, $is_schema) = @_;
2181 if (not $is_schema) {
2182 return qq|\n__PACKAGE__->meta->make_immutable;|;
2185 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
2188 sub _default_custom_content {
2189 my ($self, $is_schema) = @_;
2190 my $default = qq|\n\n# You can replace this text with custom|
2191 . qq| code or comments, and it will be preserved on regeneration|;
2192 if ($self->use_moose) {
2193 $default .= $self->_default_moose_custom_content($is_schema);
2195 $default .= qq|\n1;\n|;
2199 sub _parse_generated_file {
2200 my ($self, $fn) = @_;
2202 return unless -f $fn;
2204 open(my $fh, '<:encoding(UTF-8)', $fn)
2205 or croak "Cannot open '$fn' for reading: $!";
2208 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
2210 my ($md5, $ts, $ver, $gen);
2216 # Pull out the version and timestamp from the line above
2217 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m;
2220 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"
2221 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
2230 my $custom = do { local $/; <$fh> }
2234 $custom =~ s/$CRLF|$LF/\n/g;
2238 return ($gen, $md5, $ver, $ts, $custom);
2246 warn "$target: use $_;" if $self->debug;
2247 $self->_raw_stmt($target, "use $_;");
2255 my $blist = join(q{ }, @_);
2257 return unless $blist;
2259 warn "$target: use base qw/$blist/;" if $self->debug;
2260 $self->_raw_stmt($target, "use base qw/$blist/;");
2267 my $rlist = join(q{, }, map { qq{'$_'} } @_);
2269 return unless $rlist;
2271 warn "$target: with $rlist;" if $self->debug;
2272 $self->_raw_stmt($target, "\nwith $rlist;");
2275 sub _result_namespace {
2276 my ($self, $schema_class, $ns) = @_;
2277 my @result_namespace;
2279 $ns = $ns->[0] if ref $ns;
2281 if ($ns =~ /^\+(.*)/) {
2282 # Fully qualified namespace
2283 @result_namespace = ($1)
2286 # Relative namespace
2287 @result_namespace = ($schema_class, $ns);
2290 return wantarray ? @result_namespace : join '::', @result_namespace;
2293 # Create class with applicable bases, setup monikers, etc
2294 sub _make_src_class {
2295 my ($self, $table) = @_;
2297 my $schema = $self->schema;
2298 my $schema_class = $self->schema_class;
2300 my $table_moniker = $self->monikers->{$table->sql_name};
2301 my @result_namespace = ($schema_class);
2302 if ($self->use_namespaces) {
2303 my $result_namespace = $self->result_namespace || 'Result';
2304 @result_namespace = $self->_result_namespace(
2309 my $table_class = join(q{::}, @result_namespace, $table_moniker);
2311 if ((my $upgrading_v = $self->_upgrading_from)
2312 || $self->_rewriting) {
2313 local $self->naming->{monikers} = $upgrading_v
2316 my @result_namespace = @result_namespace;
2317 if ($self->_upgrading_from_load_classes) {
2318 @result_namespace = ($schema_class);
2320 elsif (my $ns = $self->_downgrading_to_load_classes) {
2321 @result_namespace = $self->_result_namespace(
2326 elsif ($ns = $self->_rewriting_result_namespace) {
2327 @result_namespace = $self->_result_namespace(
2333 my $old_table_moniker = do {
2334 local $self->naming->{monikers} = $upgrading_v;
2335 $self->_table2moniker($table);
2338 my $old_class = join(q{::}, @result_namespace, $old_table_moniker);
2340 $self->_upgrading_classes->{$table_class} = $old_class
2341 unless $table_class eq $old_class;
2344 $self->classes->{$table->sql_name} = $table_class;
2345 $self->moniker_to_table->{$table_moniker} = $table;
2346 $self->class_to_table->{$table_class} = $table;
2348 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
2350 $self->_use ($table_class, @{$self->additional_classes});
2352 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
2354 $self->_inject($table_class, @{$self->left_base_classes});
2356 my @components = @{ $self->components || [] };
2358 push @components, @{ $self->result_components_map->{$table_moniker} }
2359 if exists $self->result_components_map->{$table_moniker};
2361 my @fq_components = @components;
2362 foreach my $component (@fq_components) {
2363 if ($component !~ s/^\+//) {
2364 $component = "DBIx::Class::$component";
2368 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
2370 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
2372 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
2374 $self->_inject($table_class, @{$self->additional_base_classes});
2377 sub _is_result_class_method {
2378 my ($self, $name, $table) = @_;
2380 my $table_moniker = $table ? $self->monikers->{$table->sql_name} : '';
2382 $self->_result_class_methods({})
2383 if not defined $self->_result_class_methods;
2385 if (not exists $self->_result_class_methods->{$table_moniker}) {
2386 my (@methods, %methods);
2387 my $base = $self->result_base_class || 'DBIx::Class::Core';
2389 my @components = @{ $self->components || [] };
2391 push @components, @{ $self->result_components_map->{$table_moniker} }
2392 if exists $self->result_components_map->{$table_moniker};
2394 for my $c (@components) {
2395 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
2398 my @roles = @{ $self->result_roles || [] };
2400 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2401 if exists $self->result_roles_map->{$table_moniker};
2403 for my $class ($base, @components,
2404 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
2405 $self->ensure_class_loaded($class);
2407 push @methods, @{ Class::Inspector->methods($class) || [] };
2410 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
2412 @methods{@methods} = ();
2414 $self->_result_class_methods->{$table_moniker} = \%methods;
2416 my $result_methods = $self->_result_class_methods->{$table_moniker};
2418 return exists $result_methods->{$name};
2421 sub _resolve_col_accessor_collisions {
2422 my ($self, $table, $col_info) = @_;
2424 while (my ($col, $info) = each %$col_info) {
2425 my $accessor = $info->{accessor} || $col;
2427 next if $accessor eq 'id'; # special case (very common column)
2429 if ($self->_is_result_class_method($accessor, $table)) {
2432 if (my $map = $self->col_collision_map) {
2433 for my $re (keys %$map) {
2434 if (my @matches = $col =~ /$re/) {
2435 $info->{accessor} = sprintf $map->{$re}, @matches;
2443 Column '$col' in table '$table' collides with an inherited method.
2444 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
2446 $info->{accessor} = undef;
2452 # use the same logic to run moniker_map, col_accessor_map
2454 my ( $self, $map, $default_code, $ident, @extra ) = @_;
2456 my $default_ident = $default_code->( $ident, @extra );
2458 if( $map && ref $map eq 'HASH' ) {
2459 if (my @parts = try{ @{ $ident } }) {
2460 my $part_map = $map;
2462 my $part = shift @parts;
2463 last unless exists $part_map->{ $part };
2464 if ( !ref $part_map->{ $part } && !@parts ) {
2465 $new_ident = $part_map->{ $part };
2468 elsif ( ref $part_map->{ $part } eq 'HASH' ) {
2469 $part_map = $part_map->{ $part };
2473 if( !$new_ident && !ref $map->{ $ident } ) {
2474 $new_ident = $map->{ $ident };
2477 elsif( $map && ref $map eq 'CODE' ) {
2480 croak "reentered map must be a hashref"
2481 unless 'HASH' eq ref($cb_map);
2482 return $self->_run_user_map($cb_map, $default_code, $ident, @extra);
2484 $new_ident = $map->( $ident, $default_ident, @extra, $cb );
2487 $new_ident ||= $default_ident;
2492 sub _default_column_accessor_name {
2493 my ( $self, $column_name ) = @_;
2495 my $preserve = ($self->naming->{column_accessors}||'') eq 'preserve';
2497 my $v = $self->_get_naming_v('column_accessors');
2499 my $accessor_name = $preserve ?
2500 $self->_to_identifier('column_accessors', $column_name) # assume CamelCase
2502 $self->_to_identifier('column_accessors', $column_name, '_');
2504 $accessor_name =~ s/\W+/_/g; # only if naming < v8, otherwise to_identifier
2508 return $accessor_name;
2510 elsif ($v < 7 || (not $self->preserve_case)) {
2511 # older naming just lc'd the col accessor and that's all.
2512 return lc $accessor_name;
2515 return join '_', map lc, split_name $column_name, $v;
2518 sub _make_column_accessor_name {
2519 my ($self, $column_name, $column_context_info ) = @_;
2521 my $accessor = $self->_run_user_map(
2522 $self->col_accessor_map,
2523 sub { $self->_default_column_accessor_name( shift ) },
2525 $column_context_info,
2531 sub _table_is_view {
2532 #my ($self, $table) = @_;
2536 # Set up metadata (cols, pks, etc)
2537 sub _setup_src_meta {
2538 my ($self, $table) = @_;
2540 my $schema = $self->schema;
2541 my $schema_class = $self->schema_class;
2543 my $table_class = $self->classes->{$table->sql_name};
2544 my $table_moniker = $self->monikers->{$table->sql_name};
2546 $self->_dbic_stmt($table_class, 'table_class', 'DBIx::Class::ResultSource::View')
2547 if $self->_table_is_view($table);
2549 $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
2551 my $cols = $self->_table_columns($table);
2552 my $col_info = $self->__columns_info_for($table);
2554 ### generate all the column accessor names
2555 while (my ($col, $info) = each %$col_info) {
2556 # hashref of other info that could be used by
2557 # user-defined accessor map functions
2559 table_class => $table_class,
2560 table_moniker => $table_moniker,
2561 table_name => $table, # bugwards compatibility, RT#84050
2563 full_table_name => $table->dbic_name,
2564 schema_class => $schema_class,
2565 column_info => $info,
2568 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2571 $self->_resolve_col_accessor_collisions($table, $col_info);
2573 # prune any redundant accessor names
2574 while (my ($col, $info) = each %$col_info) {
2575 no warnings 'uninitialized';
2576 delete $info->{accessor} if $info->{accessor} eq $col;
2579 my $fks = $self->_table_fk_info($table);
2581 foreach my $fkdef (@$fks) {
2582 for my $col (@{ $fkdef->{local_columns} }) {
2583 $col_info->{$col}{is_foreign_key} = 1;
2587 my $pks = $self->_table_pk_info($table) || [];
2589 my %uniq_tag; # used to eliminate duplicate uniqs
2591 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2593 my $uniqs = $self->_table_uniq_info($table) || [];
2596 foreach my $uniq (@$uniqs) {
2597 my ($name, $cols) = @$uniq;
2598 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2599 push @uniqs, [$name, $cols];
2602 my @non_nullable_uniqs = grep {
2603 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2606 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2607 my @by_colnum = sort { $b->[0] <=> $a->[0] }
2608 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2610 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2611 my @keys = map $_->[1], @by_colnum;
2615 # remove the uniq from list
2616 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2622 foreach my $pkcol (@$pks) {
2623 $col_info->{$pkcol}{is_nullable} = 0;
2629 map { $_, ($col_info->{$_}||{}) } @$cols
2632 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2635 # Sort unique constraints by constraint name for repeatable results (rels
2636 # are sorted as well elsewhere.)
2637 @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs;
2639 foreach my $uniq (@uniqs) {
2640 my ($name, $cols) = @$uniq;
2641 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2645 sub __columns_info_for {
2646 my ($self, $table) = @_;
2648 my $result = $self->_columns_info_for($table);
2650 while (my ($col, $info) = each %$result) {
2651 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
2652 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2654 $result->{$col} = $info;
2662 Returns a sorted list of loaded tables, using the original database table
2670 return values %{$self->_tables};
2674 my ($self, $naming_key) = @_;
2678 if (($self->naming->{$naming_key}||'') =~ /^v(\d+)\z/) {
2682 ($v) = $CURRENT_V =~ /^v(\d+)\z/;
2688 sub _to_identifier {
2689 my ($self, $naming_key, $name, $sep_char, $force) = @_;
2691 my $v = $self->_get_naming_v($naming_key);
2693 my $to_identifier = $self->naming->{force_ascii} ?
2694 \&String::ToIdentifier::EN::to_identifier
2695 : \&String::ToIdentifier::EN::Unicode::to_identifier;
2697 return $v >= 8 || $force ? $to_identifier->($name, $sep_char) : $name;
2700 # Make a moniker from a table
2701 sub _default_table2moniker {
2702 my ($self, $table) = @_;
2704 my $v = $self->_get_naming_v('monikers');
2706 my @moniker_parts = @{ $self->moniker_parts };
2707 my @name_parts = map $table->$_, @moniker_parts;
2709 my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
2713 foreach my $i (0 .. $#name_parts) {
2714 my $part = $name_parts[$i];
2716 my $moniker_part = $self->_run_user_map(
2717 $self->moniker_part_map->{$moniker_parts[$i]},
2719 $part, $moniker_parts[$i],
2721 if (length $moniker_part) {
2722 push @all_parts, $moniker_part;
2726 if ($i != $name_idx || $v >= 8) {
2727 $part = $self->_to_identifier('monikers', $part, '_', 1);
2730 if ($i == $name_idx && $v == 5) {
2731 $part = Lingua::EN::Inflect::Number::to_S($part);
2734 my @part_parts = map lc, $v > 6 ?
2735 # use v8 semantics for all moniker parts except name
2736 ($i == $name_idx ? split_name $part, $v : split_name $part)
2737 : split /[\W_]+/, $part;
2739 if ($i == $name_idx && $v >= 6) {
2740 my $as_phrase = join ' ', @part_parts;
2742 my $inflected = ($self->naming->{monikers}||'') eq 'plural' ?
2743 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2745 ($self->naming->{monikers}||'') eq 'preserve' ?
2748 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2750 @part_parts = split /\s+/, $inflected;
2753 push @all_parts, join '', map ucfirst, @part_parts;
2756 return join $self->moniker_part_separator, @all_parts;
2759 sub _table2moniker {
2760 my ( $self, $table ) = @_;
2762 $self->_run_user_map(
2764 sub { $self->_default_table2moniker( shift ) },
2769 sub _load_relationships {
2770 my ($self, $tables) = @_;
2774 foreach my $table (@$tables) {
2775 my $local_moniker = $self->monikers->{$table->sql_name};
2777 my $tbl_fk_info = $self->_table_fk_info($table);
2779 foreach my $fkdef (@$tbl_fk_info) {
2780 $fkdef->{local_table} = $table;
2781 $fkdef->{local_moniker} = $local_moniker;
2782 $fkdef->{remote_source} =
2783 $self->monikers->{$fkdef->{remote_table}->sql_name};
2785 my $tbl_uniq_info = $self->_table_uniq_info($table);
2787 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2790 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2792 foreach my $src_class (sort keys %$rel_stmts) {
2794 my @src_stmts = map $_->[2],
2800 ($_->{method} eq 'many_to_many' ? 1 : 0),
2803 ], @{ $rel_stmts->{$src_class} };
2805 foreach my $stmt (@src_stmts) {
2806 $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2812 my ($self, $table) = @_;
2814 my $table_moniker = $self->monikers->{$table->sql_name};
2815 my $table_class = $self->classes->{$table->sql_name};
2817 my @roles = @{ $self->result_roles || [] };
2818 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2819 if exists $self->result_roles_map->{$table_moniker};
2822 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2824 $self->_with($table_class, @roles);
2828 # Overload these in driver class:
2830 # Returns an arrayref of column names
2831 sub _table_columns { croak "ABSTRACT METHOD" }
2833 # Returns arrayref of pk col names
2834 sub _table_pk_info { croak "ABSTRACT METHOD" }
2836 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2837 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2839 # Returns an arrayref of foreign key constraints, each
2840 # being a hashref with 3 keys:
2841 # local_columns (arrayref), remote_columns (arrayref), remote_table
2842 sub _table_fk_info { croak "ABSTRACT METHOD" }
2844 # Returns an array of lower case table names
2845 sub _tables_list { croak "ABSTRACT METHOD" }
2847 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2853 # generate the pod for this statement, storing it with $self->_pod
2854 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2856 my $args = dump(@_);
2857 $args = '(' . $args . ')' if @_ < 2;
2858 my $stmt = $method . $args . q{;};
2860 warn qq|$class\->$stmt\n| if $self->debug;
2861 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2865 sub _make_pod_heading {
2866 my ($self, $class) = @_;
2868 return '' if not $self->generate_pod;
2870 my $table = $self->class_to_table->{$class};
2873 my $pcm = $self->pod_comment_mode;
2874 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2875 $comment = $self->__table_comment($table);
2876 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2877 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2878 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2880 $pod .= "=head1 NAME\n\n";
2882 my $table_descr = $class;
2883 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2885 $pod .= "$table_descr\n\n";
2887 if ($comment and $comment_in_desc) {
2888 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2895 # generates the accompanying pod for a DBIC class method statement,
2896 # storing it with $self->_pod
2902 if ($method eq 'table') {
2904 $table = $$table if ref $table eq 'SCALAR';
2905 $self->_pod($class, "=head1 TABLE: C<$table>");
2906 $self->_pod_cut($class);
2908 elsif ( $method eq 'add_columns' ) {
2909 $self->_pod( $class, "=head1 ACCESSORS" );
2910 my $col_counter = 0;
2912 while( my ($name,$attrs) = splice @cols,0,2 ) {
2914 $self->_pod( $class, '=head2 ' . $name );
2915 $self->_pod( $class,
2917 my $s = $attrs->{$_};
2918 $s = !defined $s ? 'undef' :
2919 length($s) == 0 ? '(empty string)' :
2920 ref($s) eq 'SCALAR' ? $$s :
2921 ref($s) ? dumper_squashed $s :
2922 looks_like_number($s) ? $s : qq{'$s'};
2925 } sort keys %$attrs,
2927 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2928 $self->_pod( $class, $comment );
2931 $self->_pod_cut( $class );
2932 } elsif ( $method =~ /^(?:belongs_to|has_many|might_have)\z/ ) {
2933 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2934 my ( $accessor, $rel_class ) = @_;
2935 $self->_pod( $class, "=head2 $accessor" );
2936 $self->_pod( $class, 'Type: ' . $method );
2937 $self->_pod( $class, "Related object: L<$rel_class>" );
2938 $self->_pod_cut( $class );
2939 $self->{_relations_started} { $class } = 1;
2940 } elsif ( $method eq 'many_to_many' ) {
2941 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2942 my ( $accessor, $rel1, $rel2 ) = @_;
2943 $self->_pod( $class, "=head2 $accessor" );
2944 $self->_pod( $class, 'Type: many_to_many' );
2945 $self->_pod( $class, "Composing rels: L</$rel1> -> $rel2" );
2946 $self->_pod_cut( $class );
2947 $self->{_relations_started} { $class } = 1;
2949 elsif ($method eq 'add_unique_constraint') {
2950 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2951 unless $self->{_uniqs_started}{$class};
2953 my ($name, $cols) = @_;
2955 $self->_pod($class, "=head2 C<$name>");
2956 $self->_pod($class, '=over 4');
2958 foreach my $col (@$cols) {
2959 $self->_pod($class, "=item \* L</$col>");
2962 $self->_pod($class, '=back');
2963 $self->_pod_cut($class);
2965 $self->{_uniqs_started}{$class} = 1;
2967 elsif ($method eq 'set_primary_key') {
2968 $self->_pod($class, "=head1 PRIMARY KEY");
2969 $self->_pod($class, '=over 4');
2971 foreach my $col (@_) {
2972 $self->_pod($class, "=item \* L</$col>");
2975 $self->_pod($class, '=back');
2976 $self->_pod_cut($class);
2980 sub _pod_class_list {
2981 my ($self, $class, $title, @classes) = @_;
2983 return unless @classes && $self->generate_pod;
2985 $self->_pod($class, "=head1 $title");
2986 $self->_pod($class, '=over 4');
2988 foreach my $link (@classes) {
2989 $self->_pod($class, "=item * L<$link>");
2992 $self->_pod($class, '=back');
2993 $self->_pod_cut($class);
2996 sub _base_class_pod {
2997 my ($self, $base_class) = @_;
2999 return '' unless $self->generate_pod;
3002 =head1 BASE CLASS: L<$base_class>
3009 sub _filter_comment {
3010 my ($self, $txt) = @_;
3012 $txt = '' if not defined $txt;
3014 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
3019 sub __table_comment {
3022 if (my $code = $self->can('_table_comment')) {
3023 return $self->_filter_comment($self->$code(@_));
3029 sub __column_comment {
3032 if (my $code = $self->can('_column_comment')) {
3033 return $self->_filter_comment($self->$code(@_));
3039 # Stores a POD documentation
3041 my ($self, $class, $stmt) = @_;
3042 $self->_raw_stmt( $class, "\n" . $stmt );
3046 my ($self, $class ) = @_;
3047 $self->_raw_stmt( $class, "\n=cut\n" );
3050 # Store a raw source line for a class (for dumping purposes)
3052 my ($self, $class, $stmt) = @_;
3053 push(@{$self->{_dump_storage}->{$class}}, $stmt);
3056 # Like above, but separately for the externally loaded stuff
3058 my ($self, $class, $stmt) = @_;
3059 push(@{$self->{_ext_storage}->{$class}}, $stmt);
3062 sub _custom_column_info {
3063 my ( $self, $table_name, $column_name, $column_info ) = @_;
3065 if (my $code = $self->custom_column_info) {
3066 return $code->($table_name, $column_name, $column_info) || {};
3071 sub _datetime_column_info {
3072 my ( $self, $table_name, $column_name, $column_info ) = @_;
3074 my $type = $column_info->{data_type} || '';
3075 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
3076 or ($type =~ /date|timestamp/i)) {
3077 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
3078 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
3084 my ($self, $name) = @_;
3086 return $self->preserve_case ? $name : lc($name);
3090 my ($self, $name) = @_;
3092 return $self->preserve_case ? $name : uc($name);
3096 my ($self, $table) = @_;
3099 my $schema = $self->schema;
3100 # in older DBIC it's a private method
3101 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
3102 $schema->$unregister(delete $self->monikers->{$table->sql_name});
3103 delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}};
3104 delete $self->_tables->{$table->sql_name};
3108 # remove the dump dir from @INC on destruction
3112 @INC = grep $_ ne $self->dump_directory, @INC;
3117 Returns a hashref of loaded table to moniker mappings. There will
3118 be two entries for each table, the original name and the "normalized"
3119 name, in the case that the two are different (such as databases
3120 that like uppercase table names, or preserve your original mixed-case
3121 definitions, or what-have-you).
3125 Returns a hashref of table to class mappings. In some cases it will
3126 contain multiple entries per table for the original and normalized table
3127 names, as above in L</monikers>.
3129 =head2 generated_classes
3131 Returns an arrayref of classes that were actually generated (i.e. not
3132 skipped because there were no changes).
3134 =head1 NON-ENGLISH DATABASES
3136 If you use the loader on a database with table and column names in a language
3137 other than English, you will want to turn off the English language specific
3140 To do so, use something like this in your loader options:
3142 naming => { monikers => 'v4' },
3143 inflect_singular => sub { "$_[0]_rel" },
3144 inflect_plural => sub { "$_[0]_rel" },
3146 =head1 COLUMN ACCESSOR COLLISIONS
3148 Occasionally you may have a column name that collides with a perl method, such
3149 as C<can>. In such cases, the default action is to set the C<accessor> of the
3150 column spec to C<undef>.
3152 You can then name the accessor yourself by placing code such as the following
3155 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
3157 Another option is to use the L</col_collision_map> option.
3159 =head1 RELATIONSHIP NAME COLLISIONS
3161 In very rare cases, you may get a collision between a generated relationship
3162 name and a method in your Result class, for example if you have a foreign key
3163 called C<belongs_to>.
3165 This is a problem because relationship names are also relationship accessor
3166 methods in L<DBIx::Class>.
3168 The default behavior is to append C<_rel> to the relationship name and print
3169 out a warning that refers to this text.
3171 You can also control the renaming with the L</rel_collision_map> option.
3175 L<DBIx::Class::Schema::Loader>, L<dbicdump>
3179 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
3183 This library is free software; you can redistribute it and/or modify it under
3184 the same terms as Perl itself.
3189 # vim:et sts=4 sw=4 tw=0: