1 package DBIx::Class::Schema::Loader::Base;
5 use base qw/Class::Accessor::Grouped Class::C3::Componentised/;
8 use Carp::Clan qw/^DBIx::Class/;
9 use DBIx::Class::Schema::Loader::RelBuilder ();
10 use Data::Dump 'dump';
15 use Lingua::EN::Inflect::Number ();
16 use Lingua::EN::Inflect::Phrase ();
17 use String::ToIdentifier::EN ();
18 use String::ToIdentifier::EN::Unicode ();
21 use Class::Inspector ();
22 use Scalar::Util 'looks_like_number';
23 use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path slurp_file/;
24 use DBIx::Class::Schema::Loader::Optional::Dependencies ();
27 use Encode qw/encode decode/;
28 use List::MoreUtils qw/all any firstidx uniq/;
29 use File::Temp 'tempfile';
32 our $VERSION = '0.07033';
34 __PACKAGE__->mk_group_ro_accessors('simple', qw/
41 additional_base_classes
57 default_resultset_class
63 overwrite_modifications
86 __PACKAGE__->mk_group_accessors('simple', qw/
88 schema_version_to_dump
90 _upgrading_from_load_classes
91 _downgrading_to_load_classes
92 _rewriting_result_namespace
97 pod_comment_spillover_length
103 result_components_map
105 datetime_undef_if_invalid
106 _result_class_methods
108 filter_generated_code
114 my $CURRENT_V = 'v7';
117 schema_components schema_base_class result_base_class
118 additional_base_classes left_base_classes additional_classes components
124 my $CRLF = "\x0d\x0a";
128 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
132 See L<DBIx::Class::Schema::Loader>.
136 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
137 classes, and implements the common functionality between them.
139 =head1 CONSTRUCTOR OPTIONS
141 These constructor options are the base options for
142 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
144 =head2 skip_relationships
146 Skip setting up relationships. The default is to attempt the loading
149 =head2 skip_load_external
151 Skip loading of other classes in @INC. The default is to merge all other classes
152 with the same name found in @INC into the schema file we are creating.
156 Static schemas (ones dumped to disk) will, by default, use the new-style
157 relationship names and singularized Results, unless you're overwriting an
158 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
159 which case the backward compatible RelBuilder will be activated, and the
160 appropriate monikerization used.
166 will disable the backward-compatible RelBuilder and use
167 the new-style relationship names along with singularized Results, even when
168 overwriting a dump made with an earlier version.
170 The option also takes a hashref:
173 relationships => 'v8',
175 column_accessors => 'v8',
181 naming => { ALL => 'v8', force_ascii => 1 }
189 Set L</relationships>, L</monikers> and L</column_accessors> to the specified
194 How to name relationship accessors.
198 How to name Result classes.
200 =item column_accessors
202 How to name column accessors in Result classes.
206 For L</v8> mode and later, uses L<String::ToIdentifier::EN> instead of
207 L<String::ToIdentifier::EM::Unicode> to force monikers and other identifiers to
218 Latest style, whatever that happens to be.
222 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
226 Monikers singularized as whole words, C<might_have> relationships for FKs on
227 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
229 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
234 All monikers and relationships are inflected using
235 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
236 from relationship names.
238 In general, there is very little difference between v5 and v6 schemas.
242 This mode is identical to C<v6> mode, except that monikerization of CamelCase
243 table names is also done better (but best in v8.)
245 CamelCase column names in case-preserving mode will also be handled better
246 for relationship name inflection (but best in v8.) See L</preserve_case>.
248 In this mode, CamelCase L</column_accessors> are normalized based on case
249 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
255 The default mode is L</v7>, to get L</v8> mode, you have to specify it in
256 L</naming> explicitly until C<0.08> comes out.
258 L</monikers> and L</column_accessors> are created using
259 L<String::ToIdentifier::EN::Unicode> or L<String::ToIdentifier::EN> if
260 L</force_ascii> is set; this is only significant for names with non-C<\w>
261 characters such as C<.>.
263 CamelCase identifiers with words in all caps, e.g. C<VLANValidID> are supported
264 correctly in this mode.
266 For relationships, belongs_to accessors are made from column names by stripping
267 postfixes other than C<_id> as well, for example just C<Id>, C<_?ref>, C<_?cd>,
268 C<_?code> and C<_?num>, case insensitively.
272 For L</monikers>, this option does not inflect the table names but makes
273 monikers based on the actual name. For L</column_accessors> this option does
274 not normalize CamelCase column names to lowercase column accessors, but makes
275 accessors that are the same names as the columns (with any non-\w chars
276 replaced with underscores.)
280 For L</monikers>, singularizes the names using the most current inflector. This
281 is the same as setting the option to L</current>.
285 For L</monikers>, pluralizes the names, using the most current inflector.
289 Dynamic schemas will always default to the 0.04XXX relationship names and won't
290 singularize Results for backward compatibility, to activate the new RelBuilder
291 and singularization put this in your C<Schema.pm> file:
293 __PACKAGE__->naming('current');
295 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
296 next major version upgrade:
298 __PACKAGE__->naming('v7');
302 If true, will not print the usual C<Dumping manual schema ... Schema dump
303 completed.> messages. Does not affect warnings (except for warnings related to
304 L</really_erase_my_files>.)
308 By default POD will be generated for columns and relationships, using database
309 metadata for the text if available and supported.
311 Comment metadata can be stored in two ways.
313 The first is that you can create two tables named C<table_comments> and
314 C<column_comments> respectively. These tables must exist in the same database
315 and schema as the tables they describe. They both need to have columns named
316 C<table_name> and C<comment_text>. The second one needs to have a column named
317 C<column_name>. Then data stored in these tables will be used as a source of
318 metadata about tables and comments.
320 (If you wish you can change the name of these tables with the parameters
321 L</table_comments_table> and L</column_comments_table>.)
323 As a fallback you can use built-in commenting mechanisms. Currently this is
324 only supported for PostgreSQL, Oracle and MySQL. To create comments in
325 PostgreSQL you add statements of the form C<COMMENT ON TABLE some_table IS
326 '...'>, the same syntax is used in Oracle. To create comments in MySQL you add
327 C<COMMENT '...'> to the end of the column or table definition. Note that MySQL
328 restricts the length of comments, and also does not handle complex Unicode
331 Set this to C<0> to turn off all POD generation.
333 =head2 pod_comment_mode
335 Controls where table comments appear in the generated POD. Smaller table
336 comments are appended to the C<NAME> section of the documentation, and larger
337 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
338 section to be generated with the comment always, only use C<NAME>, or choose
339 the length threshold at which the comment is forced into the description.
345 Use C<NAME> section only.
349 Force C<DESCRIPTION> always.
353 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
358 =head2 pod_comment_spillover_length
360 When pod_comment_mode is set to C<auto>, this is the length of the comment at
361 which it will be forced into a separate description section.
365 =head2 table_comments_table
367 The table to look for comments about tables in. By default C<table_comments>.
368 See L</generate_pod> for details.
370 This must not be a fully qualified name, the table will be looked for in the
371 same database and schema as the table whose comment is being retrieved.
373 =head2 column_comments_table
375 The table to look for comments about columns in. By default C<column_comments>.
376 See L</generate_pod> for details.
378 This must not be a fully qualified name, the table will be looked for in the
379 same database and schema as the table/column whose comment is being retrieved.
381 =head2 relationship_attrs
383 Hashref of attributes to pass to each generated relationship, listed by type.
384 Also supports relationship type 'all', containing options to pass to all
385 generated relationships. Attributes set for more specific relationship types
386 override those set in 'all', and any attributes specified by this option
387 override the introspected attributes of the foreign key if any.
391 relationship_attrs => {
392 has_many => { cascade_delete => 1, cascade_copy => 1 },
393 might_have => { cascade_delete => 1, cascade_copy => 1 },
396 use this to turn L<DBIx::Class> cascades to on on your
397 L<has_many|DBIx::Class::Relationship/has_many> and
398 L<might_have|DBIx::Class::Relationship/might_have> relationships, they default
401 Can also be a coderef, for more precise control, in which case the coderef gets
402 this hash of parameters (as a list:)
404 rel_name # the name of the relationship
405 local_source # the DBIx::Class::ResultSource object for the source the rel is *from*
406 remote_source # the DBIx::Class::ResultSource object for the source the rel is *to*
407 local_table # a DBIx::Class::Schema::Loader::Table object for the table of the source the rel is from
408 local_cols # an arrayref of column names of columns used in the rel in the source it is from
409 remote_table # a DBIx::Class::Schema::Loader::Table object for the table of the source the rel is to
410 remote_cols # an arrayref of column names of columns used in the rel in the source it is to
411 attrs # the attributes that would be set
413 it should return the new hashref of attributes, or nothing for no changes.
417 relationship_attrs => sub {
420 say "the relationship name is: $p{rel_name}";
421 say "the local class is: ", $p{local_source}->result_class;
422 say "the remote class is: ", $p{remote_source}->result_class;
423 say "the local table is: ", $p{local_table}->sql_name;
424 say "the rel columns in the local table are: ", (join ", ", @{$p{local_cols}});
425 say "the remote table is: ", $p{remote_table}->sql_name;
426 say "the rel columns in the remote table are: ", (join ", ", @{$p{remote_cols}});
428 if ($p{local_table} eq 'dogs' && @{$p{local_cols}} == 1 && $p{local_cols}[0] eq 'name') {
429 $p{attrs}{could_be_snoopy} = 1;
435 These are the default attributes:
446 on_delete => 'CASCADE',
447 on_update => 'CASCADE',
451 For L<belongs_to|DBIx::Class::Relationship/belongs_to> relationships, these
452 defaults are overridden by the attributes introspected from the foreign key in
453 the database, if this information is available (and the driver is capable of
456 This information overrides the defaults mentioned above, and is then itself
457 overridden by the user's L</relationship_attrs> for C<belongs_to> if any are
460 In general, for most databases, for a plain foreign key with no rules, the
461 values for a L<belongs_to|DBIx::Class::Relationship/belongs_to> relationship
464 on_delete => 'NO ACTION',
465 on_update => 'NO ACTION',
468 In the cases where an attribute is not supported by the DB, a value matching
469 the actual behavior is used, for example Oracle does not support C<ON UPDATE>
470 rules, so C<on_update> is set to C<NO ACTION>. This is done so that the
471 behavior of the schema is preserved when cross deploying to a different RDBMS
472 such as SQLite for testing.
474 In the cases where the DB does not support C<DEFERRABLE> foreign keys, the
475 value is set to C<1> if L<DBIx::Class> has a working C<<
476 $storage->with_deferred_fk_checks >>. This is done so that the same
477 L<DBIx::Class> code can be used, and cross deployed from and to such databases.
481 If set to true, each constructive L<DBIx::Class> statement the loader
482 decides to execute will be C<warn>-ed before execution.
486 Set the name of the schema to load (schema in the sense that your database
489 Can be set to an arrayref of schema names for multiple schemas, or the special
490 value C<%> for all schemas.
492 For MSSQL, Sybase ASE, and Informix can be set to a hashref of databases as
493 keys and arrays of owners as values, set to the value:
497 for all owners in all databases.
499 Name clashes resulting from the same table name in different databases/schemas
500 will be resolved automatically by prefixing the moniker with the database
503 To prefix/suffix all monikers with the database and/or schema, see
508 The database table names are represented by the
509 L<DBIx::Class::Schema::Loader::Table> class in the loader, the
510 L<DBIx::Class::Schema::Loader::Table::Sybase> class for Sybase ASE and
511 L<DBIx::Class::Schema::Loader::Table::Informix> for Informix.
513 Monikers are created normally based on just the
514 L<name|DBIx::Class::Schema::Loader::DBObject/name> property, corresponding to
515 the table name, but can consist of other parts of the fully qualified name of
518 The L</moniker_parts> option is an arrayref of methods on the table class
519 corresponding to parts of the fully qualified table name, defaulting to
520 C<['name']>, in the order those parts are used to create the moniker name.
522 The C<'name'> entry B<must> be present.
524 Below is a table of supported databases and possible L</moniker_parts>.
528 =item * DB2, Firebird, mysql, Oracle, Pg, SQLAnywhere, SQLite, MS Access
532 =item * Informix, MSSQL, Sybase ASE
534 C<database>, C<schema>, C<name>
540 Only load tables matching regex. Best specified as a qr// regex.
544 Exclude tables matching regex. Best specified as a qr// regex.
548 Overrides the default table name to moniker translation. Can be either a
549 hashref of table keys and moniker values, or a coderef for a translator
550 function taking a L<table object|DBIx::Class::Schema::Loader::Table> argument
551 (which stringifies to the unqualified table name) and returning a scalar
552 moniker. If the hash entry does not exist, or the function returns a false
553 value, the code falls back to default behavior for that table name.
555 The default behavior is to split on case transition and non-alphanumeric
556 boundaries, singularize the resulting phrase, then join the titlecased words
559 Table Name | Moniker Name
560 ---------------------------------
562 luser_group | LuserGroup
563 luser-opts | LuserOpt
564 stations_visited | StationVisited
565 routeChange | RouteChange
567 =head2 col_accessor_map
569 Same as moniker_map, but for column accessor names. If a coderef is
570 passed, the code is called with arguments of
572 the name of the column in the underlying database,
573 default accessor name that DBICSL would ordinarily give this column,
575 table_class => name of the DBIC class we are building,
576 table_moniker => calculated moniker for this table (after moniker_map if present),
577 table => table object of interface DBIx::Class::Schema::Loader::Table,
578 full_table_name => schema-qualified name of the database table (RDBMS specific),
579 schema_class => name of the schema class we are building,
580 column_info => hashref of column info (data_type, is_nullable, etc),
583 the L<table object|DBIx::Class::Schema::Loader::Table> stringifies to the
584 unqualified table name.
588 Similar in idea to moniker_map, but different in the details. It can be
589 a hashref or a code ref.
591 If it is a hashref, keys can be either the default relationship name, or the
592 moniker. The keys that are the default relationship name should map to the
593 name you want to change the relationship to. Keys that are monikers should map
594 to hashes mapping relationship names to their translation. You can do both at
595 once, and the more specific moniker version will be picked up first. So, for
596 instance, you could have
605 and relationships that would have been named C<bar> will now be named C<baz>
606 except that in the table whose moniker is C<Foo> it will be named C<blat>.
608 If it is a coderef, the argument passed will be a hashref of this form:
611 name => default relationship name,
612 type => the relationship type eg: C<has_many>,
613 local_class => name of the DBIC class we are building,
614 local_moniker => moniker of the DBIC class we are building,
615 local_columns => columns in this table in the relationship,
616 remote_class => name of the DBIC class we are related to,
617 remote_moniker => moniker of the DBIC class we are related to,
618 remote_columns => columns in the other table in the relationship,
621 DBICSL will try to use the value returned as the relationship name.
623 =head2 inflect_plural
625 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
626 if hash key does not exist or coderef returns false), but acts as a map
627 for pluralizing relationship names. The default behavior is to utilize
628 L<Lingua::EN::Inflect::Phrase/to_PL>.
630 =head2 inflect_singular
632 As L</inflect_plural> above, but for singularizing relationship names.
633 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
635 =head2 schema_base_class
637 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
639 =head2 schema_components
641 List of components to load into the Schema class.
643 =head2 result_base_class
645 Base class for your table classes (aka result classes). Defaults to
648 =head2 additional_base_classes
650 List of additional base classes all of your table classes will use.
652 =head2 left_base_classes
654 List of additional base classes all of your table classes will use
655 that need to be leftmost.
657 =head2 additional_classes
659 List of additional classes which all of your table classes will use.
663 List of additional components to be loaded into all of your Result
664 classes. A good example would be
665 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
667 =head2 result_components_map
669 A hashref of moniker keys and component values. Unlike L</components>, which
670 loads the given components into every Result class, this option allows you to
671 load certain components for specified Result classes. For example:
673 result_components_map => {
674 StationVisited => '+YourApp::Schema::Component::StationVisited',
676 '+YourApp::Schema::Component::RouteChange',
677 'InflateColumn::DateTime',
681 You may use this in conjunction with L</components>.
685 List of L<Moose> roles to be applied to all of your Result classes.
687 =head2 result_roles_map
689 A hashref of moniker keys and role values. Unlike L</result_roles>, which
690 applies the given roles to every Result class, this option allows you to apply
691 certain roles for specified Result classes. For example:
693 result_roles_map => {
695 'YourApp::Role::Building',
696 'YourApp::Role::Destination',
698 RouteChange => 'YourApp::Role::TripEvent',
701 You may use this in conjunction with L</result_roles>.
703 =head2 use_namespaces
705 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
708 Generate result class names suitable for
709 L<DBIx::Class::Schema/load_namespaces> and call that instead of
710 L<DBIx::Class::Schema/load_classes>. When using this option you can also
711 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
712 C<resultset_namespace>, C<default_resultset_class>), and they will be added
713 to the call (and the generated result class names adjusted appropriately).
715 =head2 dump_directory
717 The value of this option is a perl libdir pathname. Within
718 that directory this module will create a baseline manual
719 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
721 The created schema class will have the same classname as the one on
722 which you are setting this option (and the ResultSource classes will be
723 based on this name as well).
725 Normally you wouldn't hard-code this setting in your schema class, as it
726 is meant for one-time manual usage.
728 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
729 recommended way to access this functionality.
731 =head2 dump_overwrite
733 Deprecated. See L</really_erase_my_files> below, which does *not* mean
734 the same thing as the old C<dump_overwrite> setting from previous releases.
736 =head2 really_erase_my_files
738 Default false. If true, Loader will unconditionally delete any existing
739 files before creating the new ones from scratch when dumping a schema to disk.
741 The default behavior is instead to only replace the top portion of the
742 file, up to and including the final stanza which contains
743 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
744 leaving any customizations you placed after that as they were.
746 When C<really_erase_my_files> is not set, if the output file already exists,
747 but the aforementioned final stanza is not found, or the checksum
748 contained there does not match the generated contents, Loader will
749 croak and not touch the file.
751 You should really be using version control on your schema classes (and all
752 of the rest of your code for that matter). Don't blame me if a bug in this
753 code wipes something out when it shouldn't have, you've been warned.
755 =head2 overwrite_modifications
757 Default false. If false, when updating existing files, Loader will
758 refuse to modify any Loader-generated code that has been modified
759 since its last run (as determined by the checksum Loader put in its
762 If true, Loader will discard any manual modifications that have been
763 made to Loader-generated code.
765 Again, you should be using version control on your schema classes. Be
766 careful with this option.
768 =head2 custom_column_info
770 Hook for adding extra attributes to the
771 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
773 Must be a coderef that returns a hashref with the extra attributes.
775 Receives the L<table object|DBIx::Class::Schema::Loader::Table> (which
776 stringifies to the unqualified table name), column name and column_info.
780 custom_column_info => sub {
781 my ($table, $column_name, $column_info) = @_;
783 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
784 return { is_snoopy => 1 };
788 This attribute can also be used to set C<inflate_datetime> on a non-datetime
789 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
791 =head2 datetime_timezone
793 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
794 columns with the DATE/DATETIME/TIMESTAMP data_types.
796 =head2 datetime_locale
798 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
799 columns with the DATE/DATETIME/TIMESTAMP data_types.
801 =head2 datetime_undef_if_invalid
803 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
804 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
807 The default is recommended to deal with data such as C<00/00/00> which
808 sometimes ends up in such columns in MySQL.
812 File in Perl format, which should return a HASH reference, from which to read
817 Normally database names are lowercased and split by underscore, use this option
818 if you have CamelCase database names.
820 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
821 case-sensitive collation will turn this option on unconditionally.
823 B<NOTE:> L</naming> = C<v8> is highly recommended with this option as the
824 semantics of this mode are much improved for CamelCase database names.
826 L</naming> = C<v7> or greater is required with this option.
828 =head2 qualify_objects
830 Set to true to prepend the L</db_schema> to table names for C<<
831 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
833 This attribute is automatically set to true for multi db_schema configurations,
834 unless explicitly set to false by the user.
838 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
839 L<MooseX::MarkAsMethods> (or L<namespace::autoclean>, see below). The default
840 content after the md5 sum also makes the classes immutable.
842 It is safe to upgrade your existing Schema to this option.
844 =head2 only_autoclean
846 By default, we use L<MooseX::MarkAsMethods> to remove imported functions from
847 your generated classes. It uses L<namespace::autoclean> to do this, after
848 telling your object's metaclass that any operator L<overload>s in your class
849 are methods, which will cause namespace::autoclean to spare them from removal.
851 This prevents the "Hey, where'd my overloads go?!" effect.
853 If you don't care about operator overloads, enabling this option falls back to
854 just using L<namespace::autoclean> itself.
856 If none of the above made any sense, or you don't have some pressing need to
857 only use L<namespace::autoclean>, leaving this set to the default is
860 =head2 col_collision_map
862 This option controls how accessors for column names which collide with perl
863 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
865 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
866 strings which are compiled to regular expressions that map to
867 L<sprintf|perlfunc/sprintf> formats.
871 col_collision_map => 'column_%s'
873 col_collision_map => { '(.*)' => 'column_%s' }
875 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
877 =head2 rel_collision_map
879 Works just like L</col_collision_map>, but for relationship names/accessors
880 rather than column names/accessors.
882 The default is to just append C<_rel> to the relationship name, see
883 L</RELATIONSHIP NAME COLLISIONS>.
885 =head2 uniq_to_primary
887 Automatically promotes the largest unique constraints with non-nullable columns
888 on tables to primary keys, assuming there is only one largest unique
891 =head2 filter_generated_code
893 An optional hook that lets you filter the generated text for various classes
894 through a function that change it in any way that you want. The function will
895 receive the type of file, C<schema> or C<result>, class and code; and returns
896 the new code to use instead. For instance you could add custom comments, or do
897 anything else that you want.
899 The option can also be set to a string, which is then used as a filter program,
902 If this exists but fails to return text matching C</\bpackage\b/>, no file will
905 filter_generated_code => sub {
906 my ($type, $class, $text) = @_;
913 None of these methods are intended for direct invocation by regular
914 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
915 L<DBIx::Class::Schema::Loader>.
919 # ensure that a peice of object data is a valid arrayref, creating
920 # an empty one or encapsulating whatever's there.
921 sub _ensure_arrayref {
926 $self->{$_} = [ $self->{$_} ]
927 unless ref $self->{$_} eq 'ARRAY';
933 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
934 by L<DBIx::Class::Schema::Loader>.
939 my ( $class, %args ) = @_;
941 if (exists $args{column_accessor_map}) {
942 $args{col_accessor_map} = delete $args{column_accessor_map};
945 my $self = { %args };
947 # don't lose undef options
948 for (values %$self) {
949 $_ = 0 unless defined $_;
952 bless $self => $class;
954 if (my $config_file = $self->config_file) {
955 my $config_opts = do $config_file;
957 croak "Error reading config from $config_file: $@" if $@;
959 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
961 while (my ($k, $v) = each %$config_opts) {
962 $self->{$k} = $v unless exists $self->{$k};
966 if (defined $self->{result_component_map}) {
967 if (defined $self->result_components_map) {
968 croak "Specify only one of result_components_map or result_component_map";
970 $self->result_components_map($self->{result_component_map})
973 if (defined $self->{result_role_map}) {
974 if (defined $self->result_roles_map) {
975 croak "Specify only one of result_roles_map or result_role_map";
977 $self->result_roles_map($self->{result_role_map})
980 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
981 if ((not defined $self->use_moose) || (not $self->use_moose))
982 && ((defined $self->result_roles) || (defined $self->result_roles_map));
984 $self->_ensure_arrayref(qw/schema_components
986 additional_base_classes
992 $self->_validate_class_args;
994 croak "result_components_map must be a hash"
995 if defined $self->result_components_map
996 && ref $self->result_components_map ne 'HASH';
998 if ($self->result_components_map) {
999 my %rc_map = %{ $self->result_components_map };
1000 foreach my $moniker (keys %rc_map) {
1001 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
1003 $self->result_components_map(\%rc_map);
1006 $self->result_components_map({});
1008 $self->_validate_result_components_map;
1010 croak "result_roles_map must be a hash"
1011 if defined $self->result_roles_map
1012 && ref $self->result_roles_map ne 'HASH';
1014 if ($self->result_roles_map) {
1015 my %rr_map = %{ $self->result_roles_map };
1016 foreach my $moniker (keys %rr_map) {
1017 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
1019 $self->result_roles_map(\%rr_map);
1021 $self->result_roles_map({});
1023 $self->_validate_result_roles_map;
1025 if ($self->use_moose) {
1026 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
1027 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
1028 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
1032 $self->{_tables} = {};
1033 $self->{monikers} = {};
1034 $self->{moniker_to_table} = {};
1035 $self->{class_to_table} = {};
1036 $self->{classes} = {};
1037 $self->{_upgrading_classes} = {};
1039 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
1040 $self->{schema} ||= $self->{schema_class};
1041 $self->{table_comments_table} ||= 'table_comments';
1042 $self->{column_comments_table} ||= 'column_comments';
1044 croak "dump_overwrite is deprecated. Please read the"
1045 . " DBIx::Class::Schema::Loader::Base documentation"
1046 if $self->{dump_overwrite};
1048 $self->{dynamic} = ! $self->{dump_directory};
1049 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
1054 $self->{dump_directory} ||= $self->{temp_directory};
1056 $self->real_dump_directory($self->{dump_directory});
1058 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
1059 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
1061 if (not defined $self->naming) {
1062 $self->naming_set(0);
1065 $self->naming_set(1);
1068 if ((not ref $self->naming) && defined $self->naming) {
1069 my $naming_ver = $self->naming;
1071 relationships => $naming_ver,
1072 monikers => $naming_ver,
1073 column_accessors => $naming_ver,
1076 elsif (ref $self->naming eq 'HASH' && exists $self->naming->{ALL}) {
1077 my $val = delete $self->naming->{ALL};
1079 $self->naming->{$_} = $val
1080 foreach qw/relationships monikers column_accessors/;
1083 if ($self->naming) {
1084 foreach my $key (qw/relationships monikers column_accessors/) {
1085 $self->naming->{$key} = $CURRENT_V if ($self->naming->{$key}||'') eq 'current';
1088 $self->{naming} ||= {};
1090 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
1091 croak 'custom_column_info must be a CODE ref';
1094 $self->_check_back_compat;
1096 $self->use_namespaces(1) unless defined $self->use_namespaces;
1097 $self->generate_pod(1) unless defined $self->generate_pod;
1098 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
1099 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
1101 if (my $col_collision_map = $self->col_collision_map) {
1102 if (my $reftype = ref $col_collision_map) {
1103 if ($reftype ne 'HASH') {
1104 croak "Invalid type $reftype for option 'col_collision_map'";
1108 $self->col_collision_map({ '(.*)' => $col_collision_map });
1112 if (my $rel_collision_map = $self->rel_collision_map) {
1113 if (my $reftype = ref $rel_collision_map) {
1114 if ($reftype ne 'HASH') {
1115 croak "Invalid type $reftype for option 'rel_collision_map'";
1119 $self->rel_collision_map({ '(.*)' => $rel_collision_map });
1123 if (defined(my $rel_name_map = $self->rel_name_map)) {
1124 my $reftype = ref $rel_name_map;
1125 if ($reftype ne 'HASH' && $reftype ne 'CODE') {
1126 croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
1130 if (defined(my $filter = $self->filter_generated_code)) {
1131 my $reftype = ref $filter;
1132 if ($reftype && $reftype ne 'CODE') {
1133 croak "Invalid type $reftype for option 'filter_generated_code, must be a scalar or a CODE reference";
1137 if (defined $self->db_schema) {
1138 if (ref $self->db_schema eq 'ARRAY') {
1139 if (@{ $self->db_schema } > 1 && not defined $self->{qualify_objects}) {
1140 $self->{qualify_objects} = 1;
1142 elsif (@{ $self->db_schema } == 0) {
1143 $self->{db_schema} = undef;
1146 elsif (not ref $self->db_schema) {
1147 if ($self->db_schema eq '%' && not defined $self->{qualify_objects}) {
1148 $self->{qualify_objects} = 1;
1151 $self->{db_schema} = [ $self->db_schema ];
1155 if (not $self->moniker_parts) {
1156 $self->moniker_parts(['name']);
1159 if (not ref $self->moniker_parts) {
1160 $self->moniker_parts([ $self->moniker_parts ]);
1162 if (ref $self->moniker_parts ne 'ARRAY') {
1163 croak 'moniker_parts must be an arrayref';
1165 if ((firstidx { $_ eq 'name' } @{ $self->moniker_parts }) == -1) {
1166 croak "moniker_parts option *must* contain 'name'";
1173 sub _check_back_compat {
1176 # dynamic schemas will always be in 0.04006 mode, unless overridden
1177 if ($self->dynamic) {
1178 # just in case, though no one is likely to dump a dynamic schema
1179 $self->schema_version_to_dump('0.04006');
1181 if (not $self->naming_set) {
1182 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1184 Dynamic schema detected, will run in 0.04006 mode.
1186 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1187 to disable this warning.
1189 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1194 $self->_upgrading_from('v4');
1197 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
1198 $self->use_namespaces(1);
1201 $self->naming->{relationships} ||= 'v4';
1202 $self->naming->{monikers} ||= 'v4';
1204 if ($self->use_namespaces) {
1205 $self->_upgrading_from_load_classes(1);
1208 $self->use_namespaces(0);
1214 # otherwise check if we need backcompat mode for a static schema
1215 my $filename = $self->get_dump_filename($self->schema_class);
1216 return unless -e $filename;
1218 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
1219 $self->_parse_generated_file($filename);
1221 return unless $old_ver;
1223 # determine if the existing schema was dumped with use_moose => 1
1224 if (! defined $self->use_moose) {
1225 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
1228 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
1230 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
1231 my $ds = eval $result_namespace;
1233 Could not eval expression '$result_namespace' for result_namespace from
1236 $result_namespace = $ds || '';
1238 if ($load_classes && (not defined $self->use_namespaces)) {
1239 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1241 'load_classes;' static schema detected, turning off 'use_namespaces'.
1243 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
1244 variable to disable this warning.
1246 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1249 $self->use_namespaces(0);
1251 elsif ($load_classes && $self->use_namespaces) {
1252 $self->_upgrading_from_load_classes(1);
1254 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
1255 $self->_downgrading_to_load_classes(
1256 $result_namespace || 'Result'
1259 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
1260 if (not $self->result_namespace) {
1261 $self->result_namespace($result_namespace || 'Result');
1263 elsif ($result_namespace ne $self->result_namespace) {
1264 $self->_rewriting_result_namespace(
1265 $result_namespace || 'Result'
1270 # XXX when we go past .0 this will need fixing
1271 my ($v) = $old_ver =~ /([1-9])/;
1274 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
1276 if (not %{ $self->naming }) {
1277 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1279 Version $old_ver static schema detected, turning on backcompat mode.
1281 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1282 to disable this warning.
1284 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
1286 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
1287 from version 0.04006.
1290 $self->naming->{relationships} ||= $v;
1291 $self->naming->{monikers} ||= $v;
1292 $self->naming->{column_accessors} ||= $v;
1294 $self->schema_version_to_dump($old_ver);
1297 $self->_upgrading_from($v);
1301 sub _validate_class_args {
1304 foreach my $k (@CLASS_ARGS) {
1305 next unless $self->$k;
1307 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
1308 $self->_validate_classes($k, \@classes);
1312 sub _validate_result_components_map {
1315 foreach my $classes (values %{ $self->result_components_map }) {
1316 $self->_validate_classes('result_components_map', $classes);
1320 sub _validate_result_roles_map {
1323 foreach my $classes (values %{ $self->result_roles_map }) {
1324 $self->_validate_classes('result_roles_map', $classes);
1328 sub _validate_classes {
1331 my $classes = shift;
1333 # make a copy to not destroy original
1334 my @classes = @$classes;
1336 foreach my $c (@classes) {
1337 # components default to being under the DBIx::Class namespace unless they
1338 # are preceeded with a '+'
1339 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1340 $c = 'DBIx::Class::' . $c;
1343 # 1 == installed, 0 == not installed, undef == invalid classname
1344 my $installed = Class::Inspector->installed($c);
1345 if ( defined($installed) ) {
1346 if ( $installed == 0 ) {
1347 croak qq/$c, as specified in the loader option "$key", is not installed/;
1350 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1356 sub _find_file_in_inc {
1357 my ($self, $file) = @_;
1359 foreach my $prefix (@INC) {
1360 my $fullpath = File::Spec->catfile($prefix, $file);
1361 return $fullpath if -f $fullpath
1362 # abs_path throws on Windows for nonexistant files
1363 and (try { Cwd::abs_path($fullpath) }) ne
1364 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1370 sub _find_class_in_inc {
1371 my ($self, $class) = @_;
1373 return $self->_find_file_in_inc(class_path($class));
1379 return $self->_upgrading_from
1380 || $self->_upgrading_from_load_classes
1381 || $self->_downgrading_to_load_classes
1382 || $self->_rewriting_result_namespace
1386 sub _rewrite_old_classnames {
1387 my ($self, $code) = @_;
1389 return $code unless $self->_rewriting;
1391 my %old_classes = reverse %{ $self->_upgrading_classes };
1393 my $re = join '|', keys %old_classes;
1394 $re = qr/\b($re)\b/;
1396 $code =~ s/$re/$old_classes{$1} || $1/eg;
1401 sub _load_external {
1402 my ($self, $class) = @_;
1404 return if $self->{skip_load_external};
1406 # so that we don't load our own classes, under any circumstances
1407 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1409 my $real_inc_path = $self->_find_class_in_inc($class);
1411 my $old_class = $self->_upgrading_classes->{$class}
1412 if $self->_rewriting;
1414 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1415 if $old_class && $old_class ne $class;
1417 return unless $real_inc_path || $old_real_inc_path;
1419 if ($real_inc_path) {
1420 # If we make it to here, we loaded an external definition
1421 warn qq/# Loaded external class definition for '$class'\n/
1424 my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path);
1426 if ($self->dynamic) { # load the class too
1427 eval_package_without_redefine_warnings($class, $code);
1430 $self->_ext_stmt($class,
1431 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1432 .qq|# They are now part of the custom portion of this file\n|
1433 .qq|# for you to hand-edit. If you do not either delete\n|
1434 .qq|# this section or remove that file from \@INC, this section\n|
1435 .qq|# will be repeated redundantly when you re-create this\n|
1436 .qq|# file again via Loader! See skip_load_external to disable\n|
1437 .qq|# this feature.\n|
1440 $self->_ext_stmt($class, $code);
1441 $self->_ext_stmt($class,
1442 qq|# End of lines loaded from '$real_inc_path' |
1446 if ($old_real_inc_path) {
1447 my $code = slurp_file $old_real_inc_path;
1449 $self->_ext_stmt($class, <<"EOF");
1451 # These lines were loaded from '$old_real_inc_path',
1452 # based on the Result class name that would have been created by an older
1453 # version of the Loader. For a static schema, this happens only once during
1454 # upgrade. See skip_load_external to disable this feature.
1457 $code = $self->_rewrite_old_classnames($code);
1459 if ($self->dynamic) {
1462 Detected external content in '$old_real_inc_path', a class name that would have
1463 been used by an older version of the Loader.
1465 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1466 new name of the Result.
1468 eval_package_without_redefine_warnings($class, $code);
1472 $self->_ext_stmt($class, $code);
1473 $self->_ext_stmt($class,
1474 qq|# End of lines loaded from '$old_real_inc_path' |
1481 Does the actual schema-construction work.
1488 $self->_load_tables(
1489 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1497 Rescan the database for changes. Returns a list of the newly added table
1500 The schema argument should be the schema class or object to be affected. It
1501 should probably be derived from the original schema_class used during L</load>.
1506 my ($self, $schema) = @_;
1508 $self->{schema} = $schema;
1509 $self->_relbuilder->{schema} = $schema;
1512 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1514 foreach my $table (@current) {
1515 if(!exists $self->_tables->{$table->sql_name}) {
1516 push(@created, $table);
1521 @current{map $_->sql_name, @current} = ();
1522 foreach my $table (values %{ $self->_tables }) {
1523 if (not exists $current{$table->sql_name}) {
1524 $self->_remove_table($table);
1528 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1530 my $loaded = $self->_load_tables(@current);
1532 foreach my $table (@created) {
1533 $self->monikers->{$table->sql_name} = $self->_table2moniker($table);
1536 return map { $self->monikers->{$_->sql_name} } @created;
1542 return if $self->{skip_relationships};
1544 return $self->{relbuilder} ||= do {
1545 my $relbuilder_suff =
1552 ->{$self->naming->{relationships}||$CURRENT_V} || '';
1554 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1555 $self->ensure_class_loaded($relbuilder_class);
1556 $relbuilder_class->new($self);
1561 my ($self, @tables) = @_;
1563 # Save the new tables to the tables list and compute monikers
1565 $self->_tables->{$_->sql_name} = $_;
1566 $self->monikers->{$_->sql_name} = $self->_table2moniker($_);
1569 # check for moniker clashes
1570 my $inverse_moniker_idx;
1571 foreach my $imtable (values %{ $self->_tables }) {
1572 push @{ $inverse_moniker_idx->{$self->monikers->{$imtable->sql_name}} }, $imtable;
1576 foreach my $moniker (keys %$inverse_moniker_idx) {
1577 my $imtables = $inverse_moniker_idx->{$moniker};
1578 if (@$imtables > 1) {
1579 my $different_databases =
1580 $imtables->[0]->can('database') && (uniq map $_->database||'', @$imtables) > 1;
1582 my $different_schemas =
1583 (uniq map $_->schema||'', @$imtables) > 1;
1585 if ($different_databases || $different_schemas) {
1586 my ($use_schema, $use_database) = (1, 0);
1588 if ($different_databases) {
1591 # If any monikers are in the same database, we have to distinguish by
1592 # both schema and database.
1594 $db_counts{$_}++ for map $_->database, @$imtables;
1595 $use_schema = any { $_ > 1 } values %db_counts;
1598 foreach my $tbl (@$imtables) { delete $self->monikers->{$tbl->sql_name}; }
1600 my $moniker_parts = [ @{ $self->moniker_parts } ];
1602 my $have_schema = 1 if any { $_ eq 'schema' } @{ $self->moniker_parts };
1603 my $have_database = 1 if any { $_ eq 'database' } @{ $self->moniker_parts };
1605 unshift @$moniker_parts, 'schema' if $use_schema && !$have_schema;
1606 unshift @$moniker_parts, 'database' if $use_database && !$have_database;
1608 local $self->{moniker_parts} = $moniker_parts;
1612 foreach my $tbl (@$imtables) { $new_monikers{$tbl->sql_name} = $self->_table2moniker($tbl); }
1613 foreach my $name (map $_->sql_name, @$imtables) { $self->monikers->{$name} = $new_monikers{$name}; }
1615 # check if there are still clashes
1618 while (my ($t, $m) = each %new_monikers) {
1619 push @{ $by_moniker{$m} }, $t;
1622 foreach my $m (grep @{ $by_moniker{$_} } > 1, keys %by_moniker) {
1623 push @clashes, sprintf ("tried disambiguating by moniker_parts, but tables %s still reduced to the same source moniker '%s'",
1624 join (', ', @{ $by_moniker{$m} }),
1630 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1631 join (', ', map $_->sql_name, @$imtables),
1639 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1640 . 'Change the naming style, or supply an explicit moniker_map: '
1641 . join ('; ', @clashes)
1646 foreach my $tbl (@tables) { $self->_make_src_class($tbl); }
1647 foreach my $tbl (@tables) { $self->_setup_src_meta($tbl); }
1649 if(!$self->skip_relationships) {
1650 # The relationship loader needs a working schema
1651 local $self->{quiet} = 1;
1652 local $self->{dump_directory} = $self->{temp_directory};
1653 $self->_reload_classes(\@tables);
1654 $self->_load_relationships(\@tables);
1656 # Remove that temp dir from INC so it doesn't get reloaded
1657 @INC = grep $_ ne $self->dump_directory, @INC;
1660 foreach my $tbl (@tables) { $self->_load_roles($tbl); }
1661 foreach my $tbl (map { $self->classes->{$_->sql_name} } @tables) { $self->_load_external($tbl); }
1663 # Reload without unloading first to preserve any symbols from external
1665 $self->_reload_classes(\@tables, { unload => 0 });
1667 # Drop temporary cache
1668 delete $self->{_cache};
1673 sub _reload_classes {
1674 my ($self, $tables, $opts) = @_;
1676 my @tables = @$tables;
1678 my $unload = $opts->{unload};
1679 $unload = 1 unless defined $unload;
1681 # so that we don't repeat custom sections
1682 @INC = grep $_ ne $self->dump_directory, @INC;
1684 $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables);
1686 unshift @INC, $self->dump_directory;
1689 my %have_source = map { $_ => $self->schema->source($_) }
1690 $self->schema->sources;
1692 for my $table (@tables) {
1693 my $moniker = $self->monikers->{$table->sql_name};
1694 my $class = $self->classes->{$table->sql_name};
1697 no warnings 'redefine';
1698 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1701 if (my $mc = $self->_moose_metaclass($class)) {
1704 Class::Unload->unload($class) if $unload;
1705 my ($source, $resultset_class);
1707 ($source = $have_source{$moniker})
1708 && ($resultset_class = $source->resultset_class)
1709 && ($resultset_class ne 'DBIx::Class::ResultSet')
1711 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1712 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1715 Class::Unload->unload($resultset_class) if $unload;
1716 $self->_reload_class($resultset_class) if $has_file;
1718 $self->_reload_class($class);
1720 push @to_register, [$moniker, $class];
1723 Class::C3->reinitialize;
1724 for (@to_register) {
1725 $self->schema->register_class(@$_);
1729 sub _moose_metaclass {
1730 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1734 my $mc = try { Class::MOP::class_of($class) }
1737 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1740 # We use this instead of ensure_class_loaded when there are package symbols we
1743 my ($self, $class) = @_;
1745 delete $INC{ +class_path($class) };
1748 eval_package_without_redefine_warnings ($class, "require $class");
1751 my $source = slurp_file $self->_get_dump_filename($class);
1752 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1756 sub _get_dump_filename {
1757 my ($self, $class) = (@_);
1759 $class =~ s{::}{/}g;
1760 return $self->dump_directory . q{/} . $class . q{.pm};
1763 =head2 get_dump_filename
1767 Returns the full path to the file for a class that the class has been or will
1768 be dumped to. This is a file in a temp dir for a dynamic schema.
1772 sub get_dump_filename {
1773 my ($self, $class) = (@_);
1775 local $self->{dump_directory} = $self->real_dump_directory;
1777 return $self->_get_dump_filename($class);
1780 sub _ensure_dump_subdirs {
1781 my ($self, $class) = (@_);
1783 my @name_parts = split(/::/, $class);
1784 pop @name_parts; # we don't care about the very last element,
1785 # which is a filename
1787 my $dir = $self->dump_directory;
1790 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1792 last if !@name_parts;
1793 $dir = File::Spec->catdir($dir, shift @name_parts);
1798 my ($self, @classes) = @_;
1800 my $schema_class = $self->schema_class;
1801 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1803 my $target_dir = $self->dump_directory;
1804 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1805 unless $self->dynamic or $self->quiet;
1809 . qq|package $schema_class;\n\n|
1810 . qq|# Created by DBIx::Class::Schema::Loader\n|
1811 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1814 = $self->only_autoclean
1815 ? 'namespace::autoclean'
1816 : 'MooseX::MarkAsMethods autoclean => 1'
1819 if ($self->use_moose) {
1821 $schema_text.= qq|use Moose;\nuse $autoclean;\nextends '$schema_base_class';\n\n|;
1824 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1827 my @schema_components = @{ $self->schema_components || [] };
1829 if (@schema_components) {
1830 my $schema_components = dump @schema_components;
1831 $schema_components = "($schema_components)" if @schema_components == 1;
1833 $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1836 if ($self->use_namespaces) {
1837 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1838 my $namespace_options;
1840 my @attr = qw/resultset_namespace default_resultset_class/;
1842 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1844 for my $attr (@attr) {
1846 my $code = dumper_squashed $self->$attr;
1847 $namespace_options .= qq| $attr => $code,\n|
1850 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1851 $schema_text .= qq|;\n|;
1854 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1858 local $self->{version_to_dump} = $self->schema_version_to_dump;
1859 $self->_write_classfile($schema_class, $schema_text, 1);
1862 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1864 foreach my $src_class (@classes) {
1867 . qq|package $src_class;\n\n|
1868 . qq|# Created by DBIx::Class::Schema::Loader\n|
1869 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1871 $src_text .= $self->_make_pod_heading($src_class);
1873 $src_text .= qq|use strict;\nuse warnings;\n\n|;
1875 $src_text .= $self->_base_class_pod($result_base_class)
1876 unless $result_base_class eq 'DBIx::Class::Core';
1878 if ($self->use_moose) {
1879 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse $autoclean;|;
1881 # these options 'use base' which is compile time
1882 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1883 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1886 $src_text .= qq|\nextends '$result_base_class';\n|;
1890 $src_text .= qq|use base '$result_base_class';\n|;
1893 $self->_write_classfile($src_class, $src_text);
1896 # remove Result dir if downgrading from use_namespaces, and there are no
1898 if (my $result_ns = $self->_downgrading_to_load_classes
1899 || $self->_rewriting_result_namespace) {
1900 my $result_namespace = $self->_result_namespace(
1905 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1906 $result_dir = $self->dump_directory . '/' . $result_dir;
1908 unless (my @files = glob "$result_dir/*") {
1913 warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
1917 my ($self, $version, $ts) = @_;
1918 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1921 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1924 sub _write_classfile {
1925 my ($self, $class, $text, $is_schema) = @_;
1927 my $filename = $self->_get_dump_filename($class);
1928 $self->_ensure_dump_subdirs($class);
1930 if (-f $filename && $self->really_erase_my_files) {
1931 warn "Deleting existing file '$filename' due to "
1932 . "'really_erase_my_files' setting\n" unless $self->quiet;
1936 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1937 = $self->_parse_generated_file($filename);
1939 if (! $old_gen && -f $filename) {
1940 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1941 . " it does not appear to have been generated by Loader"
1944 my $custom_content = $old_custom || '';
1946 # Use custom content from a renamed class, the class names in it are
1948 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1949 my $old_filename = $self->_get_dump_filename($renamed_class);
1951 if (-f $old_filename) {
1952 $custom_content = ($self->_parse_generated_file ($old_filename))[4];
1954 unlink $old_filename;
1958 $custom_content ||= $self->_default_custom_content($is_schema);
1960 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1961 # If there is already custom content, which does not have the Moose content, add it.
1962 if ($self->use_moose) {
1964 my $non_moose_custom_content = do {
1965 local $self->{use_moose} = 0;
1966 $self->_default_custom_content;
1969 if ($custom_content eq $non_moose_custom_content) {
1970 $custom_content = $self->_default_custom_content($is_schema);
1972 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1973 $custom_content .= $self->_default_custom_content($is_schema);
1976 elsif (defined $self->use_moose && $old_gen) {
1977 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'
1978 if $old_gen =~ /use \s+ MooseX?\b/x;
1981 $custom_content = $self->_rewrite_old_classnames($custom_content);
1984 for @{$self->{_dump_storage}->{$class} || []};
1986 if ($self->filter_generated_code) {
1987 my $filter = $self->filter_generated_code;
1989 if (ref $filter eq 'CODE') {
1991 ($is_schema ? 'schema' : 'result'),
1997 my ($fh, $temp_file) = tempfile();
1999 binmode $fh, ':encoding(UTF-8)';
2003 open my $out, qq{$filter < "$temp_file"|}
2004 or croak "Could not open pipe to $filter: $!";
2006 $text = decode('UTF-8', do { local $/; <$out> });
2008 $text =~ s/$CR?$LF/\n/g;
2012 my $exit_code = $? >> 8;
2015 or croak "Could not remove temporary file '$temp_file': $!";
2017 if ($exit_code != 0) {
2018 croak "filter '$filter' exited non-zero: $exit_code";
2021 if (not $text or not $text =~ /\bpackage\b/) {
2022 warn("$class skipped due to filter") if $self->debug;
2027 # Check and see if the dump is in fact different
2031 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
2032 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
2033 return unless $self->_upgrading_from && $is_schema;
2037 $text .= $self->_sig_comment(
2038 $self->version_to_dump,
2039 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
2042 open(my $fh, '>:encoding(UTF-8)', $filename)
2043 or croak "Cannot open '$filename' for writing: $!";
2045 # Write the top half and its MD5 sum
2046 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
2048 # Write out anything loaded via external partial class file in @INC
2050 for @{$self->{_ext_storage}->{$class} || []};
2052 # Write out any custom content the user has added
2053 print $fh $custom_content;
2056 or croak "Error closing '$filename': $!";
2059 sub _default_moose_custom_content {
2060 my ($self, $is_schema) = @_;
2062 if (not $is_schema) {
2063 return qq|\n__PACKAGE__->meta->make_immutable;|;
2066 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
2069 sub _default_custom_content {
2070 my ($self, $is_schema) = @_;
2071 my $default = qq|\n\n# You can replace this text with custom|
2072 . qq| code or comments, and it will be preserved on regeneration|;
2073 if ($self->use_moose) {
2074 $default .= $self->_default_moose_custom_content($is_schema);
2076 $default .= qq|\n1;\n|;
2080 sub _parse_generated_file {
2081 my ($self, $fn) = @_;
2083 return unless -f $fn;
2085 open(my $fh, '<:encoding(UTF-8)', $fn)
2086 or croak "Cannot open '$fn' for reading: $!";
2089 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
2091 my ($md5, $ts, $ver, $gen);
2097 # Pull out the version and timestamp from the line above
2098 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m;
2101 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"
2102 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
2111 my $custom = do { local $/; <$fh> }
2115 $custom =~ s/$CRLF|$LF/\n/g;
2119 return ($gen, $md5, $ver, $ts, $custom);
2127 warn "$target: use $_;" if $self->debug;
2128 $self->_raw_stmt($target, "use $_;");
2136 my $blist = join(q{ }, @_);
2138 return unless $blist;
2140 warn "$target: use base qw/$blist/;" if $self->debug;
2141 $self->_raw_stmt($target, "use base qw/$blist/;");
2148 my $rlist = join(q{, }, map { qq{'$_'} } @_);
2150 return unless $rlist;
2152 warn "$target: with $rlist;" if $self->debug;
2153 $self->_raw_stmt($target, "\nwith $rlist;");
2156 sub _result_namespace {
2157 my ($self, $schema_class, $ns) = @_;
2158 my @result_namespace;
2160 $ns = $ns->[0] if ref $ns;
2162 if ($ns =~ /^\+(.*)/) {
2163 # Fully qualified namespace
2164 @result_namespace = ($1)
2167 # Relative namespace
2168 @result_namespace = ($schema_class, $ns);
2171 return wantarray ? @result_namespace : join '::', @result_namespace;
2174 # Create class with applicable bases, setup monikers, etc
2175 sub _make_src_class {
2176 my ($self, $table) = @_;
2178 my $schema = $self->schema;
2179 my $schema_class = $self->schema_class;
2181 my $table_moniker = $self->monikers->{$table->sql_name};
2182 my @result_namespace = ($schema_class);
2183 if ($self->use_namespaces) {
2184 my $result_namespace = $self->result_namespace || 'Result';
2185 @result_namespace = $self->_result_namespace(
2190 my $table_class = join(q{::}, @result_namespace, $table_moniker);
2192 if ((my $upgrading_v = $self->_upgrading_from)
2193 || $self->_rewriting) {
2194 local $self->naming->{monikers} = $upgrading_v
2197 my @result_namespace = @result_namespace;
2198 if ($self->_upgrading_from_load_classes) {
2199 @result_namespace = ($schema_class);
2201 elsif (my $ns = $self->_downgrading_to_load_classes) {
2202 @result_namespace = $self->_result_namespace(
2207 elsif ($ns = $self->_rewriting_result_namespace) {
2208 @result_namespace = $self->_result_namespace(
2214 my $old_table_moniker = do {
2215 local $self->naming->{monikers} = $upgrading_v;
2216 $self->_table2moniker($table);
2219 my $old_class = join(q{::}, @result_namespace, $old_table_moniker);
2221 $self->_upgrading_classes->{$table_class} = $old_class
2222 unless $table_class eq $old_class;
2225 $self->classes->{$table->sql_name} = $table_class;
2226 $self->moniker_to_table->{$table_moniker} = $table;
2227 $self->class_to_table->{$table_class} = $table;
2229 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
2231 $self->_use ($table_class, @{$self->additional_classes});
2233 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
2235 $self->_inject($table_class, @{$self->left_base_classes});
2237 my @components = @{ $self->components || [] };
2239 push @components, @{ $self->result_components_map->{$table_moniker} }
2240 if exists $self->result_components_map->{$table_moniker};
2242 my @fq_components = @components;
2243 foreach my $component (@fq_components) {
2244 if ($component !~ s/^\+//) {
2245 $component = "DBIx::Class::$component";
2249 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
2251 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
2253 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
2255 $self->_inject($table_class, @{$self->additional_base_classes});
2258 sub _is_result_class_method {
2259 my ($self, $name, $table) = @_;
2261 my $table_moniker = $table ? $self->monikers->{$table->sql_name} : '';
2263 $self->_result_class_methods({})
2264 if not defined $self->_result_class_methods;
2266 if (not exists $self->_result_class_methods->{$table_moniker}) {
2267 my (@methods, %methods);
2268 my $base = $self->result_base_class || 'DBIx::Class::Core';
2270 my @components = @{ $self->components || [] };
2272 push @components, @{ $self->result_components_map->{$table_moniker} }
2273 if exists $self->result_components_map->{$table_moniker};
2275 for my $c (@components) {
2276 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
2279 my @roles = @{ $self->result_roles || [] };
2281 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2282 if exists $self->result_roles_map->{$table_moniker};
2284 for my $class ($base, @components,
2285 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
2286 $self->ensure_class_loaded($class);
2288 push @methods, @{ Class::Inspector->methods($class) || [] };
2291 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
2293 @methods{@methods} = ();
2295 $self->_result_class_methods->{$table_moniker} = \%methods;
2297 my $result_methods = $self->_result_class_methods->{$table_moniker};
2299 return exists $result_methods->{$name};
2302 sub _resolve_col_accessor_collisions {
2303 my ($self, $table, $col_info) = @_;
2305 while (my ($col, $info) = each %$col_info) {
2306 my $accessor = $info->{accessor} || $col;
2308 next if $accessor eq 'id'; # special case (very common column)
2310 if ($self->_is_result_class_method($accessor, $table)) {
2313 if (my $map = $self->col_collision_map) {
2314 for my $re (keys %$map) {
2315 if (my @matches = $col =~ /$re/) {
2316 $info->{accessor} = sprintf $map->{$re}, @matches;
2324 Column '$col' in table '$table' collides with an inherited method.
2325 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
2327 $info->{accessor} = undef;
2333 # use the same logic to run moniker_map, col_accessor_map
2335 my ( $self, $map, $default_code, $ident, @extra ) = @_;
2337 my $default_ident = $default_code->( $ident, @extra );
2339 if( $map && ref $map eq 'HASH' ) {
2340 $new_ident = $map->{ $ident };
2342 elsif( $map && ref $map eq 'CODE' ) {
2343 $new_ident = $map->( $ident, $default_ident, @extra );
2346 $new_ident ||= $default_ident;
2351 sub _default_column_accessor_name {
2352 my ( $self, $column_name ) = @_;
2354 my $preserve = ($self->naming->{column_accessors}||'') eq 'preserve';
2356 my $v = $self->_get_naming_v('column_accessors');
2358 my $accessor_name = $preserve ?
2359 $self->_to_identifier('column_accessors', $column_name) # assume CamelCase
2361 $self->_to_identifier('column_accessors', $column_name, '_');
2363 $accessor_name =~ s/\W+/_/g; # only if naming < v8, otherwise to_identifier
2367 return $accessor_name;
2369 elsif ($v < 7 || (not $self->preserve_case)) {
2370 # older naming just lc'd the col accessor and that's all.
2371 return lc $accessor_name;
2374 return join '_', map lc, split_name $column_name, $v;
2377 sub _make_column_accessor_name {
2378 my ($self, $column_name, $column_context_info ) = @_;
2380 my $accessor = $self->_run_user_map(
2381 $self->col_accessor_map,
2382 sub { $self->_default_column_accessor_name( shift ) },
2384 $column_context_info,
2390 # Set up metadata (cols, pks, etc)
2391 sub _setup_src_meta {
2392 my ($self, $table) = @_;
2394 my $schema = $self->schema;
2395 my $schema_class = $self->schema_class;
2397 my $table_class = $self->classes->{$table->sql_name};
2398 my $table_moniker = $self->monikers->{$table->sql_name};
2400 $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
2402 my $cols = $self->_table_columns($table);
2403 my $col_info = $self->__columns_info_for($table);
2405 ### generate all the column accessor names
2406 while (my ($col, $info) = each %$col_info) {
2407 # hashref of other info that could be used by
2408 # user-defined accessor map functions
2410 table_class => $table_class,
2411 table_moniker => $table_moniker,
2412 table_name => $table,
2413 full_table_name => $table->dbic_name,
2414 schema_class => $schema_class,
2415 column_info => $info,
2418 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2421 $self->_resolve_col_accessor_collisions($table, $col_info);
2423 # prune any redundant accessor names
2424 while (my ($col, $info) = each %$col_info) {
2425 no warnings 'uninitialized';
2426 delete $info->{accessor} if $info->{accessor} eq $col;
2429 my $fks = $self->_table_fk_info($table);
2431 foreach my $fkdef (@$fks) {
2432 for my $col (@{ $fkdef->{local_columns} }) {
2433 $col_info->{$col}{is_foreign_key} = 1;
2437 my $pks = $self->_table_pk_info($table) || [];
2439 my %uniq_tag; # used to eliminate duplicate uniqs
2441 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2443 my $uniqs = $self->_table_uniq_info($table) || [];
2446 foreach my $uniq (@$uniqs) {
2447 my ($name, $cols) = @$uniq;
2448 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2449 push @uniqs, [$name, $cols];
2452 my @non_nullable_uniqs = grep {
2453 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2456 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2457 my @by_colnum = sort { $b->[0] <=> $a->[0] }
2458 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2460 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2461 my @keys = map $_->[1], @by_colnum;
2465 # remove the uniq from list
2466 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2472 foreach my $pkcol (@$pks) {
2473 $col_info->{$pkcol}{is_nullable} = 0;
2479 map { $_, ($col_info->{$_}||{}) } @$cols
2482 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2485 # Sort unique constraints by constraint name for repeatable results (rels
2486 # are sorted as well elsewhere.)
2487 @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs;
2489 foreach my $uniq (@uniqs) {
2490 my ($name, $cols) = @$uniq;
2491 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2495 sub __columns_info_for {
2496 my ($self, $table) = @_;
2498 my $result = $self->_columns_info_for($table);
2500 while (my ($col, $info) = each %$result) {
2501 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
2502 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2504 $result->{$col} = $info;
2512 Returns a sorted list of loaded tables, using the original database table
2520 return values %{$self->_tables};
2524 my ($self, $naming_key) = @_;
2528 if (($self->naming->{$naming_key}||'') =~ /^v(\d+)\z/) {
2532 ($v) = $CURRENT_V =~ /^v(\d+)\z/;
2538 sub _to_identifier {
2539 my ($self, $naming_key, $name, $sep_char, $force) = @_;
2541 my $v = $self->_get_naming_v($naming_key);
2543 my $to_identifier = $self->naming->{force_ascii} ?
2544 \&String::ToIdentifier::EN::to_identifier
2545 : \&String::ToIdentifier::EN::Unicode::to_identifier;
2547 return $v >= 8 || $force ? $to_identifier->($name, $sep_char) : $name;
2550 # Make a moniker from a table
2551 sub _default_table2moniker {
2552 my ($self, $table) = @_;
2554 my $v = $self->_get_naming_v('monikers');
2556 my @name_parts = map $table->$_, @{ $self->moniker_parts };
2558 my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
2562 foreach my $i (0 .. $#name_parts) {
2563 my $part = $name_parts[$i];
2565 if ($i != $name_idx || $v >= 8) {
2566 $part = $self->_to_identifier('monikers', $part, '_', 1);
2569 if ($i == $name_idx && $v == 5) {
2570 $part = Lingua::EN::Inflect::Number::to_S($part);
2573 my @part_parts = map lc, $v > 6 ?
2574 # use v8 semantics for all moniker parts except name
2575 ($i == $name_idx ? split_name $part, $v : split_name $part)
2576 : split /[\W_]+/, $part;
2578 if ($i == $name_idx && $v >= 6) {
2579 my $as_phrase = join ' ', @part_parts;
2581 my $inflected = ($self->naming->{monikers}||'') eq 'plural' ?
2582 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2584 ($self->naming->{monikers}||'') eq 'preserve' ?
2587 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2589 @part_parts = split /\s+/, $inflected;
2592 push @all_parts, map ucfirst, @part_parts;
2595 return join '', @all_parts;
2598 sub _table2moniker {
2599 my ( $self, $table ) = @_;
2601 $self->_run_user_map(
2603 sub { $self->_default_table2moniker( shift ) },
2608 sub _load_relationships {
2609 my ($self, $tables) = @_;
2613 foreach my $table (@$tables) {
2614 my $local_moniker = $self->monikers->{$table->sql_name};
2616 my $tbl_fk_info = $self->_table_fk_info($table);
2618 foreach my $fkdef (@$tbl_fk_info) {
2619 $fkdef->{local_table} = $table;
2620 $fkdef->{local_moniker} = $local_moniker;
2621 $fkdef->{remote_source} =
2622 $self->monikers->{$fkdef->{remote_table}->sql_name};
2624 my $tbl_uniq_info = $self->_table_uniq_info($table);
2626 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2629 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2631 foreach my $src_class (sort keys %$rel_stmts) {
2633 my @src_stmts = map $_->[2],
2639 ($_->{method} eq 'many_to_many' ? 1 : 0),
2642 ], @{ $rel_stmts->{$src_class} };
2644 foreach my $stmt (@src_stmts) {
2645 $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2651 my ($self, $table) = @_;
2653 my $table_moniker = $self->monikers->{$table->sql_name};
2654 my $table_class = $self->classes->{$table->sql_name};
2656 my @roles = @{ $self->result_roles || [] };
2657 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2658 if exists $self->result_roles_map->{$table_moniker};
2661 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2663 $self->_with($table_class, @roles);
2667 # Overload these in driver class:
2669 # Returns an arrayref of column names
2670 sub _table_columns { croak "ABSTRACT METHOD" }
2672 # Returns arrayref of pk col names
2673 sub _table_pk_info { croak "ABSTRACT METHOD" }
2675 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2676 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2678 # Returns an arrayref of foreign key constraints, each
2679 # being a hashref with 3 keys:
2680 # local_columns (arrayref), remote_columns (arrayref), remote_table
2681 sub _table_fk_info { croak "ABSTRACT METHOD" }
2683 # Returns an array of lower case table names
2684 sub _tables_list { croak "ABSTRACT METHOD" }
2686 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2692 # generate the pod for this statement, storing it with $self->_pod
2693 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2695 my $args = dump(@_);
2696 $args = '(' . $args . ')' if @_ < 2;
2697 my $stmt = $method . $args . q{;};
2699 warn qq|$class\->$stmt\n| if $self->debug;
2700 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2704 sub _make_pod_heading {
2705 my ($self, $class) = @_;
2707 return '' if not $self->generate_pod;
2709 my $table = $self->class_to_table->{$class};
2712 my $pcm = $self->pod_comment_mode;
2713 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2714 $comment = $self->__table_comment($table);
2715 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2716 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2717 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2719 $pod .= "=head1 NAME\n\n";
2721 my $table_descr = $class;
2722 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2724 $pod .= "$table_descr\n\n";
2726 if ($comment and $comment_in_desc) {
2727 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2734 # generates the accompanying pod for a DBIC class method statement,
2735 # storing it with $self->_pod
2741 if ($method eq 'table') {
2743 $table = $$table if ref $table eq 'SCALAR';
2744 $self->_pod($class, "=head1 TABLE: C<$table>");
2745 $self->_pod_cut($class);
2747 elsif ( $method eq 'add_columns' ) {
2748 $self->_pod( $class, "=head1 ACCESSORS" );
2749 my $col_counter = 0;
2751 while( my ($name,$attrs) = splice @cols,0,2 ) {
2753 $self->_pod( $class, '=head2 ' . $name );
2754 $self->_pod( $class,
2756 my $s = $attrs->{$_};
2757 $s = !defined $s ? 'undef' :
2758 length($s) == 0 ? '(empty string)' :
2759 ref($s) eq 'SCALAR' ? $$s :
2760 ref($s) ? dumper_squashed $s :
2761 looks_like_number($s) ? $s : qq{'$s'};
2764 } sort keys %$attrs,
2766 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2767 $self->_pod( $class, $comment );
2770 $self->_pod_cut( $class );
2771 } elsif ( $method =~ /^(?:belongs_to|has_many|might_have)\z/ ) {
2772 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2773 my ( $accessor, $rel_class ) = @_;
2774 $self->_pod( $class, "=head2 $accessor" );
2775 $self->_pod( $class, 'Type: ' . $method );
2776 $self->_pod( $class, "Related object: L<$rel_class>" );
2777 $self->_pod_cut( $class );
2778 $self->{_relations_started} { $class } = 1;
2779 } elsif ( $method eq 'many_to_many' ) {
2780 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2781 my ( $accessor, $rel1, $rel2 ) = @_;
2782 $self->_pod( $class, "=head2 $accessor" );
2783 $self->_pod( $class, 'Type: many_to_many' );
2784 $self->_pod( $class, "Composing rels: L</$rel1> -> $rel2" );
2785 $self->_pod_cut( $class );
2786 $self->{_relations_started} { $class } = 1;
2788 elsif ($method eq 'add_unique_constraint') {
2789 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2790 unless $self->{_uniqs_started}{$class};
2792 my ($name, $cols) = @_;
2794 $self->_pod($class, "=head2 C<$name>");
2795 $self->_pod($class, '=over 4');
2797 foreach my $col (@$cols) {
2798 $self->_pod($class, "=item \* L</$col>");
2801 $self->_pod($class, '=back');
2802 $self->_pod_cut($class);
2804 $self->{_uniqs_started}{$class} = 1;
2806 elsif ($method eq 'set_primary_key') {
2807 $self->_pod($class, "=head1 PRIMARY KEY");
2808 $self->_pod($class, '=over 4');
2810 foreach my $col (@_) {
2811 $self->_pod($class, "=item \* L</$col>");
2814 $self->_pod($class, '=back');
2815 $self->_pod_cut($class);
2819 sub _pod_class_list {
2820 my ($self, $class, $title, @classes) = @_;
2822 return unless @classes && $self->generate_pod;
2824 $self->_pod($class, "=head1 $title");
2825 $self->_pod($class, '=over 4');
2827 foreach my $link (@classes) {
2828 $self->_pod($class, "=item * L<$link>");
2831 $self->_pod($class, '=back');
2832 $self->_pod_cut($class);
2835 sub _base_class_pod {
2836 my ($self, $base_class) = @_;
2838 return '' unless $self->generate_pod;
2841 =head1 BASE CLASS: L<$base_class>
2848 sub _filter_comment {
2849 my ($self, $txt) = @_;
2851 $txt = '' if not defined $txt;
2853 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2858 sub __table_comment {
2861 if (my $code = $self->can('_table_comment')) {
2862 return $self->_filter_comment($self->$code(@_));
2868 sub __column_comment {
2871 if (my $code = $self->can('_column_comment')) {
2872 return $self->_filter_comment($self->$code(@_));
2878 # Stores a POD documentation
2880 my ($self, $class, $stmt) = @_;
2881 $self->_raw_stmt( $class, "\n" . $stmt );
2885 my ($self, $class ) = @_;
2886 $self->_raw_stmt( $class, "\n=cut\n" );
2889 # Store a raw source line for a class (for dumping purposes)
2891 my ($self, $class, $stmt) = @_;
2892 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2895 # Like above, but separately for the externally loaded stuff
2897 my ($self, $class, $stmt) = @_;
2898 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2901 sub _custom_column_info {
2902 my ( $self, $table_name, $column_name, $column_info ) = @_;
2904 if (my $code = $self->custom_column_info) {
2905 return $code->($table_name, $column_name, $column_info) || {};
2910 sub _datetime_column_info {
2911 my ( $self, $table_name, $column_name, $column_info ) = @_;
2913 my $type = $column_info->{data_type} || '';
2914 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2915 or ($type =~ /date|timestamp/i)) {
2916 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2917 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2923 my ($self, $name) = @_;
2925 return $self->preserve_case ? $name : lc($name);
2929 my ($self, $name) = @_;
2931 return $self->preserve_case ? $name : uc($name);
2935 my ($self, $table) = @_;
2938 my $schema = $self->schema;
2939 # in older DBIC it's a private method
2940 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2941 $schema->$unregister(delete $self->monikers->{$table->sql_name});
2942 delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}};
2943 delete $self->_tables->{$table->sql_name};
2947 # remove the dump dir from @INC on destruction
2951 @INC = grep $_ ne $self->dump_directory, @INC;
2956 Returns a hashref of loaded table to moniker mappings. There will
2957 be two entries for each table, the original name and the "normalized"
2958 name, in the case that the two are different (such as databases
2959 that like uppercase table names, or preserve your original mixed-case
2960 definitions, or what-have-you).
2964 Returns a hashref of table to class mappings. In some cases it will
2965 contain multiple entries per table for the original and normalized table
2966 names, as above in L</monikers>.
2968 =head1 NON-ENGLISH DATABASES
2970 If you use the loader on a database with table and column names in a language
2971 other than English, you will want to turn off the English language specific
2974 To do so, use something like this in your loader options:
2976 naming => { monikers => 'v4' },
2977 inflect_singular => sub { "$_[0]_rel" },
2978 inflect_plural => sub { "$_[0]_rel" },
2980 =head1 COLUMN ACCESSOR COLLISIONS
2982 Occasionally you may have a column name that collides with a perl method, such
2983 as C<can>. In such cases, the default action is to set the C<accessor> of the
2984 column spec to C<undef>.
2986 You can then name the accessor yourself by placing code such as the following
2989 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2991 Another option is to use the L</col_collision_map> option.
2993 =head1 RELATIONSHIP NAME COLLISIONS
2995 In very rare cases, you may get a collision between a generated relationship
2996 name and a method in your Result class, for example if you have a foreign key
2997 called C<belongs_to>.
2999 This is a problem because relationship names are also relationship accessor
3000 methods in L<DBIx::Class>.
3002 The default behavior is to append C<_rel> to the relationship name and print
3003 out a warning that refers to this text.
3005 You can also control the renaming with the L</rel_collision_map> option.
3009 L<DBIx::Class::Schema::Loader>, L<dbicdump>
3013 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
3017 This library is free software; you can redistribute it and/or modify it under
3018 the same terms as Perl itself.
3023 # vim:et sts=4 sw=4 tw=0: