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.07020';
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
384 by type. Also supports relationship type 'all', containing options to
385 pass to all generated relationships. Attributes set for more specific
386 relationship types override those set in 'all'.
390 relationship_attrs => {
391 belongs_to => { is_deferrable => 0 },
394 use this to turn off DEFERRABLE on your foreign key constraints.
398 If set to true, each constructive L<DBIx::Class> statement the loader
399 decides to execute will be C<warn>-ed before execution.
403 Set the name of the schema to load (schema in the sense that your database
406 Can be set to an arrayref of schema names for multiple schemas, or the special
407 value C<%> for all schemas.
409 For MSSQL, Sybase ASE, and Informix can be set to a hashref of databases as
410 keys and arrays of owners as values, set to the value:
414 for all owners in all databases.
416 Name clashes resulting from the same table name in different databases/schemas
417 will be resolved automatically by prefixing the moniker with the database
420 To prefix/suffix all monikers with the database and/or schema, see
425 The database table names are represented by the
426 L<DBIx::Class::Schema::Loader::Table> class in the loader, the
427 L<DBIx::Class::Schema::Loader::Table::Sybase> class for Sybase ASE and
428 L<DBIx::Class::Schema::Loader::Table::Informix> for Informix.
430 Monikers are created normally based on just the
431 L<name|DBIx::Class::Schema::Loader::DBObject/name> property, corresponding to
432 the table name, but can consist of other parts of the fully qualified name of
435 The L</moniker_parts> option is an arrayref of methods on the table class
436 corresponding to parts of the fully qualified table name, defaulting to
437 C<['name']>, in the order those parts are used to create the moniker name.
439 The C<'name'> entry B<must> be present.
441 Below is a table of supported databases and possible L</moniker_parts>.
445 =item * DB2, Firebird, mysql, Oracle, Pg, SQLAnywhere, SQLite, MS Access
449 =item * Informix, MSSQL, Sybase ASE
451 C<database>, C<schema>, C<name>
457 Only load tables matching regex. Best specified as a qr// regex.
461 Exclude tables matching regex. Best specified as a qr// regex.
465 Overrides the default table name to moniker translation. Can be either a
466 hashref of table keys and moniker values, or a coderef for a translator
467 function taking a L<table object|DBIx::Class::Schema::Loader::Table> argument
468 (which stringifies to the unqualified table name) and returning a scalar
469 moniker. If the hash entry does not exist, or the function returns a false
470 value, the code falls back to default behavior for that table name.
472 The default behavior is to split on case transition and non-alphanumeric
473 boundaries, singularize the resulting phrase, then join the titlecased words
476 Table Name | Moniker Name
477 ---------------------------------
479 luser_group | LuserGroup
480 luser-opts | LuserOpt
481 stations_visited | StationVisited
482 routeChange | RouteChange
484 =head2 col_accessor_map
486 Same as moniker_map, but for column accessor names. If a coderef is
487 passed, the code is called with arguments of
489 the name of the column in the underlying database,
490 default accessor name that DBICSL would ordinarily give this column,
492 table_class => name of the DBIC class we are building,
493 table_moniker => calculated moniker for this table (after moniker_map if present),
494 table => table object of interface DBIx::Class::Schema::Loader::Table,
495 full_table_name => schema-qualified name of the database table (RDBMS specific),
496 schema_class => name of the schema class we are building,
497 column_info => hashref of column info (data_type, is_nullable, etc),
500 the L<table object|DBIx::Class::Schema::Loader::Table> stringifies to the
501 unqualified table name.
505 Similar in idea to moniker_map, but different in the details. It can be
506 a hashref or a code ref.
508 If it is a hashref, keys can be either the default relationship name, or the
509 moniker. The keys that are the default relationship name should map to the
510 name you want to change the relationship to. Keys that are monikers should map
511 to hashes mapping relationship names to their translation. You can do both at
512 once, and the more specific moniker version will be picked up first. So, for
513 instance, you could have
522 and relationships that would have been named C<bar> will now be named C<baz>
523 except that in the table whose moniker is C<Foo> it will be named C<blat>.
525 If it is a coderef, the argument passed will be a hashref of this form:
528 name => default relationship name,
529 type => the relationship type eg: C<has_many>,
530 local_class => name of the DBIC class we are building,
531 local_moniker => moniker of the DBIC class we are building,
532 local_columns => columns in this table in the relationship,
533 remote_class => name of the DBIC class we are related to,
534 remote_moniker => moniker of the DBIC class we are related to,
535 remote_columns => columns in the other table in the relationship,
538 DBICSL will try to use the value returned as the relationship name.
540 =head2 inflect_plural
542 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
543 if hash key does not exist or coderef returns false), but acts as a map
544 for pluralizing relationship names. The default behavior is to utilize
545 L<Lingua::EN::Inflect::Phrase/to_PL>.
547 =head2 inflect_singular
549 As L</inflect_plural> above, but for singularizing relationship names.
550 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
552 =head2 schema_base_class
554 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
556 =head2 schema_components
558 List of components to load into the Schema class.
560 =head2 result_base_class
562 Base class for your table classes (aka result classes). Defaults to
565 =head2 additional_base_classes
567 List of additional base classes all of your table classes will use.
569 =head2 left_base_classes
571 List of additional base classes all of your table classes will use
572 that need to be leftmost.
574 =head2 additional_classes
576 List of additional classes which all of your table classes will use.
580 List of additional components to be loaded into all of your Result
581 classes. A good example would be
582 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
584 =head2 result_components_map
586 A hashref of moniker keys and component values. Unlike L</components>, which
587 loads the given components into every Result class, this option allows you to
588 load certain components for specified Result classes. For example:
590 result_components_map => {
591 StationVisited => '+YourApp::Schema::Component::StationVisited',
593 '+YourApp::Schema::Component::RouteChange',
594 'InflateColumn::DateTime',
598 You may use this in conjunction with L</components>.
602 List of L<Moose> roles to be applied to all of your Result classes.
604 =head2 result_roles_map
606 A hashref of moniker keys and role values. Unlike L</result_roles>, which
607 applies the given roles to every Result class, this option allows you to apply
608 certain roles for specified Result classes. For example:
610 result_roles_map => {
612 'YourApp::Role::Building',
613 'YourApp::Role::Destination',
615 RouteChange => 'YourApp::Role::TripEvent',
618 You may use this in conjunction with L</result_roles>.
620 =head2 use_namespaces
622 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
625 Generate result class names suitable for
626 L<DBIx::Class::Schema/load_namespaces> and call that instead of
627 L<DBIx::Class::Schema/load_classes>. When using this option you can also
628 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
629 C<resultset_namespace>, C<default_resultset_class>), and they will be added
630 to the call (and the generated result class names adjusted appropriately).
632 =head2 dump_directory
634 The value of this option is a perl libdir pathname. Within
635 that directory this module will create a baseline manual
636 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
638 The created schema class will have the same classname as the one on
639 which you are setting this option (and the ResultSource classes will be
640 based on this name as well).
642 Normally you wouldn't hard-code this setting in your schema class, as it
643 is meant for one-time manual usage.
645 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
646 recommended way to access this functionality.
648 =head2 dump_overwrite
650 Deprecated. See L</really_erase_my_files> below, which does *not* mean
651 the same thing as the old C<dump_overwrite> setting from previous releases.
653 =head2 really_erase_my_files
655 Default false. If true, Loader will unconditionally delete any existing
656 files before creating the new ones from scratch when dumping a schema to disk.
658 The default behavior is instead to only replace the top portion of the
659 file, up to and including the final stanza which contains
660 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
661 leaving any customizations you placed after that as they were.
663 When C<really_erase_my_files> is not set, if the output file already exists,
664 but the aforementioned final stanza is not found, or the checksum
665 contained there does not match the generated contents, Loader will
666 croak and not touch the file.
668 You should really be using version control on your schema classes (and all
669 of the rest of your code for that matter). Don't blame me if a bug in this
670 code wipes something out when it shouldn't have, you've been warned.
672 =head2 overwrite_modifications
674 Default false. If false, when updating existing files, Loader will
675 refuse to modify any Loader-generated code that has been modified
676 since its last run (as determined by the checksum Loader put in its
679 If true, Loader will discard any manual modifications that have been
680 made to Loader-generated code.
682 Again, you should be using version control on your schema classes. Be
683 careful with this option.
685 =head2 custom_column_info
687 Hook for adding extra attributes to the
688 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
690 Must be a coderef that returns a hashref with the extra attributes.
692 Receives the L<table object|DBIx::Class::Schema::Loader::Table> (which
693 stringifies to the unqualified table name), column name and column_info.
697 custom_column_info => sub {
698 my ($table, $column_name, $column_info) = @_;
700 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
701 return { is_snoopy => 1 };
705 This attribute can also be used to set C<inflate_datetime> on a non-datetime
706 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
708 =head2 datetime_timezone
710 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
711 columns with the DATE/DATETIME/TIMESTAMP data_types.
713 =head2 datetime_locale
715 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
716 columns with the DATE/DATETIME/TIMESTAMP data_types.
718 =head2 datetime_undef_if_invalid
720 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
721 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
724 The default is recommended to deal with data such as C<00/00/00> which
725 sometimes ends up in such columns in MySQL.
729 File in Perl format, which should return a HASH reference, from which to read
734 Normally database names are lowercased and split by underscore, use this option
735 if you have CamelCase database names.
737 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
738 case-sensitive collation will turn this option on unconditionally.
740 B<NOTE:> L</naming> = C<v8> is highly recommended with this option as the
741 semantics of this mode are much improved for CamelCase database names.
743 L</naming> = C<v7> or greater is required with this option.
745 =head2 qualify_objects
747 Set to true to prepend the L</db_schema> to table names for C<<
748 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
750 This attribute is automatically set to true for multi db_schema configurations.
754 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
755 L<MooseX::MarkAsMethods> (or L<namespace::autoclean>, see below). The default
756 content after the md5 sum also makes the classes immutable.
758 It is safe to upgrade your existing Schema to this option.
760 =head2 only_autoclean
762 By default, we use L<MooseX::MarkAsMethods> to remove imported functions from
763 your generated classes. It uses L<namespace::autoclean> to do this, after
764 telling your object's metaclass that any operator L<overload>s in your class
765 are methods, which will cause namespace::autoclean to spare them from removal.
767 This prevents the "Hey, where'd my overloads go?!" effect.
769 If you don't care about operator overloads, enabling this option falls back to
770 just using L<namespace::autoclean> itself.
772 If none of the above made any sense, or you don't have some pressing need to
773 only use L<namespace::autoclean>, leaving this set to the default is
776 =head2 col_collision_map
778 This option controls how accessors for column names which collide with perl
779 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
781 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
782 strings which are compiled to regular expressions that map to
783 L<sprintf|perlfunc/sprintf> formats.
787 col_collision_map => 'column_%s'
789 col_collision_map => { '(.*)' => 'column_%s' }
791 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
793 =head2 rel_collision_map
795 Works just like L</col_collision_map>, but for relationship names/accessors
796 rather than column names/accessors.
798 The default is to just append C<_rel> to the relationship name, see
799 L</RELATIONSHIP NAME COLLISIONS>.
801 =head2 uniq_to_primary
803 Automatically promotes the largest unique constraints with non-nullable columns
804 on tables to primary keys, assuming there is only one largest unique
807 =head2 filter_generated_code
809 An optional hook that lets you filter the generated text for various classes
810 through a function that change it in any way that you want. The function will
811 receive the type of file, C<schema> or C<result>, class and code; and returns
812 the new code to use instead. For instance you could add custom comments, or do
813 anything else that you want.
815 The option can also be set to a string, which is then used as a filter program,
818 If this exists but fails to return text matching C</\bpackage\b/>, no file will
821 filter_generated_code => sub {
822 my ($type, $class, $text) = @_;
829 None of these methods are intended for direct invocation by regular
830 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
831 L<DBIx::Class::Schema::Loader>.
835 # ensure that a peice of object data is a valid arrayref, creating
836 # an empty one or encapsulating whatever's there.
837 sub _ensure_arrayref {
842 $self->{$_} = [ $self->{$_} ]
843 unless ref $self->{$_} eq 'ARRAY';
849 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
850 by L<DBIx::Class::Schema::Loader>.
855 my ( $class, %args ) = @_;
857 if (exists $args{column_accessor_map}) {
858 $args{col_accessor_map} = delete $args{column_accessor_map};
861 my $self = { %args };
863 # don't lose undef options
864 for (values %$self) {
865 $_ = 0 unless defined $_;
868 bless $self => $class;
870 if (my $config_file = $self->config_file) {
871 my $config_opts = do $config_file;
873 croak "Error reading config from $config_file: $@" if $@;
875 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
877 while (my ($k, $v) = each %$config_opts) {
878 $self->{$k} = $v unless exists $self->{$k};
882 if (defined $self->{result_component_map}) {
883 if (defined $self->result_components_map) {
884 croak "Specify only one of result_components_map or result_component_map";
886 $self->result_components_map($self->{result_component_map})
889 if (defined $self->{result_role_map}) {
890 if (defined $self->result_roles_map) {
891 croak "Specify only one of result_roles_map or result_role_map";
893 $self->result_roles_map($self->{result_role_map})
896 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
897 if ((not defined $self->use_moose) || (not $self->use_moose))
898 && ((defined $self->result_roles) || (defined $self->result_roles_map));
900 $self->_ensure_arrayref(qw/schema_components
902 additional_base_classes
908 $self->_validate_class_args;
910 croak "result_components_map must be a hash"
911 if defined $self->result_components_map
912 && ref $self->result_components_map ne 'HASH';
914 if ($self->result_components_map) {
915 my %rc_map = %{ $self->result_components_map };
916 foreach my $moniker (keys %rc_map) {
917 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
919 $self->result_components_map(\%rc_map);
922 $self->result_components_map({});
924 $self->_validate_result_components_map;
926 croak "result_roles_map must be a hash"
927 if defined $self->result_roles_map
928 && ref $self->result_roles_map ne 'HASH';
930 if ($self->result_roles_map) {
931 my %rr_map = %{ $self->result_roles_map };
932 foreach my $moniker (keys %rr_map) {
933 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
935 $self->result_roles_map(\%rr_map);
937 $self->result_roles_map({});
939 $self->_validate_result_roles_map;
941 if ($self->use_moose) {
942 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
943 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
944 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
948 $self->{_tables} = {};
949 $self->{monikers} = {};
950 $self->{moniker_to_table} = {};
951 $self->{class_to_table} = {};
952 $self->{classes} = {};
953 $self->{_upgrading_classes} = {};
955 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
956 $self->{schema} ||= $self->{schema_class};
957 $self->{table_comments_table} ||= 'table_comments';
958 $self->{column_comments_table} ||= 'column_comments';
960 croak "dump_overwrite is deprecated. Please read the"
961 . " DBIx::Class::Schema::Loader::Base documentation"
962 if $self->{dump_overwrite};
964 $self->{dynamic} = ! $self->{dump_directory};
965 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
970 $self->{dump_directory} ||= $self->{temp_directory};
972 $self->real_dump_directory($self->{dump_directory});
974 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
975 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
977 if (not defined $self->naming) {
978 $self->naming_set(0);
981 $self->naming_set(1);
984 if ((not ref $self->naming) && defined $self->naming) {
985 my $naming_ver = $self->naming;
987 relationships => $naming_ver,
988 monikers => $naming_ver,
989 column_accessors => $naming_ver,
992 elsif (ref $self->naming eq 'HASH' && exists $self->naming->{ALL}) {
993 my $val = delete $self->naming->{ALL};
995 $self->naming->{$_} = $val
996 foreach qw/relationships monikers column_accessors/;
1000 foreach my $key (qw/relationships monikers column_accessors/) {
1001 $self->naming->{$key} = $CURRENT_V if ($self->naming->{$key}||'') eq 'current';
1004 $self->{naming} ||= {};
1006 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
1007 croak 'custom_column_info must be a CODE ref';
1010 $self->_check_back_compat;
1012 $self->use_namespaces(1) unless defined $self->use_namespaces;
1013 $self->generate_pod(1) unless defined $self->generate_pod;
1014 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
1015 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
1017 if (my $col_collision_map = $self->col_collision_map) {
1018 if (my $reftype = ref $col_collision_map) {
1019 if ($reftype ne 'HASH') {
1020 croak "Invalid type $reftype for option 'col_collision_map'";
1024 $self->col_collision_map({ '(.*)' => $col_collision_map });
1028 if (my $rel_collision_map = $self->rel_collision_map) {
1029 if (my $reftype = ref $rel_collision_map) {
1030 if ($reftype ne 'HASH') {
1031 croak "Invalid type $reftype for option 'rel_collision_map'";
1035 $self->rel_collision_map({ '(.*)' => $rel_collision_map });
1039 if (defined(my $rel_name_map = $self->rel_name_map)) {
1040 my $reftype = ref $rel_name_map;
1041 if ($reftype ne 'HASH' && $reftype ne 'CODE') {
1042 croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
1046 if (defined(my $filter = $self->filter_generated_code)) {
1047 my $reftype = ref $filter;
1048 if ($reftype && $reftype ne 'CODE') {
1049 croak "Invalid type $reftype for option 'filter_generated_code, must be a scalar or a CODE reference";
1053 if (defined $self->db_schema) {
1054 if (ref $self->db_schema eq 'ARRAY') {
1055 if (@{ $self->db_schema } > 1) {
1056 $self->{qualify_objects} = 1;
1058 elsif (@{ $self->db_schema } == 0) {
1059 $self->{db_schema} = undef;
1062 elsif (not ref $self->db_schema) {
1063 if ($self->db_schema eq '%') {
1064 $self->{qualify_objects} = 1;
1067 $self->{db_schema} = [ $self->db_schema ];
1071 if (not $self->moniker_parts) {
1072 $self->moniker_parts(['name']);
1075 if (not ref $self->moniker_parts) {
1076 $self->moniker_parts([ $self->moniker_parts ]);
1078 if (ref $self->moniker_parts ne 'ARRAY') {
1079 croak 'moniker_parts must be an arrayref';
1081 if ((firstidx { $_ eq 'name' } @{ $self->moniker_parts }) == -1) {
1082 croak "moniker_parts option *must* contain 'name'";
1089 sub _check_back_compat {
1092 # dynamic schemas will always be in 0.04006 mode, unless overridden
1093 if ($self->dynamic) {
1094 # just in case, though no one is likely to dump a dynamic schema
1095 $self->schema_version_to_dump('0.04006');
1097 if (not $self->naming_set) {
1098 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1100 Dynamic schema detected, will run in 0.04006 mode.
1102 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1103 to disable this warning.
1105 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1110 $self->_upgrading_from('v4');
1113 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
1114 $self->use_namespaces(1);
1117 $self->naming->{relationships} ||= 'v4';
1118 $self->naming->{monikers} ||= 'v4';
1120 if ($self->use_namespaces) {
1121 $self->_upgrading_from_load_classes(1);
1124 $self->use_namespaces(0);
1130 # otherwise check if we need backcompat mode for a static schema
1131 my $filename = $self->get_dump_filename($self->schema_class);
1132 return unless -e $filename;
1134 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
1135 $self->_parse_generated_file($filename);
1137 return unless $old_ver;
1139 # determine if the existing schema was dumped with use_moose => 1
1140 if (! defined $self->use_moose) {
1141 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
1144 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
1146 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
1147 my $ds = eval $result_namespace;
1149 Could not eval expression '$result_namespace' for result_namespace from
1152 $result_namespace = $ds || '';
1154 if ($load_classes && (not defined $self->use_namespaces)) {
1155 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1157 'load_classes;' static schema detected, turning off 'use_namespaces'.
1159 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
1160 variable to disable this warning.
1162 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1165 $self->use_namespaces(0);
1167 elsif ($load_classes && $self->use_namespaces) {
1168 $self->_upgrading_from_load_classes(1);
1170 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
1171 $self->_downgrading_to_load_classes(
1172 $result_namespace || 'Result'
1175 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
1176 if (not $self->result_namespace) {
1177 $self->result_namespace($result_namespace || 'Result');
1179 elsif ($result_namespace ne $self->result_namespace) {
1180 $self->_rewriting_result_namespace(
1181 $result_namespace || 'Result'
1186 # XXX when we go past .0 this will need fixing
1187 my ($v) = $old_ver =~ /([1-9])/;
1190 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
1192 if (not %{ $self->naming }) {
1193 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1195 Version $old_ver static schema detected, turning on backcompat mode.
1197 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1198 to disable this warning.
1200 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
1202 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
1203 from version 0.04006.
1206 $self->naming->{relationships} ||= $v;
1207 $self->naming->{monikers} ||= $v;
1208 $self->naming->{column_accessors} ||= $v;
1210 $self->schema_version_to_dump($old_ver);
1213 $self->_upgrading_from($v);
1217 sub _validate_class_args {
1220 foreach my $k (@CLASS_ARGS) {
1221 next unless $self->$k;
1223 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
1224 $self->_validate_classes($k, \@classes);
1228 sub _validate_result_components_map {
1231 foreach my $classes (values %{ $self->result_components_map }) {
1232 $self->_validate_classes('result_components_map', $classes);
1236 sub _validate_result_roles_map {
1239 foreach my $classes (values %{ $self->result_roles_map }) {
1240 $self->_validate_classes('result_roles_map', $classes);
1244 sub _validate_classes {
1247 my $classes = shift;
1249 # make a copy to not destroy original
1250 my @classes = @$classes;
1252 foreach my $c (@classes) {
1253 # components default to being under the DBIx::Class namespace unless they
1254 # are preceeded with a '+'
1255 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1256 $c = 'DBIx::Class::' . $c;
1259 # 1 == installed, 0 == not installed, undef == invalid classname
1260 my $installed = Class::Inspector->installed($c);
1261 if ( defined($installed) ) {
1262 if ( $installed == 0 ) {
1263 croak qq/$c, as specified in the loader option "$key", is not installed/;
1266 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1272 sub _find_file_in_inc {
1273 my ($self, $file) = @_;
1275 foreach my $prefix (@INC) {
1276 my $fullpath = File::Spec->catfile($prefix, $file);
1277 return $fullpath if -f $fullpath
1278 # abs_path throws on Windows for nonexistant files
1279 and (try { Cwd::abs_path($fullpath) }) ne
1280 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1286 sub _find_class_in_inc {
1287 my ($self, $class) = @_;
1289 return $self->_find_file_in_inc(class_path($class));
1295 return $self->_upgrading_from
1296 || $self->_upgrading_from_load_classes
1297 || $self->_downgrading_to_load_classes
1298 || $self->_rewriting_result_namespace
1302 sub _rewrite_old_classnames {
1303 my ($self, $code) = @_;
1305 return $code unless $self->_rewriting;
1307 my %old_classes = reverse %{ $self->_upgrading_classes };
1309 my $re = join '|', keys %old_classes;
1310 $re = qr/\b($re)\b/;
1312 $code =~ s/$re/$old_classes{$1} || $1/eg;
1317 sub _load_external {
1318 my ($self, $class) = @_;
1320 return if $self->{skip_load_external};
1322 # so that we don't load our own classes, under any circumstances
1323 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1325 my $real_inc_path = $self->_find_class_in_inc($class);
1327 my $old_class = $self->_upgrading_classes->{$class}
1328 if $self->_rewriting;
1330 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1331 if $old_class && $old_class ne $class;
1333 return unless $real_inc_path || $old_real_inc_path;
1335 if ($real_inc_path) {
1336 # If we make it to here, we loaded an external definition
1337 warn qq/# Loaded external class definition for '$class'\n/
1340 my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path);
1342 if ($self->dynamic) { # load the class too
1343 eval_package_without_redefine_warnings($class, $code);
1346 $self->_ext_stmt($class,
1347 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1348 .qq|# They are now part of the custom portion of this file\n|
1349 .qq|# for you to hand-edit. If you do not either delete\n|
1350 .qq|# this section or remove that file from \@INC, this section\n|
1351 .qq|# will be repeated redundantly when you re-create this\n|
1352 .qq|# file again via Loader! See skip_load_external to disable\n|
1353 .qq|# this feature.\n|
1356 $self->_ext_stmt($class, $code);
1357 $self->_ext_stmt($class,
1358 qq|# End of lines loaded from '$real_inc_path' |
1362 if ($old_real_inc_path) {
1363 my $code = slurp_file $old_real_inc_path;
1365 $self->_ext_stmt($class, <<"EOF");
1367 # These lines were loaded from '$old_real_inc_path',
1368 # based on the Result class name that would have been created by an older
1369 # version of the Loader. For a static schema, this happens only once during
1370 # upgrade. See skip_load_external to disable this feature.
1373 $code = $self->_rewrite_old_classnames($code);
1375 if ($self->dynamic) {
1378 Detected external content in '$old_real_inc_path', a class name that would have
1379 been used by an older version of the Loader.
1381 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1382 new name of the Result.
1384 eval_package_without_redefine_warnings($class, $code);
1388 $self->_ext_stmt($class, $code);
1389 $self->_ext_stmt($class,
1390 qq|# End of lines loaded from '$old_real_inc_path' |
1397 Does the actual schema-construction work.
1404 $self->_load_tables(
1405 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1413 Rescan the database for changes. Returns a list of the newly added table
1416 The schema argument should be the schema class or object to be affected. It
1417 should probably be derived from the original schema_class used during L</load>.
1422 my ($self, $schema) = @_;
1424 $self->{schema} = $schema;
1425 $self->_relbuilder->{schema} = $schema;
1428 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1430 foreach my $table (@current) {
1431 if(!exists $self->_tables->{$table->sql_name}) {
1432 push(@created, $table);
1437 @current{map $_->sql_name, @current} = ();
1438 foreach my $table (values %{ $self->_tables }) {
1439 if (not exists $current{$table->sql_name}) {
1440 $self->_remove_table($table);
1444 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1446 my $loaded = $self->_load_tables(@current);
1448 foreach my $table (@created) {
1449 $self->monikers->{$table->sql_name} = $self->_table2moniker($table);
1452 return map { $self->monikers->{$_->sql_name} } @created;
1458 return if $self->{skip_relationships};
1460 return $self->{relbuilder} ||= do {
1461 my $relbuilder_suff =
1468 ->{$self->naming->{relationships}||$CURRENT_V} || '';
1470 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1471 $self->ensure_class_loaded($relbuilder_class);
1472 $relbuilder_class->new($self);
1477 my ($self, @tables) = @_;
1479 # Save the new tables to the tables list and compute monikers
1481 $self->_tables->{$_->sql_name} = $_;
1482 $self->monikers->{$_->sql_name} = $self->_table2moniker($_);
1485 # check for moniker clashes
1486 my $inverse_moniker_idx;
1487 foreach my $imtable (values %{ $self->_tables }) {
1488 push @{ $inverse_moniker_idx->{$self->monikers->{$imtable->sql_name}} }, $imtable;
1492 foreach my $moniker (keys %$inverse_moniker_idx) {
1493 my $imtables = $inverse_moniker_idx->{$moniker};
1494 if (@$imtables > 1) {
1495 my $different_databases =
1496 $imtables->[0]->can('database') && (uniq map $_->database||'', @$imtables) > 1;
1498 my $different_schemas =
1499 (uniq map $_->schema||'', @$imtables) > 1;
1501 if ($different_databases || $different_schemas) {
1502 my ($use_schema, $use_database) = (1, 0);
1504 if ($different_databases) {
1507 # If any monikers are in the same database, we have to distinguish by
1508 # both schema and database.
1510 $db_counts{$_}++ for map $_->database, @$imtables;
1511 $use_schema = any { $_ > 1 } values %db_counts;
1514 foreach my $tbl (@$imtables) { delete $self->monikers->{$tbl->sql_name}; }
1516 my $moniker_parts = [ @{ $self->moniker_parts } ];
1518 my $have_schema = 1 if any { $_ eq 'schema' } @{ $self->moniker_parts };
1519 my $have_database = 1 if any { $_ eq 'database' } @{ $self->moniker_parts };
1521 unshift @$moniker_parts, 'schema' if $use_schema && !$have_schema;
1522 unshift @$moniker_parts, 'database' if $use_database && !$have_database;
1524 local $self->{moniker_parts} = $moniker_parts;
1528 foreach my $tbl (@$imtables) { $new_monikers{$tbl->sql_name} = $self->_table2moniker($tbl); }
1529 foreach my $name (map $_->sql_name, @$imtables) { $self->monikers->{$name} = $new_monikers{$name}; }
1531 # check if there are still clashes
1534 while (my ($t, $m) = each %new_monikers) {
1535 push @{ $by_moniker{$m} }, $t;
1538 foreach my $m (grep @{ $by_moniker{$_} } > 1, keys %by_moniker) {
1539 push @clashes, sprintf ("tried disambiguating by moniker_parts, but tables %s still reduced to the same source moniker '%s'",
1540 join (', ', @{ $by_moniker{$m} }),
1546 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1547 join (', ', map $_->sql_name, @$imtables),
1555 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1556 . 'Change the naming style, or supply an explicit moniker_map: '
1557 . join ('; ', @clashes)
1562 foreach my $tbl (@tables) { $self->_make_src_class($tbl); }
1563 foreach my $tbl (@tables) { $self->_setup_src_meta($tbl); }
1565 if(!$self->skip_relationships) {
1566 # The relationship loader needs a working schema
1567 local $self->{quiet} = 1;
1568 local $self->{dump_directory} = $self->{temp_directory};
1569 $self->_reload_classes(\@tables);
1570 $self->_load_relationships(\@tables);
1572 # Remove that temp dir from INC so it doesn't get reloaded
1573 @INC = grep $_ ne $self->dump_directory, @INC;
1576 foreach my $tbl (@tables) { $self->_load_roles($tbl); }
1577 foreach my $tbl (map { $self->classes->{$_->sql_name} } @tables) { $self->_load_external($tbl); }
1579 # Reload without unloading first to preserve any symbols from external
1581 $self->_reload_classes(\@tables, { unload => 0 });
1583 # Drop temporary cache
1584 delete $self->{_cache};
1589 sub _reload_classes {
1590 my ($self, $tables, $opts) = @_;
1592 my @tables = @$tables;
1594 my $unload = $opts->{unload};
1595 $unload = 1 unless defined $unload;
1597 # so that we don't repeat custom sections
1598 @INC = grep $_ ne $self->dump_directory, @INC;
1600 $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables);
1602 unshift @INC, $self->dump_directory;
1605 my %have_source = map { $_ => $self->schema->source($_) }
1606 $self->schema->sources;
1608 for my $table (@tables) {
1609 my $moniker = $self->monikers->{$table->sql_name};
1610 my $class = $self->classes->{$table->sql_name};
1613 no warnings 'redefine';
1614 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1617 if (my $mc = $self->_moose_metaclass($class)) {
1620 Class::Unload->unload($class) if $unload;
1621 my ($source, $resultset_class);
1623 ($source = $have_source{$moniker})
1624 && ($resultset_class = $source->resultset_class)
1625 && ($resultset_class ne 'DBIx::Class::ResultSet')
1627 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1628 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1631 Class::Unload->unload($resultset_class) if $unload;
1632 $self->_reload_class($resultset_class) if $has_file;
1634 $self->_reload_class($class);
1636 push @to_register, [$moniker, $class];
1639 Class::C3->reinitialize;
1640 for (@to_register) {
1641 $self->schema->register_class(@$_);
1645 sub _moose_metaclass {
1646 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1650 my $mc = try { Class::MOP::class_of($class) }
1653 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1656 # We use this instead of ensure_class_loaded when there are package symbols we
1659 my ($self, $class) = @_;
1661 delete $INC{ +class_path($class) };
1664 eval_package_without_redefine_warnings ($class, "require $class");
1667 my $source = slurp_file $self->_get_dump_filename($class);
1668 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1672 sub _get_dump_filename {
1673 my ($self, $class) = (@_);
1675 $class =~ s{::}{/}g;
1676 return $self->dump_directory . q{/} . $class . q{.pm};
1679 =head2 get_dump_filename
1683 Returns the full path to the file for a class that the class has been or will
1684 be dumped to. This is a file in a temp dir for a dynamic schema.
1688 sub get_dump_filename {
1689 my ($self, $class) = (@_);
1691 local $self->{dump_directory} = $self->real_dump_directory;
1693 return $self->_get_dump_filename($class);
1696 sub _ensure_dump_subdirs {
1697 my ($self, $class) = (@_);
1699 my @name_parts = split(/::/, $class);
1700 pop @name_parts; # we don't care about the very last element,
1701 # which is a filename
1703 my $dir = $self->dump_directory;
1706 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1708 last if !@name_parts;
1709 $dir = File::Spec->catdir($dir, shift @name_parts);
1714 my ($self, @classes) = @_;
1716 my $schema_class = $self->schema_class;
1717 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1719 my $target_dir = $self->dump_directory;
1720 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1721 unless $self->dynamic or $self->quiet;
1725 . qq|package $schema_class;\n\n|
1726 . qq|# Created by DBIx::Class::Schema::Loader\n|
1727 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1730 = $self->only_autoclean
1731 ? 'namespace::autoclean'
1732 : 'MooseX::MarkAsMethods autoclean => 1'
1735 if ($self->use_moose) {
1737 $schema_text.= qq|use Moose;\nuse $autoclean;\nextends '$schema_base_class';\n\n|;
1740 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1743 my @schema_components = @{ $self->schema_components || [] };
1745 if (@schema_components) {
1746 my $schema_components = dump @schema_components;
1747 $schema_components = "($schema_components)" if @schema_components == 1;
1749 $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1752 if ($self->use_namespaces) {
1753 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1754 my $namespace_options;
1756 my @attr = qw/resultset_namespace default_resultset_class/;
1758 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1760 for my $attr (@attr) {
1762 my $code = dumper_squashed $self->$attr;
1763 $namespace_options .= qq| $attr => $code,\n|
1766 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1767 $schema_text .= qq|;\n|;
1770 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1774 local $self->{version_to_dump} = $self->schema_version_to_dump;
1775 $self->_write_classfile($schema_class, $schema_text, 1);
1778 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1780 foreach my $src_class (@classes) {
1783 . qq|package $src_class;\n\n|
1784 . qq|# Created by DBIx::Class::Schema::Loader\n|
1785 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1787 $src_text .= $self->_make_pod_heading($src_class);
1789 $src_text .= qq|use strict;\nuse warnings;\n\n|;
1791 $src_text .= $self->_base_class_pod($result_base_class)
1792 unless $result_base_class eq 'DBIx::Class::Core';
1794 if ($self->use_moose) {
1795 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse $autoclean;|;
1797 # these options 'use base' which is compile time
1798 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1799 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1802 $src_text .= qq|\nextends '$result_base_class';\n|;
1806 $src_text .= qq|use base '$result_base_class';\n|;
1809 $self->_write_classfile($src_class, $src_text);
1812 # remove Result dir if downgrading from use_namespaces, and there are no
1814 if (my $result_ns = $self->_downgrading_to_load_classes
1815 || $self->_rewriting_result_namespace) {
1816 my $result_namespace = $self->_result_namespace(
1821 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1822 $result_dir = $self->dump_directory . '/' . $result_dir;
1824 unless (my @files = glob "$result_dir/*") {
1829 warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
1833 my ($self, $version, $ts) = @_;
1834 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1837 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1840 sub _write_classfile {
1841 my ($self, $class, $text, $is_schema) = @_;
1843 my $filename = $self->_get_dump_filename($class);
1844 $self->_ensure_dump_subdirs($class);
1846 if (-f $filename && $self->really_erase_my_files) {
1847 warn "Deleting existing file '$filename' due to "
1848 . "'really_erase_my_files' setting\n" unless $self->quiet;
1852 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1853 = $self->_parse_generated_file($filename);
1855 if (! $old_gen && -f $filename) {
1856 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1857 . " it does not appear to have been generated by Loader"
1860 my $custom_content = $old_custom || '';
1862 # Use custom content from a renamed class, the class names in it are
1864 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1865 my $old_filename = $self->_get_dump_filename($renamed_class);
1867 if (-f $old_filename) {
1868 $custom_content = ($self->_parse_generated_file ($old_filename))[4];
1870 unlink $old_filename;
1874 $custom_content ||= $self->_default_custom_content($is_schema);
1876 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1877 # If there is already custom content, which does not have the Moose content, add it.
1878 if ($self->use_moose) {
1880 my $non_moose_custom_content = do {
1881 local $self->{use_moose} = 0;
1882 $self->_default_custom_content;
1885 if ($custom_content eq $non_moose_custom_content) {
1886 $custom_content = $self->_default_custom_content($is_schema);
1888 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1889 $custom_content .= $self->_default_custom_content($is_schema);
1892 elsif (defined $self->use_moose && $old_gen) {
1893 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'
1894 if $old_gen =~ /use \s+ MooseX?\b/x;
1897 $custom_content = $self->_rewrite_old_classnames($custom_content);
1900 for @{$self->{_dump_storage}->{$class} || []};
1902 if ($self->filter_generated_code) {
1903 my $filter = $self->filter_generated_code;
1905 if (ref $filter eq 'CODE') {
1907 ($is_schema ? 'schema' : 'result'),
1913 my ($fh, $temp_file) = tempfile();
1915 binmode $fh, ':encoding(UTF-8)';
1919 open my $out, qq{$filter < "$temp_file"|}
1920 or croak "Could not open pipe to $filter: $!";
1922 $text = decode('UTF-8', do { local $/; <$out> });
1924 $text =~ s/$CR?$LF/\n/g;
1928 my $exit_code = $? >> 8;
1931 or croak "Could not remove temporary file '$temp_file': $!";
1933 if ($exit_code != 0) {
1934 croak "filter '$filter' exited non-zero: $exit_code";
1937 if (not $text or not $text =~ /\bpackage\b/) {
1938 warn("$class skipped due to filter") if $self->debug;
1943 # Check and see if the dump is in fact different
1947 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1948 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1949 return unless $self->_upgrading_from && $is_schema;
1953 $text .= $self->_sig_comment(
1954 $self->version_to_dump,
1955 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1958 open(my $fh, '>:encoding(UTF-8)', $filename)
1959 or croak "Cannot open '$filename' for writing: $!";
1961 # Write the top half and its MD5 sum
1962 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1964 # Write out anything loaded via external partial class file in @INC
1966 for @{$self->{_ext_storage}->{$class} || []};
1968 # Write out any custom content the user has added
1969 print $fh $custom_content;
1972 or croak "Error closing '$filename': $!";
1975 sub _default_moose_custom_content {
1976 my ($self, $is_schema) = @_;
1978 if (not $is_schema) {
1979 return qq|\n__PACKAGE__->meta->make_immutable;|;
1982 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1985 sub _default_custom_content {
1986 my ($self, $is_schema) = @_;
1987 my $default = qq|\n\n# You can replace this text with custom|
1988 . qq| code or comments, and it will be preserved on regeneration|;
1989 if ($self->use_moose) {
1990 $default .= $self->_default_moose_custom_content($is_schema);
1992 $default .= qq|\n1;\n|;
1996 sub _parse_generated_file {
1997 my ($self, $fn) = @_;
1999 return unless -f $fn;
2001 open(my $fh, '<:encoding(UTF-8)', $fn)
2002 or croak "Cannot open '$fn' for reading: $!";
2005 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
2007 my ($md5, $ts, $ver, $gen);
2013 # Pull out the version and timestamp from the line above
2014 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m;
2017 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"
2018 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
2027 my $custom = do { local $/; <$fh> }
2031 $custom =~ s/$CRLF|$LF/\n/g;
2035 return ($gen, $md5, $ver, $ts, $custom);
2043 warn "$target: use $_;" if $self->debug;
2044 $self->_raw_stmt($target, "use $_;");
2052 my $blist = join(q{ }, @_);
2054 return unless $blist;
2056 warn "$target: use base qw/$blist/;" if $self->debug;
2057 $self->_raw_stmt($target, "use base qw/$blist/;");
2064 my $rlist = join(q{, }, map { qq{'$_'} } @_);
2066 return unless $rlist;
2068 warn "$target: with $rlist;" if $self->debug;
2069 $self->_raw_stmt($target, "\nwith $rlist;");
2072 sub _result_namespace {
2073 my ($self, $schema_class, $ns) = @_;
2074 my @result_namespace;
2076 $ns = $ns->[0] if ref $ns;
2078 if ($ns =~ /^\+(.*)/) {
2079 # Fully qualified namespace
2080 @result_namespace = ($1)
2083 # Relative namespace
2084 @result_namespace = ($schema_class, $ns);
2087 return wantarray ? @result_namespace : join '::', @result_namespace;
2090 # Create class with applicable bases, setup monikers, etc
2091 sub _make_src_class {
2092 my ($self, $table) = @_;
2094 my $schema = $self->schema;
2095 my $schema_class = $self->schema_class;
2097 my $table_moniker = $self->monikers->{$table->sql_name};
2098 my @result_namespace = ($schema_class);
2099 if ($self->use_namespaces) {
2100 my $result_namespace = $self->result_namespace || 'Result';
2101 @result_namespace = $self->_result_namespace(
2106 my $table_class = join(q{::}, @result_namespace, $table_moniker);
2108 if ((my $upgrading_v = $self->_upgrading_from)
2109 || $self->_rewriting) {
2110 local $self->naming->{monikers} = $upgrading_v
2113 my @result_namespace = @result_namespace;
2114 if ($self->_upgrading_from_load_classes) {
2115 @result_namespace = ($schema_class);
2117 elsif (my $ns = $self->_downgrading_to_load_classes) {
2118 @result_namespace = $self->_result_namespace(
2123 elsif ($ns = $self->_rewriting_result_namespace) {
2124 @result_namespace = $self->_result_namespace(
2130 my $old_table_moniker = do {
2131 local $self->naming->{monikers} = $upgrading_v;
2132 $self->_table2moniker($table);
2135 my $old_class = join(q{::}, @result_namespace, $old_table_moniker);
2137 $self->_upgrading_classes->{$table_class} = $old_class
2138 unless $table_class eq $old_class;
2141 $self->classes->{$table->sql_name} = $table_class;
2142 $self->moniker_to_table->{$table_moniker} = $table;
2143 $self->class_to_table->{$table_class} = $table;
2145 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
2147 $self->_use ($table_class, @{$self->additional_classes});
2149 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
2151 $self->_inject($table_class, @{$self->left_base_classes});
2153 my @components = @{ $self->components || [] };
2155 push @components, @{ $self->result_components_map->{$table_moniker} }
2156 if exists $self->result_components_map->{$table_moniker};
2158 my @fq_components = @components;
2159 foreach my $component (@fq_components) {
2160 if ($component !~ s/^\+//) {
2161 $component = "DBIx::Class::$component";
2165 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
2167 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
2169 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
2171 $self->_inject($table_class, @{$self->additional_base_classes});
2174 sub _is_result_class_method {
2175 my ($self, $name, $table) = @_;
2177 my $table_moniker = $table ? $self->monikers->{$table->sql_name} : '';
2179 $self->_result_class_methods({})
2180 if not defined $self->_result_class_methods;
2182 if (not exists $self->_result_class_methods->{$table_moniker}) {
2183 my (@methods, %methods);
2184 my $base = $self->result_base_class || 'DBIx::Class::Core';
2186 my @components = @{ $self->components || [] };
2188 push @components, @{ $self->result_components_map->{$table_moniker} }
2189 if exists $self->result_components_map->{$table_moniker};
2191 for my $c (@components) {
2192 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
2195 my @roles = @{ $self->result_roles || [] };
2197 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2198 if exists $self->result_roles_map->{$table_moniker};
2200 for my $class ($base, @components,
2201 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
2202 $self->ensure_class_loaded($class);
2204 push @methods, @{ Class::Inspector->methods($class) || [] };
2207 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
2209 @methods{@methods} = ();
2211 $self->_result_class_methods->{$table_moniker} = \%methods;
2213 my $result_methods = $self->_result_class_methods->{$table_moniker};
2215 return exists $result_methods->{$name};
2218 sub _resolve_col_accessor_collisions {
2219 my ($self, $table, $col_info) = @_;
2221 while (my ($col, $info) = each %$col_info) {
2222 my $accessor = $info->{accessor} || $col;
2224 next if $accessor eq 'id'; # special case (very common column)
2226 if ($self->_is_result_class_method($accessor, $table)) {
2229 if (my $map = $self->col_collision_map) {
2230 for my $re (keys %$map) {
2231 if (my @matches = $col =~ /$re/) {
2232 $info->{accessor} = sprintf $map->{$re}, @matches;
2240 Column '$col' in table '$table' collides with an inherited method.
2241 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
2243 $info->{accessor} = undef;
2249 # use the same logic to run moniker_map, col_accessor_map
2251 my ( $self, $map, $default_code, $ident, @extra ) = @_;
2253 my $default_ident = $default_code->( $ident, @extra );
2255 if( $map && ref $map eq 'HASH' ) {
2256 $new_ident = $map->{ $ident };
2258 elsif( $map && ref $map eq 'CODE' ) {
2259 $new_ident = $map->( $ident, $default_ident, @extra );
2262 $new_ident ||= $default_ident;
2267 sub _default_column_accessor_name {
2268 my ( $self, $column_name ) = @_;
2270 my $preserve = ($self->naming->{column_accessors}||'') eq 'preserve';
2272 my $v = $self->_get_naming_v('column_accessors');
2274 my $accessor_name = $preserve ?
2275 $self->_to_identifier('column_accessors', $column_name) # assume CamelCase
2277 $self->_to_identifier('column_accessors', $column_name, '_');
2279 $accessor_name =~ s/\W+/_/g; # only if naming < v8, otherwise to_identifier
2283 return $accessor_name;
2285 elsif ($v < 7 || (not $self->preserve_case)) {
2286 # older naming just lc'd the col accessor and that's all.
2287 return lc $accessor_name;
2290 return join '_', map lc, split_name $column_name, $v;
2293 sub _make_column_accessor_name {
2294 my ($self, $column_name, $column_context_info ) = @_;
2296 my $accessor = $self->_run_user_map(
2297 $self->col_accessor_map,
2298 sub { $self->_default_column_accessor_name( shift ) },
2300 $column_context_info,
2306 # Set up metadata (cols, pks, etc)
2307 sub _setup_src_meta {
2308 my ($self, $table) = @_;
2310 my $schema = $self->schema;
2311 my $schema_class = $self->schema_class;
2313 my $table_class = $self->classes->{$table->sql_name};
2314 my $table_moniker = $self->monikers->{$table->sql_name};
2316 $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
2318 my $cols = $self->_table_columns($table);
2319 my $col_info = $self->__columns_info_for($table);
2321 ### generate all the column accessor names
2322 while (my ($col, $info) = each %$col_info) {
2323 # hashref of other info that could be used by
2324 # user-defined accessor map functions
2326 table_class => $table_class,
2327 table_moniker => $table_moniker,
2328 table_name => $table,
2329 full_table_name => $table->dbic_name,
2330 schema_class => $schema_class,
2331 column_info => $info,
2334 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2337 $self->_resolve_col_accessor_collisions($table, $col_info);
2339 # prune any redundant accessor names
2340 while (my ($col, $info) = each %$col_info) {
2341 no warnings 'uninitialized';
2342 delete $info->{accessor} if $info->{accessor} eq $col;
2345 my $fks = $self->_table_fk_info($table);
2347 foreach my $fkdef (@$fks) {
2348 for my $col (@{ $fkdef->{local_columns} }) {
2349 $col_info->{$col}{is_foreign_key} = 1;
2353 my $pks = $self->_table_pk_info($table) || [];
2355 my %uniq_tag; # used to eliminate duplicate uniqs
2357 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2359 my $uniqs = $self->_table_uniq_info($table) || [];
2362 foreach my $uniq (@$uniqs) {
2363 my ($name, $cols) = @$uniq;
2364 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2365 push @uniqs, [$name, $cols];
2368 my @non_nullable_uniqs = grep {
2369 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2372 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2373 my @by_colnum = sort { $b->[0] <=> $a->[0] }
2374 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2376 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2377 my @keys = map $_->[1], @by_colnum;
2381 # remove the uniq from list
2382 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2388 foreach my $pkcol (@$pks) {
2389 $col_info->{$pkcol}{is_nullable} = 0;
2395 map { $_, ($col_info->{$_}||{}) } @$cols
2398 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2401 # Sort unique constraints by constraint name for repeatable results (rels
2402 # are sorted as well elsewhere.)
2403 @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs;
2405 foreach my $uniq (@uniqs) {
2406 my ($name, $cols) = @$uniq;
2407 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2411 sub __columns_info_for {
2412 my ($self, $table) = @_;
2414 my $result = $self->_columns_info_for($table);
2416 while (my ($col, $info) = each %$result) {
2417 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
2418 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2420 $result->{$col} = $info;
2428 Returns a sorted list of loaded tables, using the original database table
2436 return values %{$self->_tables};
2440 my ($self, $naming_key) = @_;
2444 if (($self->naming->{$naming_key}||'') =~ /^v(\d+)\z/) {
2448 ($v) = $CURRENT_V =~ /^v(\d+)\z/;
2454 sub _to_identifier {
2455 my ($self, $naming_key, $name, $sep_char, $force) = @_;
2457 my $v = $self->_get_naming_v($naming_key);
2459 my $to_identifier = $self->naming->{force_ascii} ?
2460 \&String::ToIdentifier::EN::to_identifier
2461 : \&String::ToIdentifier::EN::Unicode::to_identifier;
2463 return $v >= 8 || $force ? $to_identifier->($name, $sep_char) : $name;
2466 # Make a moniker from a table
2467 sub _default_table2moniker {
2468 my ($self, $table) = @_;
2470 my $v = $self->_get_naming_v('monikers');
2472 my @name_parts = map $table->$_, @{ $self->moniker_parts };
2474 my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
2478 foreach my $i (0 .. $#name_parts) {
2479 my $part = $name_parts[$i];
2481 if ($i != $name_idx || $v >= 8) {
2482 $part = $self->_to_identifier('monikers', $part, '_', 1);
2485 if ($i == $name_idx && $v == 5) {
2486 $part = Lingua::EN::Inflect::Number::to_S($part);
2489 my @part_parts = map lc, $v > 6 ?
2490 # use v8 semantics for all moniker parts except name
2491 ($i == $name_idx ? split_name $part, $v : split_name $part)
2492 : split /[\W_]+/, $part;
2494 if ($i == $name_idx && $v >= 6) {
2495 my $as_phrase = join ' ', @part_parts;
2497 my $inflected = ($self->naming->{monikers}||'') eq 'plural' ?
2498 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2500 ($self->naming->{monikers}||'') eq 'preserve' ?
2503 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2505 @part_parts = split /\s+/, $inflected;
2508 push @all_parts, map ucfirst, @part_parts;
2511 return join '', @all_parts;
2514 sub _table2moniker {
2515 my ( $self, $table ) = @_;
2517 $self->_run_user_map(
2519 sub { $self->_default_table2moniker( shift ) },
2524 sub _load_relationships {
2525 my ($self, $tables) = @_;
2529 foreach my $table (@$tables) {
2530 my $local_moniker = $self->monikers->{$table->sql_name};
2532 my $tbl_fk_info = $self->_table_fk_info($table);
2534 foreach my $fkdef (@$tbl_fk_info) {
2535 $fkdef->{local_table} = $table;
2536 $fkdef->{local_moniker} = $local_moniker;
2537 $fkdef->{remote_source} =
2538 $self->monikers->{$fkdef->{remote_table}->sql_name};
2540 my $tbl_uniq_info = $self->_table_uniq_info($table);
2542 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2545 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2547 foreach my $src_class (sort keys %$rel_stmts) {
2549 my @src_stmts = map $_->[2],
2555 ($_->{method} eq 'many_to_many' ? 1 : 0),
2558 ], @{ $rel_stmts->{$src_class} };
2560 foreach my $stmt (@src_stmts) {
2561 $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2567 my ($self, $table) = @_;
2569 my $table_moniker = $self->monikers->{$table->sql_name};
2570 my $table_class = $self->classes->{$table->sql_name};
2572 my @roles = @{ $self->result_roles || [] };
2573 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2574 if exists $self->result_roles_map->{$table_moniker};
2577 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2579 $self->_with($table_class, @roles);
2583 # Overload these in driver class:
2585 # Returns an arrayref of column names
2586 sub _table_columns { croak "ABSTRACT METHOD" }
2588 # Returns arrayref of pk col names
2589 sub _table_pk_info { croak "ABSTRACT METHOD" }
2591 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2592 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2594 # Returns an arrayref of foreign key constraints, each
2595 # being a hashref with 3 keys:
2596 # local_columns (arrayref), remote_columns (arrayref), remote_table
2597 sub _table_fk_info { croak "ABSTRACT METHOD" }
2599 # Returns an array of lower case table names
2600 sub _tables_list { croak "ABSTRACT METHOD" }
2602 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2608 # generate the pod for this statement, storing it with $self->_pod
2609 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2611 my $args = dump(@_);
2612 $args = '(' . $args . ')' if @_ < 2;
2613 my $stmt = $method . $args . q{;};
2615 warn qq|$class\->$stmt\n| if $self->debug;
2616 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2620 sub _make_pod_heading {
2621 my ($self, $class) = @_;
2623 return '' if not $self->generate_pod;
2625 my $table = $self->class_to_table->{$class};
2628 my $pcm = $self->pod_comment_mode;
2629 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2630 $comment = $self->__table_comment($table);
2631 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2632 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2633 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2635 $pod .= "=head1 NAME\n\n";
2637 my $table_descr = $class;
2638 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2640 $pod .= "$table_descr\n\n";
2642 if ($comment and $comment_in_desc) {
2643 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2650 # generates the accompanying pod for a DBIC class method statement,
2651 # storing it with $self->_pod
2657 if ($method eq 'table') {
2659 $table = $$table if ref $table eq 'SCALAR';
2660 $self->_pod($class, "=head1 TABLE: C<$table>");
2661 $self->_pod_cut($class);
2663 elsif ( $method eq 'add_columns' ) {
2664 $self->_pod( $class, "=head1 ACCESSORS" );
2665 my $col_counter = 0;
2667 while( my ($name,$attrs) = splice @cols,0,2 ) {
2669 $self->_pod( $class, '=head2 ' . $name );
2670 $self->_pod( $class,
2672 my $s = $attrs->{$_};
2673 $s = !defined $s ? 'undef' :
2674 length($s) == 0 ? '(empty string)' :
2675 ref($s) eq 'SCALAR' ? $$s :
2676 ref($s) ? dumper_squashed $s :
2677 looks_like_number($s) ? $s : qq{'$s'};
2680 } sort keys %$attrs,
2682 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2683 $self->_pod( $class, $comment );
2686 $self->_pod_cut( $class );
2687 } elsif ( $method =~ /^(?:belongs_to|has_many|might_have)\z/ ) {
2688 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2689 my ( $accessor, $rel_class ) = @_;
2690 $self->_pod( $class, "=head2 $accessor" );
2691 $self->_pod( $class, 'Type: ' . $method );
2692 $self->_pod( $class, "Related object: L<$rel_class>" );
2693 $self->_pod_cut( $class );
2694 $self->{_relations_started} { $class } = 1;
2695 } elsif ( $method eq 'many_to_many' ) {
2696 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2697 my ( $accessor, $rel1, $rel2 ) = @_;
2698 $self->_pod( $class, "=head2 $accessor" );
2699 $self->_pod( $class, 'Type: many_to_many' );
2700 $self->_pod( $class, "Composing rels: L</$rel1> -> $rel2" );
2701 $self->_pod_cut( $class );
2702 $self->{_relations_started} { $class } = 1;
2704 elsif ($method eq 'add_unique_constraint') {
2705 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2706 unless $self->{_uniqs_started}{$class};
2708 my ($name, $cols) = @_;
2710 $self->_pod($class, "=head2 C<$name>");
2711 $self->_pod($class, '=over 4');
2713 foreach my $col (@$cols) {
2714 $self->_pod($class, "=item \* L</$col>");
2717 $self->_pod($class, '=back');
2718 $self->_pod_cut($class);
2720 $self->{_uniqs_started}{$class} = 1;
2722 elsif ($method eq 'set_primary_key') {
2723 $self->_pod($class, "=head1 PRIMARY KEY");
2724 $self->_pod($class, '=over 4');
2726 foreach my $col (@_) {
2727 $self->_pod($class, "=item \* L</$col>");
2730 $self->_pod($class, '=back');
2731 $self->_pod_cut($class);
2735 sub _pod_class_list {
2736 my ($self, $class, $title, @classes) = @_;
2738 return unless @classes && $self->generate_pod;
2740 $self->_pod($class, "=head1 $title");
2741 $self->_pod($class, '=over 4');
2743 foreach my $link (@classes) {
2744 $self->_pod($class, "=item * L<$link>");
2747 $self->_pod($class, '=back');
2748 $self->_pod_cut($class);
2751 sub _base_class_pod {
2752 my ($self, $base_class) = @_;
2754 return '' unless $self->generate_pod;
2757 =head1 BASE CLASS: L<$base_class>
2764 sub _filter_comment {
2765 my ($self, $txt) = @_;
2767 $txt = '' if not defined $txt;
2769 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2774 sub __table_comment {
2777 if (my $code = $self->can('_table_comment')) {
2778 return $self->_filter_comment($self->$code(@_));
2784 sub __column_comment {
2787 if (my $code = $self->can('_column_comment')) {
2788 return $self->_filter_comment($self->$code(@_));
2794 # Stores a POD documentation
2796 my ($self, $class, $stmt) = @_;
2797 $self->_raw_stmt( $class, "\n" . $stmt );
2801 my ($self, $class ) = @_;
2802 $self->_raw_stmt( $class, "\n=cut\n" );
2805 # Store a raw source line for a class (for dumping purposes)
2807 my ($self, $class, $stmt) = @_;
2808 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2811 # Like above, but separately for the externally loaded stuff
2813 my ($self, $class, $stmt) = @_;
2814 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2817 sub _custom_column_info {
2818 my ( $self, $table_name, $column_name, $column_info ) = @_;
2820 if (my $code = $self->custom_column_info) {
2821 return $code->($table_name, $column_name, $column_info) || {};
2826 sub _datetime_column_info {
2827 my ( $self, $table_name, $column_name, $column_info ) = @_;
2829 my $type = $column_info->{data_type} || '';
2830 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2831 or ($type =~ /date|timestamp/i)) {
2832 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2833 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2839 my ($self, $name) = @_;
2841 return $self->preserve_case ? $name : lc($name);
2845 my ($self, $name) = @_;
2847 return $self->preserve_case ? $name : uc($name);
2851 my ($self, $table) = @_;
2854 my $schema = $self->schema;
2855 # in older DBIC it's a private method
2856 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2857 $schema->$unregister(delete $self->monikers->{$table->sql_name});
2858 delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}};
2859 delete $self->_tables->{$table->sql_name};
2863 # remove the dump dir from @INC on destruction
2867 @INC = grep $_ ne $self->dump_directory, @INC;
2872 Returns a hashref of loaded table to moniker mappings. There will
2873 be two entries for each table, the original name and the "normalized"
2874 name, in the case that the two are different (such as databases
2875 that like uppercase table names, or preserve your original mixed-case
2876 definitions, or what-have-you).
2880 Returns a hashref of table to class mappings. In some cases it will
2881 contain multiple entries per table for the original and normalized table
2882 names, as above in L</monikers>.
2884 =head1 NON-ENGLISH DATABASES
2886 If you use the loader on a database with table and column names in a language
2887 other than English, you will want to turn off the English language specific
2890 To do so, use something like this in your loader options:
2892 naming => { monikers => 'v4' },
2893 inflect_singular => sub { "$_[0]_rel" },
2894 inflect_plural => sub { "$_[0]_rel" },
2896 =head1 COLUMN ACCESSOR COLLISIONS
2898 Occasionally you may have a column name that collides with a perl method, such
2899 as C<can>. In such cases, the default action is to set the C<accessor> of the
2900 column spec to C<undef>.
2902 You can then name the accessor yourself by placing code such as the following
2905 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2907 Another option is to use the L</col_collision_map> option.
2909 =head1 RELATIONSHIP NAME COLLISIONS
2911 In very rare cases, you may get a collision between a generated relationship
2912 name and a method in your Result class, for example if you have a foreign key
2913 called C<belongs_to>.
2915 This is a problem because relationship names are also relationship accessor
2916 methods in L<DBIx::Class>.
2918 The default behavior is to append C<_rel> to the relationship name and print
2919 out a warning that refers to this text.
2921 You can also control the renaming with the L</rel_collision_map> option.
2925 L<DBIx::Class::Schema::Loader>, L<dbicdump>
2929 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2933 This library is free software; you can redistribute it and/or modify it under
2934 the same terms as Perl itself.
2939 # vim:et sts=4 sw=4 tw=0: