1 package DBIx::Class::Schema::Loader::Base;
5 use base qw/Class::Accessor::Grouped Class::C3::Componentised/;
7 use Carp::Clan qw/^DBIx::Class/;
8 use DBIx::Class::Schema::Loader::RelBuilder;
9 use Data::Dump qw/ dump /;
14 use Lingua::EN::Inflect::Number qw//;
15 use Lingua::EN::Inflect::Phrase qw//;
18 use Class::Inspector ();
19 use Scalar::Util 'looks_like_number';
20 use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path slurp_file/;
21 use DBIx::Class::Schema::Loader::Optional::Dependencies ();
24 use Encode qw/encode/;
25 use List::MoreUtils 'all';
28 our $VERSION = '0.07010';
30 __PACKAGE__->mk_group_ro_accessors('simple', qw/
37 additional_base_classes
53 default_resultset_class
58 overwrite_modifications
81 __PACKAGE__->mk_group_accessors('simple', qw/
83 schema_version_to_dump
85 _upgrading_from_load_classes
86 _downgrading_to_load_classes
87 _rewriting_result_namespace
92 pod_comment_spillover_length
100 datetime_undef_if_invalid
101 _result_class_methods
105 my $CURRENT_V = 'v7';
108 schema_components schema_base_class result_base_class
109 additional_base_classes left_base_classes additional_classes components
114 my $CRLF = "\x0d\x0a";
118 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
122 See L<DBIx::Class::Schema::Loader>
126 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
127 classes, and implements the common functionality between them.
129 =head1 CONSTRUCTOR OPTIONS
131 These constructor options are the base options for
132 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
134 =head2 skip_relationships
136 Skip setting up relationships. The default is to attempt the loading
139 =head2 skip_load_external
141 Skip loading of other classes in @INC. The default is to merge all other classes
142 with the same name found in @INC into the schema file we are creating.
146 Static schemas (ones dumped to disk) will, by default, use the new-style
147 relationship names and singularized Results, unless you're overwriting an
148 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
149 which case the backward compatible RelBuilder will be activated, and the
150 appropriate monikerization used.
156 will disable the backward-compatible RelBuilder and use
157 the new-style relationship names along with singularized Results, even when
158 overwriting a dump made with an earlier version.
160 The option also takes a hashref:
162 naming => { relationships => 'v7', monikers => 'v7' }
170 How to name relationship accessors.
174 How to name Result classes.
176 =item column_accessors
178 How to name column accessors in Result classes.
188 Latest style, whatever that happens to be.
192 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
196 Monikers singularized as whole words, C<might_have> relationships for FKs on
197 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
199 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
204 All monikers and relationships are inflected using
205 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
206 from relationship names.
208 In general, there is very little difference between v5 and v6 schemas.
212 This mode is identical to C<v6> mode, except that monikerization of CamelCase
213 table names is also done correctly.
215 CamelCase column names in case-preserving mode will also be handled correctly
216 for relationship name inflection. See L</preserve_case>.
218 In this mode, CamelCase L</column_accessors> are normalized based on case
219 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
221 If you don't have any CamelCase table or column names, you can upgrade without
222 breaking any of your code.
226 For L</monikers>, this option does not inflect the table names but makes
227 monikers based on the actual name. For L</column_accessors> this option does
228 not normalize CamelCase column names to lowercase column accessors, but makes
229 accessors that are the same names as the columns (with any non-\w chars
230 replaced with underscores.)
234 For L</monikers>, singularizes the names using the most current inflector. This
235 is the same as setting the option to L</current>.
239 For L</monikers>, pluralizes the names, using the most current inflector.
243 Dynamic schemas will always default to the 0.04XXX relationship names and won't
244 singularize Results for backward compatibility, to activate the new RelBuilder
245 and singularization put this in your C<Schema.pm> file:
247 __PACKAGE__->naming('current');
249 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
250 next major version upgrade:
252 __PACKAGE__->naming('v7');
256 If true, will not print the usual C<Dumping manual schema ... Schema dump
257 completed.> messages. Does not affect warnings (except for warnings related to
258 L</really_erase_my_files>.)
262 By default POD will be generated for columns and relationships, using database
263 metadata for the text if available and supported.
265 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
266 supported for Postgres right now.
268 Set this to C<0> to turn off all POD generation.
270 =head2 pod_comment_mode
272 Controls where table comments appear in the generated POD. Smaller table
273 comments are appended to the C<NAME> section of the documentation, and larger
274 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
275 section to be generated with the comment always, only use C<NAME>, or choose
276 the length threshold at which the comment is forced into the description.
282 Use C<NAME> section only.
286 Force C<DESCRIPTION> always.
290 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
295 =head2 pod_comment_spillover_length
297 When pod_comment_mode is set to C<auto>, this is the length of the comment at
298 which it will be forced into a separate description section.
302 =head2 relationship_attrs
304 Hashref of attributes to pass to each generated relationship, listed
305 by type. Also supports relationship type 'all', containing options to
306 pass to all generated relationships. Attributes set for more specific
307 relationship types override those set in 'all'.
311 relationship_attrs => {
312 belongs_to => { is_deferrable => 0 },
315 use this to turn off DEFERRABLE on your foreign key constraints.
319 If set to true, each constructive L<DBIx::Class> statement the loader
320 decides to execute will be C<warn>-ed before execution.
324 Set the name of the schema to load (schema in the sense that your database
325 vendor means it). Does not currently support loading more than one schema
330 Only load tables matching regex. Best specified as a qr// regex.
334 Exclude tables matching regex. Best specified as a qr// regex.
338 Overrides the default table name to moniker translation. Can be either
339 a hashref of table keys and moniker values, or a coderef for a translator
340 function taking a single scalar table name argument and returning
341 a scalar moniker. If the hash entry does not exist, or the function
342 returns a false value, the code falls back to default behavior
345 The default behavior is to split on case transition and non-alphanumeric
346 boundaries, singularize the resulting phrase, then join the titlecased words
349 Table Name | Moniker Name
350 ---------------------------------
352 luser_group | LuserGroup
353 luser-opts | LuserOpt
354 stations_visited | StationVisited
355 routeChange | RouteChange
357 =head2 col_accessor_map
359 Same as moniker_map, but for column accessor names. If a coderef is
360 passed, the code is called with arguments of
362 the name of the column in the underlying database,
363 default accessor name that DBICSL would ordinarily give this column,
365 table_class => name of the DBIC class we are building,
366 table_moniker => calculated moniker for this table (after moniker_map if present),
367 table_name => name of the database table,
368 full_table_name => schema-qualified name of the database table (RDBMS specific),
369 schema_class => name of the schema class we are building,
370 column_info => hashref of column info (data_type, is_nullable, etc),
375 Similar in idea to moniker_map, but different in the details. It can be
376 a hashref or a code ref.
378 If it is a hashref, keys can be either the default relationship name, or the
379 moniker. The keys that are the default relationship name should map to the
380 name you want to change the relationship to. Keys that are monikers should map
381 to hashes mapping relationship names to their translation. You can do both at
382 once, and the more specific moniker version will be picked up first. So, for
383 instance, you could have
392 and relationships that would have been named C<bar> will now be named C<baz>
393 except that in the table whose moniker is C<Foo> it will be named C<blat>.
395 If it is a coderef, the argument passed will be a hashref of this form:
398 name => default relationship name,
399 type => the relationship type eg: C<has_many>,
400 local_class => name of the DBIC class we are building,
401 local_moniker => moniker of the DBIC class we are building,
402 local_columns => columns in this table in the relationship,
403 remote_class => name of the DBIC class we are related to,
404 remote_moniker => moniker of the DBIC class we are related to,
405 remote_columns => columns in the other table in the relationship,
408 DBICSL will try to use the value returned as the relationship name.
410 =head2 inflect_plural
412 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
413 if hash key does not exist or coderef returns false), but acts as a map
414 for pluralizing relationship names. The default behavior is to utilize
415 L<Lingua::EN::Inflect::Phrase/to_PL>.
417 =head2 inflect_singular
419 As L</inflect_plural> above, but for singularizing relationship names.
420 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
422 =head2 schema_base_class
424 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
426 =head2 result_base_class
428 Base class for your table classes (aka result classes). Defaults to
431 =head2 additional_base_classes
433 List of additional base classes all of your table classes will use.
435 =head2 left_base_classes
437 List of additional base classes all of your table classes will use
438 that need to be leftmost.
440 =head2 additional_classes
442 List of additional classes which all of your table classes will use.
444 =head2 schema_components
446 List of components to load into the Schema class.
450 List of additional components to be loaded into all of your Result
451 classes. A good example would be
452 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
454 =head2 result_components_map
456 A hashref of moniker keys and component values. Unlike L</components>, which
457 loads the given components into every Result class, this option allows you to
458 load certain components for specified Result classes. For example:
460 result_components_map => {
461 StationVisited => '+YourApp::Schema::Component::StationVisited',
463 '+YourApp::Schema::Component::RouteChange',
464 'InflateColumn::DateTime',
468 You may use this in conjunction with L</components>.
472 List of L<Moose> roles to be applied to all of your Result classes.
474 =head2 result_roles_map
476 A hashref of moniker keys and role values. Unlike L</result_roles>, which
477 applies the given roles to every Result class, this option allows you to apply
478 certain roles for specified Result classes. For example:
480 result_roles_map => {
482 'YourApp::Role::Building',
483 'YourApp::Role::Destination',
485 RouteChange => 'YourApp::Role::TripEvent',
488 You may use this in conjunction with L</result_roles>.
490 =head2 use_namespaces
492 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
495 Generate result class names suitable for
496 L<DBIx::Class::Schema/load_namespaces> and call that instead of
497 L<DBIx::Class::Schema/load_classes>. When using this option you can also
498 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
499 C<resultset_namespace>, C<default_resultset_class>), and they will be added
500 to the call (and the generated result class names adjusted appropriately).
502 =head2 dump_directory
504 The value of this option is a perl libdir pathname. Within
505 that directory this module will create a baseline manual
506 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
508 The created schema class will have the same classname as the one on
509 which you are setting this option (and the ResultSource classes will be
510 based on this name as well).
512 Normally you wouldn't hard-code this setting in your schema class, as it
513 is meant for one-time manual usage.
515 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
516 recommended way to access this functionality.
518 =head2 dump_overwrite
520 Deprecated. See L</really_erase_my_files> below, which does *not* mean
521 the same thing as the old C<dump_overwrite> setting from previous releases.
523 =head2 really_erase_my_files
525 Default false. If true, Loader will unconditionally delete any existing
526 files before creating the new ones from scratch when dumping a schema to disk.
528 The default behavior is instead to only replace the top portion of the
529 file, up to and including the final stanza which contains
530 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
531 leaving any customizations you placed after that as they were.
533 When C<really_erase_my_files> is not set, if the output file already exists,
534 but the aforementioned final stanza is not found, or the checksum
535 contained there does not match the generated contents, Loader will
536 croak and not touch the file.
538 You should really be using version control on your schema classes (and all
539 of the rest of your code for that matter). Don't blame me if a bug in this
540 code wipes something out when it shouldn't have, you've been warned.
542 =head2 overwrite_modifications
544 Default false. If false, when updating existing files, Loader will
545 refuse to modify any Loader-generated code that has been modified
546 since its last run (as determined by the checksum Loader put in its
549 If true, Loader will discard any manual modifications that have been
550 made to Loader-generated code.
552 Again, you should be using version control on your schema classes. Be
553 careful with this option.
555 =head2 custom_column_info
557 Hook for adding extra attributes to the
558 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
560 Must be a coderef that returns a hashref with the extra attributes.
562 Receives the table name, column name and column_info.
566 custom_column_info => sub {
567 my ($table_name, $column_name, $column_info) = @_;
569 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
570 return { is_snoopy => 1 };
574 This attribute can also be used to set C<inflate_datetime> on a non-datetime
575 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
577 =head2 datetime_timezone
579 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
580 columns with the DATE/DATETIME/TIMESTAMP data_types.
582 =head2 datetime_locale
584 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
585 columns with the DATE/DATETIME/TIMESTAMP data_types.
587 =head2 datetime_undef_if_invalid
589 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
590 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
593 The default is recommended to deal with data such as C<00/00/00> which
594 sometimes ends up in such columns in MySQL.
598 File in Perl format, which should return a HASH reference, from which to read
603 Usually column names are lowercased, to make them easier to work with in
604 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
607 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
608 case-sensitive collation will turn this option on unconditionally.
610 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
613 =head2 qualify_objects
615 Set to true to prepend the L</db_schema> to table names for C<<
616 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
620 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
621 L<namespace::autoclean>. The default content after the md5 sum also makes the
624 It is safe to upgrade your existing Schema to this option.
626 =head2 col_collision_map
628 This option controls how accessors for column names which collide with perl
629 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
631 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
632 strings which are compiled to regular expressions that map to
633 L<sprintf|perlfunc/sprintf> formats.
637 col_collision_map => 'column_%s'
639 col_collision_map => { '(.*)' => 'column_%s' }
641 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
643 =head2 rel_collision_map
645 Works just like L</col_collision_map>, but for relationship names/accessors
646 rather than column names/accessors.
648 The default is to just append C<_rel> to the relationship name, see
649 L</RELATIONSHIP NAME COLLISIONS>.
651 =head2 uniq_to_primary
653 Automatically promotes the largest unique constraints with non-nullable columns
654 on tables to primary keys, assuming there is only one largest unique
659 None of these methods are intended for direct invocation by regular
660 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
661 L<DBIx::Class::Schema::Loader>.
665 # ensure that a peice of object data is a valid arrayref, creating
666 # an empty one or encapsulating whatever's there.
667 sub _ensure_arrayref {
672 $self->{$_} = [ $self->{$_} ]
673 unless ref $self->{$_} eq 'ARRAY';
679 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
680 by L<DBIx::Class::Schema::Loader>.
685 my ( $class, %args ) = @_;
687 if (exists $args{column_accessor_map}) {
688 $args{col_accessor_map} = delete $args{column_accessor_map};
691 my $self = { %args };
693 # don't lose undef options
694 for (values %$self) {
695 $_ = 0 unless defined $_;
698 bless $self => $class;
700 if (my $config_file = $self->config_file) {
701 my $config_opts = do $config_file;
703 croak "Error reading config from $config_file: $@" if $@;
705 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
707 while (my ($k, $v) = each %$config_opts) {
708 $self->{$k} = $v unless exists $self->{$k};
712 if (defined $self->{result_component_map}) {
713 if (defined $self->result_components_map) {
714 croak "Specify only one of result_components_map or result_component_map";
716 $self->result_components_map($self->{result_component_map})
719 if (defined $self->{result_role_map}) {
720 if (defined $self->result_roles_map) {
721 croak "Specify only one of result_roles_map or result_role_map";
723 $self->result_roles_map($self->{result_role_map})
726 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
727 if ((not defined $self->use_moose) || (not $self->use_moose))
728 && ((defined $self->result_roles) || (defined $self->result_roles_map));
730 $self->_ensure_arrayref(qw/schema_components
732 additional_base_classes
738 $self->_validate_class_args;
740 croak "result_components_map must be a hash"
741 if defined $self->result_components_map
742 && ref $self->result_components_map ne 'HASH';
744 if ($self->result_components_map) {
745 my %rc_map = %{ $self->result_components_map };
746 foreach my $moniker (keys %rc_map) {
747 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
749 $self->result_components_map(\%rc_map);
752 $self->result_components_map({});
754 $self->_validate_result_components_map;
756 croak "result_roles_map must be a hash"
757 if defined $self->result_roles_map
758 && ref $self->result_roles_map ne 'HASH';
760 if ($self->result_roles_map) {
761 my %rr_map = %{ $self->result_roles_map };
762 foreach my $moniker (keys %rr_map) {
763 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
765 $self->result_roles_map(\%rr_map);
767 $self->result_roles_map({});
769 $self->_validate_result_roles_map;
771 if ($self->use_moose) {
772 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
773 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
774 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
778 $self->{monikers} = {};
779 $self->{tables} = {};
780 $self->{class_to_table} = {};
781 $self->{classes} = {};
782 $self->{_upgrading_classes} = {};
784 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
785 $self->{schema} ||= $self->{schema_class};
787 croak "dump_overwrite is deprecated. Please read the"
788 . " DBIx::Class::Schema::Loader::Base documentation"
789 if $self->{dump_overwrite};
791 $self->{dynamic} = ! $self->{dump_directory};
792 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
797 $self->{dump_directory} ||= $self->{temp_directory};
799 $self->real_dump_directory($self->{dump_directory});
801 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
802 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
804 if (not defined $self->naming) {
805 $self->naming_set(0);
808 $self->naming_set(1);
811 if ((not ref $self->naming) && defined $self->naming) {
812 my $naming_ver = $self->naming;
814 relationships => $naming_ver,
815 monikers => $naming_ver,
816 column_accessors => $naming_ver,
821 for (values %{ $self->naming }) {
822 $_ = $CURRENT_V if $_ eq 'current';
825 $self->{naming} ||= {};
827 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
828 croak 'custom_column_info must be a CODE ref';
831 $self->_check_back_compat;
833 $self->use_namespaces(1) unless defined $self->use_namespaces;
834 $self->generate_pod(1) unless defined $self->generate_pod;
835 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
836 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
838 if (my $col_collision_map = $self->col_collision_map) {
839 if (my $reftype = ref $col_collision_map) {
840 if ($reftype ne 'HASH') {
841 croak "Invalid type $reftype for option 'col_collision_map'";
845 $self->col_collision_map({ '(.*)' => $col_collision_map });
849 if (my $rel_collision_map = $self->rel_collision_map) {
850 if (my $reftype = ref $rel_collision_map) {
851 if ($reftype ne 'HASH') {
852 croak "Invalid type $reftype for option 'rel_collision_map'";
856 $self->rel_collision_map({ '(.*)' => $rel_collision_map });
860 if (defined(my $rel_name_map = $self->rel_name_map)) {
861 my $reftype = ref $rel_name_map;
862 if ($reftype ne 'HASH' && $reftype ne 'CODE') {
863 croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
870 sub _check_back_compat {
873 # dynamic schemas will always be in 0.04006 mode, unless overridden
874 if ($self->dynamic) {
875 # just in case, though no one is likely to dump a dynamic schema
876 $self->schema_version_to_dump('0.04006');
878 if (not $self->naming_set) {
879 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
881 Dynamic schema detected, will run in 0.04006 mode.
883 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
884 to disable this warning.
886 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
891 $self->_upgrading_from('v4');
894 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
895 $self->use_namespaces(1);
898 $self->naming->{relationships} ||= 'v4';
899 $self->naming->{monikers} ||= 'v4';
901 if ($self->use_namespaces) {
902 $self->_upgrading_from_load_classes(1);
905 $self->use_namespaces(0);
911 # otherwise check if we need backcompat mode for a static schema
912 my $filename = $self->get_dump_filename($self->schema_class);
913 return unless -e $filename;
915 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
916 $self->_parse_generated_file($filename);
918 return unless $old_ver;
920 # determine if the existing schema was dumped with use_moose => 1
921 if (! defined $self->use_moose) {
922 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
925 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
927 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
928 my $ds = eval $result_namespace;
930 Could not eval expression '$result_namespace' for result_namespace from
933 $result_namespace = $ds || '';
935 if ($load_classes && (not defined $self->use_namespaces)) {
936 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
938 'load_classes;' static schema detected, turning off 'use_namespaces'.
940 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
941 variable to disable this warning.
943 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
946 $self->use_namespaces(0);
948 elsif ($load_classes && $self->use_namespaces) {
949 $self->_upgrading_from_load_classes(1);
951 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
952 $self->_downgrading_to_load_classes(
953 $result_namespace || 'Result'
956 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
957 if (not $self->result_namespace) {
958 $self->result_namespace($result_namespace || 'Result');
960 elsif ($result_namespace ne $self->result_namespace) {
961 $self->_rewriting_result_namespace(
962 $result_namespace || 'Result'
967 # XXX when we go past .0 this will need fixing
968 my ($v) = $old_ver =~ /([1-9])/;
971 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
973 if (not %{ $self->naming }) {
974 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
976 Version $old_ver static schema detected, turning on backcompat mode.
978 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
979 to disable this warning.
981 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
983 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
984 from version 0.04006.
987 $self->naming->{relationships} ||= $v;
988 $self->naming->{monikers} ||= $v;
989 $self->naming->{column_accessors} ||= $v;
991 $self->schema_version_to_dump($old_ver);
994 $self->_upgrading_from($v);
998 sub _validate_class_args {
1001 foreach my $k (@CLASS_ARGS) {
1002 next unless $self->$k;
1004 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
1005 $self->_validate_classes($k, \@classes);
1009 sub _validate_result_components_map {
1012 foreach my $classes (values %{ $self->result_components_map }) {
1013 $self->_validate_classes('result_components_map', $classes);
1017 sub _validate_result_roles_map {
1020 foreach my $classes (values %{ $self->result_roles_map }) {
1021 $self->_validate_classes('result_roles_map', $classes);
1025 sub _validate_classes {
1028 my $classes = shift;
1030 # make a copy to not destroy original
1031 my @classes = @$classes;
1033 foreach my $c (@classes) {
1034 # components default to being under the DBIx::Class namespace unless they
1035 # are preceeded with a '+'
1036 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1037 $c = 'DBIx::Class::' . $c;
1040 # 1 == installed, 0 == not installed, undef == invalid classname
1041 my $installed = Class::Inspector->installed($c);
1042 if ( defined($installed) ) {
1043 if ( $installed == 0 ) {
1044 croak qq/$c, as specified in the loader option "$key", is not installed/;
1047 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1053 sub _find_file_in_inc {
1054 my ($self, $file) = @_;
1056 foreach my $prefix (@INC) {
1057 my $fullpath = File::Spec->catfile($prefix, $file);
1058 return $fullpath if -f $fullpath
1059 # abs_path throws on Windows for nonexistant files
1060 and (try { Cwd::abs_path($fullpath) }) ne
1061 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1067 sub _find_class_in_inc {
1068 my ($self, $class) = @_;
1070 return $self->_find_file_in_inc(class_path($class));
1076 return $self->_upgrading_from
1077 || $self->_upgrading_from_load_classes
1078 || $self->_downgrading_to_load_classes
1079 || $self->_rewriting_result_namespace
1083 sub _rewrite_old_classnames {
1084 my ($self, $code) = @_;
1086 return $code unless $self->_rewriting;
1088 my %old_classes = reverse %{ $self->_upgrading_classes };
1090 my $re = join '|', keys %old_classes;
1091 $re = qr/\b($re)\b/;
1093 $code =~ s/$re/$old_classes{$1} || $1/eg;
1098 sub _load_external {
1099 my ($self, $class) = @_;
1101 return if $self->{skip_load_external};
1103 # so that we don't load our own classes, under any circumstances
1104 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1106 my $real_inc_path = $self->_find_class_in_inc($class);
1108 my $old_class = $self->_upgrading_classes->{$class}
1109 if $self->_rewriting;
1111 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1112 if $old_class && $old_class ne $class;
1114 return unless $real_inc_path || $old_real_inc_path;
1116 if ($real_inc_path) {
1117 # If we make it to here, we loaded an external definition
1118 warn qq/# Loaded external class definition for '$class'\n/
1121 my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path);
1123 if ($self->dynamic) { # load the class too
1124 eval_package_without_redefine_warnings($class, $code);
1127 $self->_ext_stmt($class,
1128 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1129 .qq|# They are now part of the custom portion of this file\n|
1130 .qq|# for you to hand-edit. If you do not either delete\n|
1131 .qq|# this section or remove that file from \@INC, this section\n|
1132 .qq|# will be repeated redundantly when you re-create this\n|
1133 .qq|# file again via Loader! See skip_load_external to disable\n|
1134 .qq|# this feature.\n|
1137 $self->_ext_stmt($class, $code);
1138 $self->_ext_stmt($class,
1139 qq|# End of lines loaded from '$real_inc_path' |
1143 if ($old_real_inc_path) {
1144 my $code = slurp_file $old_real_inc_path;
1146 $self->_ext_stmt($class, <<"EOF");
1148 # These lines were loaded from '$old_real_inc_path',
1149 # based on the Result class name that would have been created by an older
1150 # version of the Loader. For a static schema, this happens only once during
1151 # upgrade. See skip_load_external to disable this feature.
1154 $code = $self->_rewrite_old_classnames($code);
1156 if ($self->dynamic) {
1159 Detected external content in '$old_real_inc_path', a class name that would have
1160 been used by an older version of the Loader.
1162 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1163 new name of the Result.
1165 eval_package_without_redefine_warnings($class, $code);
1169 $self->_ext_stmt($class, $code);
1170 $self->_ext_stmt($class,
1171 qq|# End of lines loaded from '$old_real_inc_path' |
1178 Does the actual schema-construction work.
1185 $self->_load_tables(
1186 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1194 Rescan the database for changes. Returns a list of the newly added table
1197 The schema argument should be the schema class or object to be affected. It
1198 should probably be derived from the original schema_class used during L</load>.
1203 my ($self, $schema) = @_;
1205 $self->{schema} = $schema;
1206 $self->_relbuilder->{schema} = $schema;
1209 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1211 foreach my $table (@current) {
1212 if(!exists $self->{_tables}->{$table}) {
1213 push(@created, $table);
1218 @current{@current} = ();
1219 foreach my $table (keys %{ $self->{_tables} }) {
1220 if (not exists $current{$table}) {
1221 $self->_unregister_source_for_table($table);
1225 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1227 my $loaded = $self->_load_tables(@current);
1229 return map { $self->monikers->{$_} } @created;
1235 return if $self->{skip_relationships};
1237 return $self->{relbuilder} ||= do {
1239 no warnings 'uninitialized';
1240 my $relbuilder_suff =
1246 ->{ $self->naming->{relationships}};
1248 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1249 $self->ensure_class_loaded($relbuilder_class);
1250 $relbuilder_class->new( $self );
1256 my ($self, @tables) = @_;
1258 # Save the new tables to the tables list
1260 $self->{_tables}->{$_} = 1;
1263 $self->_make_src_class($_) for @tables;
1265 # sanity-check for moniker clashes
1266 my $inverse_moniker_idx;
1267 for (keys %{$self->monikers}) {
1268 push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1272 for (keys %$inverse_moniker_idx) {
1273 my $tables = $inverse_moniker_idx->{$_};
1275 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1276 join (', ', map { "'$_'" } @$tables),
1283 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1284 . 'Either change the naming style, or supply an explicit moniker_map: '
1285 . join ('; ', @clashes)
1291 $self->_setup_src_meta($_) for @tables;
1293 if(!$self->skip_relationships) {
1294 # The relationship loader needs a working schema
1295 local $self->{quiet} = 1;
1296 local $self->{dump_directory} = $self->{temp_directory};
1297 $self->_reload_classes(\@tables);
1298 $self->_load_relationships(\@tables);
1300 # Remove that temp dir from INC so it doesn't get reloaded
1301 @INC = grep $_ ne $self->dump_directory, @INC;
1304 $self->_load_roles($_) for @tables;
1306 $self->_load_external($_)
1307 for map { $self->classes->{$_} } @tables;
1309 # Reload without unloading first to preserve any symbols from external
1311 $self->_reload_classes(\@tables, { unload => 0 });
1313 # Drop temporary cache
1314 delete $self->{_cache};
1319 sub _reload_classes {
1320 my ($self, $tables, $opts) = @_;
1322 my @tables = @$tables;
1324 my $unload = $opts->{unload};
1325 $unload = 1 unless defined $unload;
1327 # so that we don't repeat custom sections
1328 @INC = grep $_ ne $self->dump_directory, @INC;
1330 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1332 unshift @INC, $self->dump_directory;
1335 my %have_source = map { $_ => $self->schema->source($_) }
1336 $self->schema->sources;
1338 for my $table (@tables) {
1339 my $moniker = $self->monikers->{$table};
1340 my $class = $self->classes->{$table};
1343 no warnings 'redefine';
1344 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1347 if (my $mc = $self->_moose_metaclass($class)) {
1350 Class::Unload->unload($class) if $unload;
1351 my ($source, $resultset_class);
1353 ($source = $have_source{$moniker})
1354 && ($resultset_class = $source->resultset_class)
1355 && ($resultset_class ne 'DBIx::Class::ResultSet')
1357 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1358 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1361 Class::Unload->unload($resultset_class) if $unload;
1362 $self->_reload_class($resultset_class) if $has_file;
1364 $self->_reload_class($class);
1366 push @to_register, [$moniker, $class];
1369 Class::C3->reinitialize;
1370 for (@to_register) {
1371 $self->schema->register_class(@$_);
1375 sub _moose_metaclass {
1376 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1380 my $mc = try { Class::MOP::class_of($class) }
1383 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1386 # We use this instead of ensure_class_loaded when there are package symbols we
1389 my ($self, $class) = @_;
1391 delete $INC{ +class_path($class) };
1394 eval_package_without_redefine_warnings ($class, "require $class");
1397 my $source = slurp_file $self->_get_dump_filename($class);
1398 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1402 sub _get_dump_filename {
1403 my ($self, $class) = (@_);
1405 $class =~ s{::}{/}g;
1406 return $self->dump_directory . q{/} . $class . q{.pm};
1409 =head2 get_dump_filename
1413 Returns the full path to the file for a class that the class has been or will
1414 be dumped to. This is a file in a temp dir for a dynamic schema.
1418 sub get_dump_filename {
1419 my ($self, $class) = (@_);
1421 local $self->{dump_directory} = $self->real_dump_directory;
1423 return $self->_get_dump_filename($class);
1426 sub _ensure_dump_subdirs {
1427 my ($self, $class) = (@_);
1429 my @name_parts = split(/::/, $class);
1430 pop @name_parts; # we don't care about the very last element,
1431 # which is a filename
1433 my $dir = $self->dump_directory;
1436 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1438 last if !@name_parts;
1439 $dir = File::Spec->catdir($dir, shift @name_parts);
1444 my ($self, @classes) = @_;
1446 my $schema_class = $self->schema_class;
1447 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1449 my $target_dir = $self->dump_directory;
1450 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1451 unless $self->dynamic or $self->quiet;
1454 qq|package $schema_class;\n\n|
1455 . qq|# Created by DBIx::Class::Schema::Loader\n|
1456 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1458 if ($self->use_moose) {
1459 $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1462 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1465 my @schema_components = @{ $self->schema_components || [] };
1467 if (@schema_components) {
1468 my $schema_components = dump @schema_components;
1469 $schema_components = "($schema_components)" if @schema_components == 1;
1471 $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1474 if ($self->use_namespaces) {
1475 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1476 my $namespace_options;
1478 my @attr = qw/resultset_namespace default_resultset_class/;
1480 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1482 for my $attr (@attr) {
1484 my $code = dumper_squashed $self->$attr;
1485 $namespace_options .= qq| $attr => $code,\n|
1488 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1489 $schema_text .= qq|;\n|;
1492 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1496 local $self->{version_to_dump} = $self->schema_version_to_dump;
1497 $self->_write_classfile($schema_class, $schema_text, 1);
1500 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1502 foreach my $src_class (@classes) {
1504 qq|package $src_class;\n\n|
1505 . qq|# Created by DBIx::Class::Schema::Loader\n|
1506 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1508 $src_text .= $self->_make_pod_heading($src_class);
1510 $src_text .= qq|use strict;\nuse warnings;\n\n|;
1512 $src_text .= $self->_base_class_pod($result_base_class)
1513 unless $result_base_class eq 'DBIx::Class::Core';
1515 if ($self->use_moose) {
1516 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1518 # these options 'use base' which is compile time
1519 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1520 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1523 $src_text .= qq|\nextends '$result_base_class';\n|;
1527 $src_text .= qq|use base '$result_base_class';\n|;
1530 $self->_write_classfile($src_class, $src_text);
1533 # remove Result dir if downgrading from use_namespaces, and there are no
1535 if (my $result_ns = $self->_downgrading_to_load_classes
1536 || $self->_rewriting_result_namespace) {
1537 my $result_namespace = $self->_result_namespace(
1542 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1543 $result_dir = $self->dump_directory . '/' . $result_dir;
1545 unless (my @files = glob "$result_dir/*") {
1550 warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
1555 my ($self, $version, $ts) = @_;
1556 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1559 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1562 sub _write_classfile {
1563 my ($self, $class, $text, $is_schema) = @_;
1565 my $filename = $self->_get_dump_filename($class);
1566 $self->_ensure_dump_subdirs($class);
1568 if (-f $filename && $self->really_erase_my_files) {
1569 warn "Deleting existing file '$filename' due to "
1570 . "'really_erase_my_files' setting\n" unless $self->quiet;
1574 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1575 = $self->_parse_generated_file($filename);
1577 if (! $old_gen && -f $filename) {
1578 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1579 . " it does not appear to have been generated by Loader"
1582 my $custom_content = $old_custom || '';
1584 # prepend extra custom content from a *renamed* class (singularization effect)
1585 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1586 my $old_filename = $self->_get_dump_filename($renamed_class);
1588 if (-f $old_filename) {
1589 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1591 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1593 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1596 unlink $old_filename;
1600 $custom_content ||= $self->_default_custom_content($is_schema);
1602 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1603 # If there is already custom content, which does not have the Moose content, add it.
1604 if ($self->use_moose) {
1606 my $non_moose_custom_content = do {
1607 local $self->{use_moose} = 0;
1608 $self->_default_custom_content;
1611 if ($custom_content eq $non_moose_custom_content) {
1612 $custom_content = $self->_default_custom_content($is_schema);
1614 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1615 $custom_content .= $self->_default_custom_content($is_schema);
1618 elsif (defined $self->use_moose && $old_gen) {
1619 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'
1620 if $old_gen =~ /use \s+ MooseX?\b/x;
1623 $custom_content = $self->_rewrite_old_classnames($custom_content);
1626 for @{$self->{_dump_storage}->{$class} || []};
1628 # Check and see if the dump is infact differnt
1632 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1633 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1634 return unless $self->_upgrading_from && $is_schema;
1638 $text .= $self->_sig_comment(
1639 $self->version_to_dump,
1640 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1643 open(my $fh, '>:encoding(UTF-8)', $filename)
1644 or croak "Cannot open '$filename' for writing: $!";
1646 # Write the top half and its MD5 sum
1647 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1649 # Write out anything loaded via external partial class file in @INC
1651 for @{$self->{_ext_storage}->{$class} || []};
1653 # Write out any custom content the user has added
1654 print $fh $custom_content;
1657 or croak "Error closing '$filename': $!";
1660 sub _default_moose_custom_content {
1661 my ($self, $is_schema) = @_;
1663 if (not $is_schema) {
1664 return qq|\n__PACKAGE__->meta->make_immutable;|;
1667 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1670 sub _default_custom_content {
1671 my ($self, $is_schema) = @_;
1672 my $default = qq|\n\n# You can replace this text with custom|
1673 . qq| code or comments, and it will be preserved on regeneration|;
1674 if ($self->use_moose) {
1675 $default .= $self->_default_moose_custom_content($is_schema);
1677 $default .= qq|\n1;\n|;
1681 sub _parse_generated_file {
1682 my ($self, $fn) = @_;
1684 return unless -f $fn;
1686 open(my $fh, '<:encoding(UTF-8)', $fn)
1687 or croak "Cannot open '$fn' for reading: $!";
1690 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
1692 my ($md5, $ts, $ver, $gen);
1698 # Pull out the version and timestamp from the line above
1699 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m;
1702 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"
1703 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
1712 my $custom = do { local $/; <$fh> }
1716 $custom =~ s/$CRLF|$LF/\n/g;
1720 return ($gen, $md5, $ver, $ts, $custom);
1728 warn "$target: use $_;" if $self->debug;
1729 $self->_raw_stmt($target, "use $_;");
1737 my $blist = join(q{ }, @_);
1739 return unless $blist;
1741 warn "$target: use base qw/$blist/;" if $self->debug;
1742 $self->_raw_stmt($target, "use base qw/$blist/;");
1749 my $rlist = join(q{, }, map { qq{'$_'} } @_);
1751 return unless $rlist;
1753 warn "$target: with $rlist;" if $self->debug;
1754 $self->_raw_stmt($target, "\nwith $rlist;");
1757 sub _result_namespace {
1758 my ($self, $schema_class, $ns) = @_;
1759 my @result_namespace;
1761 $ns = $ns->[0] if ref $ns;
1763 if ($ns =~ /^\+(.*)/) {
1764 # Fully qualified namespace
1765 @result_namespace = ($1)
1768 # Relative namespace
1769 @result_namespace = ($schema_class, $ns);
1772 return wantarray ? @result_namespace : join '::', @result_namespace;
1775 # Create class with applicable bases, setup monikers, etc
1776 sub _make_src_class {
1777 my ($self, $table) = @_;
1779 my $schema = $self->schema;
1780 my $schema_class = $self->schema_class;
1782 my $table_moniker = $self->_table2moniker($table);
1783 my @result_namespace = ($schema_class);
1784 if ($self->use_namespaces) {
1785 my $result_namespace = $self->result_namespace || 'Result';
1786 @result_namespace = $self->_result_namespace(
1791 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1793 if ((my $upgrading_v = $self->_upgrading_from)
1794 || $self->_rewriting) {
1795 local $self->naming->{monikers} = $upgrading_v
1798 my @result_namespace = @result_namespace;
1799 if ($self->_upgrading_from_load_classes) {
1800 @result_namespace = ($schema_class);
1802 elsif (my $ns = $self->_downgrading_to_load_classes) {
1803 @result_namespace = $self->_result_namespace(
1808 elsif ($ns = $self->_rewriting_result_namespace) {
1809 @result_namespace = $self->_result_namespace(
1815 my $old_class = join(q{::}, @result_namespace,
1816 $self->_table2moniker($table));
1818 $self->_upgrading_classes->{$table_class} = $old_class
1819 unless $table_class eq $old_class;
1822 $self->classes->{$table} = $table_class;
1823 $self->monikers->{$table} = $table_moniker;
1824 $self->tables->{$table_moniker} = $table;
1825 $self->class_to_table->{$table_class} = $table;
1827 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
1829 $self->_use ($table_class, @{$self->additional_classes});
1831 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
1833 $self->_inject($table_class, @{$self->left_base_classes});
1835 my @components = @{ $self->components || [] };
1837 push @components, @{ $self->result_components_map->{$table_moniker} }
1838 if exists $self->result_components_map->{$table_moniker};
1840 my @fq_components = @components;
1841 foreach my $component (@fq_components) {
1842 if ($component !~ s/^\+//) {
1843 $component = "DBIx::Class::$component";
1847 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
1849 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
1851 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
1853 $self->_inject($table_class, @{$self->additional_base_classes});
1856 sub _is_result_class_method {
1857 my ($self, $name, $table_name) = @_;
1859 my $table_moniker = $table_name ? $self->monikers->{$table_name} : '';
1861 $self->_result_class_methods({})
1862 if not defined $self->_result_class_methods;
1864 if (not exists $self->_result_class_methods->{$table_moniker}) {
1865 my (@methods, %methods);
1866 my $base = $self->result_base_class || 'DBIx::Class::Core';
1868 my @components = @{ $self->components || [] };
1870 push @components, @{ $self->result_components_map->{$table_moniker} }
1871 if exists $self->result_components_map->{$table_moniker};
1873 for my $c (@components) {
1874 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
1877 my @roles = @{ $self->result_roles || [] };
1879 push @roles, @{ $self->result_roles_map->{$table_moniker} }
1880 if exists $self->result_roles_map->{$table_moniker};
1882 for my $class ($base, @components,
1883 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
1884 $self->ensure_class_loaded($class);
1886 push @methods, @{ Class::Inspector->methods($class) || [] };
1889 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1891 @methods{@methods} = ();
1893 $self->_result_class_methods->{$table_moniker} = \%methods;
1895 my $result_methods = $self->_result_class_methods->{$table_moniker};
1897 return exists $result_methods->{$name};
1900 sub _resolve_col_accessor_collisions {
1901 my ($self, $table, $col_info) = @_;
1903 my $table_name = ref $table ? $$table : $table;
1905 while (my ($col, $info) = each %$col_info) {
1906 my $accessor = $info->{accessor} || $col;
1908 next if $accessor eq 'id'; # special case (very common column)
1910 if ($self->_is_result_class_method($accessor, $table_name)) {
1913 if (my $map = $self->col_collision_map) {
1914 for my $re (keys %$map) {
1915 if (my @matches = $col =~ /$re/) {
1916 $info->{accessor} = sprintf $map->{$re}, @matches;
1924 Column '$col' in table '$table_name' collides with an inherited method.
1925 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1927 $info->{accessor} = undef;
1933 # use the same logic to run moniker_map, col_accessor_map
1935 my ( $self, $map, $default_code, $ident, @extra ) = @_;
1937 my $default_ident = $default_code->( $ident, @extra );
1939 if( $map && ref $map eq 'HASH' ) {
1940 $new_ident = $map->{ $ident };
1942 elsif( $map && ref $map eq 'CODE' ) {
1943 $new_ident = $map->( $ident, $default_ident, @extra );
1946 $new_ident ||= $default_ident;
1951 sub _default_column_accessor_name {
1952 my ( $self, $column_name ) = @_;
1954 my $accessor_name = $column_name;
1955 $accessor_name =~ s/\W+/_/g;
1957 if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
1958 # older naming just lc'd the col accessor and that's all.
1959 return lc $accessor_name;
1961 elsif (($self->naming->{column_accessors}||'') eq 'preserve') {
1962 return $accessor_name;
1965 return join '_', map lc, split_name $column_name;
1968 sub _make_column_accessor_name {
1969 my ($self, $column_name, $column_context_info ) = @_;
1971 my $accessor = $self->_run_user_map(
1972 $self->col_accessor_map,
1973 sub { $self->_default_column_accessor_name( shift ) },
1975 $column_context_info,
1982 my ($self, $identifier) = @_;
1984 my $qt = $self->schema->storage->sql_maker->quote_char || '';
1987 return $qt->[0] . $identifier . $qt->[1];
1990 return "${qt}${identifier}${qt}";
1993 # Set up metadata (cols, pks, etc)
1994 sub _setup_src_meta {
1995 my ($self, $table) = @_;
1997 my $schema = $self->schema;
1998 my $schema_class = $self->schema_class;
2000 my $table_class = $self->classes->{$table};
2001 my $table_moniker = $self->monikers->{$table};
2003 my $table_name = $table;
2005 my $sql_maker = $self->schema->storage->sql_maker;
2006 my $name_sep = $sql_maker->name_sep;
2008 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
2009 $table_name = \ $self->_quote($table_name);
2012 my $full_table_name = ($self->qualify_objects ?
2013 ($self->_quote($self->db_schema) . '.') : '')
2014 . (ref $table_name ? $$table_name : $table_name);
2016 # be careful to not create refs Data::Dump can "optimize"
2017 $full_table_name = \do {"".$full_table_name} if ref $table_name;
2019 $self->_dbic_stmt($table_class, 'table', $full_table_name);
2021 my $cols = $self->_table_columns($table);
2022 my $col_info = $self->__columns_info_for($table);
2024 ### generate all the column accessor names
2025 while (my ($col, $info) = each %$col_info) {
2026 # hashref of other info that could be used by
2027 # user-defined accessor map functions
2029 table_class => $table_class,
2030 table_moniker => $table_moniker,
2031 table_name => $table_name,
2032 full_table_name => $full_table_name,
2033 schema_class => $schema_class,
2034 column_info => $info,
2037 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2040 $self->_resolve_col_accessor_collisions($table, $col_info);
2042 # prune any redundant accessor names
2043 while (my ($col, $info) = each %$col_info) {
2044 no warnings 'uninitialized';
2045 delete $info->{accessor} if $info->{accessor} eq $col;
2048 my $fks = $self->_table_fk_info($table);
2050 foreach my $fkdef (@$fks) {
2051 for my $col (@{ $fkdef->{local_columns} }) {
2052 $col_info->{$col}{is_foreign_key} = 1;
2056 my $pks = $self->_table_pk_info($table) || [];
2058 my %uniq_tag; # used to eliminate duplicate uniqs
2060 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2062 my $uniqs = $self->_table_uniq_info($table) || [];
2065 foreach my $uniq (@$uniqs) {
2066 my ($name, $cols) = @$uniq;
2067 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2068 push @uniqs, [$name, $cols];
2071 my @non_nullable_uniqs = grep {
2072 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2075 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2076 my @by_colnum = sort { $b->[0] <=> $a->[0] }
2077 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2079 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2080 my @keys = map $_->[1], @by_colnum;
2084 # remove the uniq from list
2085 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2091 foreach my $pkcol (@$pks) {
2092 $col_info->{$pkcol}{is_nullable} = 0;
2098 map { $_, ($col_info->{$_}||{}) } @$cols
2101 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2104 foreach my $uniq (@uniqs) {
2105 my ($name, $cols) = @$uniq;
2106 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2110 sub __columns_info_for {
2111 my ($self, $table) = @_;
2113 my $result = $self->_columns_info_for($table);
2115 while (my ($col, $info) = each %$result) {
2116 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
2117 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2119 $result->{$col} = $info;
2127 Returns a sorted list of loaded tables, using the original database table
2135 return keys %{$self->_tables};
2138 # Make a moniker from a table
2139 sub _default_table2moniker {
2140 no warnings 'uninitialized';
2141 my ($self, $table) = @_;
2143 if ($self->naming->{monikers} eq 'v4') {
2144 return join '', map ucfirst, split /[\W_]+/, lc $table;
2146 elsif ($self->naming->{monikers} eq 'v5') {
2147 return join '', map ucfirst, split /[\W_]+/,
2148 Lingua::EN::Inflect::Number::to_S(lc $table);
2150 elsif ($self->naming->{monikers} eq 'v6') {
2151 (my $as_phrase = lc $table) =~ s/_+/ /g;
2152 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2154 return join '', map ucfirst, split /\W+/, $inflected;
2157 my @words = map lc, split_name $table;
2158 my $as_phrase = join ' ', @words;
2160 my $inflected = $self->naming->{monikers} eq 'plural' ?
2161 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2163 $self->naming->{monikers} eq 'preserve' ?
2166 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2168 return join '', map ucfirst, split /\W+/, $inflected;
2171 sub _table2moniker {
2172 my ( $self, $table ) = @_;
2174 $self->_run_user_map(
2176 sub { $self->_default_table2moniker( shift ) },
2181 sub _load_relationships {
2182 my ($self, $tables) = @_;
2186 foreach my $table (@$tables) {
2187 my $tbl_fk_info = $self->_table_fk_info($table);
2188 foreach my $fkdef (@$tbl_fk_info) {
2189 $fkdef->{remote_source} =
2190 $self->monikers->{delete $fkdef->{remote_table}};
2192 my $tbl_uniq_info = $self->_table_uniq_info($table);
2194 my $local_moniker = $self->monikers->{$table};
2196 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2199 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2201 foreach my $src_class (sort keys %$rel_stmts) {
2203 my @src_stmts = map $_->[1],
2204 sort { $a->[0] cmp $b->[0] }
2205 map [ $_->{args}[0], $_ ], @{ $rel_stmts->{$src_class} };
2207 foreach my $stmt (@src_stmts) {
2208 $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2214 my ($self, $table) = @_;
2216 my $table_moniker = $self->monikers->{$table};
2217 my $table_class = $self->classes->{$table};
2219 my @roles = @{ $self->result_roles || [] };
2220 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2221 if exists $self->result_roles_map->{$table_moniker};
2224 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2226 $self->_with($table_class, @roles);
2230 # Overload these in driver class:
2232 # Returns an arrayref of column names
2233 sub _table_columns { croak "ABSTRACT METHOD" }
2235 # Returns arrayref of pk col names
2236 sub _table_pk_info { croak "ABSTRACT METHOD" }
2238 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2239 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2241 # Returns an arrayref of foreign key constraints, each
2242 # being a hashref with 3 keys:
2243 # local_columns (arrayref), remote_columns (arrayref), remote_table
2244 sub _table_fk_info { croak "ABSTRACT METHOD" }
2246 # Returns an array of lower case table names
2247 sub _tables_list { croak "ABSTRACT METHOD" }
2249 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2255 # generate the pod for this statement, storing it with $self->_pod
2256 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2258 my $args = dump(@_);
2259 $args = '(' . $args . ')' if @_ < 2;
2260 my $stmt = $method . $args . q{;};
2262 warn qq|$class\->$stmt\n| if $self->debug;
2263 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2267 sub _make_pod_heading {
2268 my ($self, $class) = @_;
2270 return '' if not $self->generate_pod;
2272 my $table = $self->class_to_table->{$class};
2275 my $pcm = $self->pod_comment_mode;
2276 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2277 $comment = $self->__table_comment($table);
2278 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2279 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2280 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2282 $pod .= "=head1 NAME\n\n";
2284 my $table_descr = $class;
2285 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2287 $pod .= "$table_descr\n\n";
2289 if ($comment and $comment_in_desc) {
2290 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2297 # generates the accompanying pod for a DBIC class method statement,
2298 # storing it with $self->_pod
2304 if ($method eq 'table') {
2306 $table = $$table if ref $table eq 'SCALAR';
2307 $self->_pod($class, "=head1 TABLE: C<$table>");
2308 $self->_pod_cut($class);
2310 elsif ( $method eq 'add_columns' ) {
2311 $self->_pod( $class, "=head1 ACCESSORS" );
2312 my $col_counter = 0;
2314 while( my ($name,$attrs) = splice @cols,0,2 ) {
2316 $self->_pod( $class, '=head2 ' . $name );
2317 $self->_pod( $class,
2319 my $s = $attrs->{$_};
2320 $s = !defined $s ? 'undef' :
2321 length($s) == 0 ? '(empty string)' :
2322 ref($s) eq 'SCALAR' ? $$s :
2323 ref($s) ? dumper_squashed $s :
2324 looks_like_number($s) ? $s : qq{'$s'};
2327 } sort keys %$attrs,
2329 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2330 $self->_pod( $class, $comment );
2333 $self->_pod_cut( $class );
2334 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2335 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2336 my ( $accessor, $rel_class ) = @_;
2337 $self->_pod( $class, "=head2 $accessor" );
2338 $self->_pod( $class, 'Type: ' . $method );
2339 $self->_pod( $class, "Related object: L<$rel_class>" );
2340 $self->_pod_cut( $class );
2341 $self->{_relations_started} { $class } = 1;
2343 elsif ($method eq 'add_unique_constraint') {
2344 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2345 unless $self->{_uniqs_started}{$class};
2347 my ($name, $cols) = @_;
2349 $self->_pod($class, "=head2 C<$name>");
2350 $self->_pod($class, '=over 4');
2352 foreach my $col (@$cols) {
2353 $self->_pod($class, "=item \* L</$col>");
2356 $self->_pod($class, '=back');
2357 $self->_pod_cut($class);
2359 $self->{_uniqs_started}{$class} = 1;
2361 elsif ($method eq 'set_primary_key') {
2362 $self->_pod($class, "=head1 PRIMARY KEY");
2363 $self->_pod($class, '=over 4');
2365 foreach my $col (@_) {
2366 $self->_pod($class, "=item \* L</$col>");
2369 $self->_pod($class, '=back');
2370 $self->_pod_cut($class);
2374 sub _pod_class_list {
2375 my ($self, $class, $title, @classes) = @_;
2377 return unless @classes && $self->generate_pod;
2379 $self->_pod($class, "=head1 $title");
2380 $self->_pod($class, '=over 4');
2382 foreach my $link (@classes) {
2383 $self->_pod($class, "=item * L<$link>");
2386 $self->_pod($class, '=back');
2387 $self->_pod_cut($class);
2390 sub _base_class_pod {
2391 my ($self, $base_class) = @_;
2393 return unless $self->generate_pod;
2396 =head1 BASE CLASS: L<$base_class>
2403 sub _filter_comment {
2404 my ($self, $txt) = @_;
2406 $txt = '' if not defined $txt;
2408 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2413 sub __table_comment {
2416 if (my $code = $self->can('_table_comment')) {
2417 return $self->_filter_comment($self->$code(@_));
2423 sub __column_comment {
2426 if (my $code = $self->can('_column_comment')) {
2427 return $self->_filter_comment($self->$code(@_));
2433 # Stores a POD documentation
2435 my ($self, $class, $stmt) = @_;
2436 $self->_raw_stmt( $class, "\n" . $stmt );
2440 my ($self, $class ) = @_;
2441 $self->_raw_stmt( $class, "\n=cut\n" );
2444 # Store a raw source line for a class (for dumping purposes)
2446 my ($self, $class, $stmt) = @_;
2447 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2450 # Like above, but separately for the externally loaded stuff
2452 my ($self, $class, $stmt) = @_;
2453 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2456 sub _custom_column_info {
2457 my ( $self, $table_name, $column_name, $column_info ) = @_;
2459 if (my $code = $self->custom_column_info) {
2460 return $code->($table_name, $column_name, $column_info) || {};
2465 sub _datetime_column_info {
2466 my ( $self, $table_name, $column_name, $column_info ) = @_;
2468 my $type = $column_info->{data_type} || '';
2469 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2470 or ($type =~ /date|timestamp/i)) {
2471 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2472 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2478 my ($self, $name) = @_;
2480 return $self->preserve_case ? $name : lc($name);
2484 my ($self, $name) = @_;
2486 return $self->preserve_case ? $name : uc($name);
2489 sub _unregister_source_for_table {
2490 my ($self, $table) = @_;
2494 my $schema = $self->schema;
2495 # in older DBIC it's a private method
2496 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2497 $schema->$unregister($self->_table2moniker($table));
2498 delete $self->monikers->{$table};
2499 delete $self->classes->{$table};
2500 delete $self->_upgrading_classes->{$table};
2501 delete $self->{_tables}{$table};
2505 # remove the dump dir from @INC on destruction
2509 @INC = grep $_ ne $self->dump_directory, @INC;
2514 Returns a hashref of loaded table to moniker mappings. There will
2515 be two entries for each table, the original name and the "normalized"
2516 name, in the case that the two are different (such as databases
2517 that like uppercase table names, or preserve your original mixed-case
2518 definitions, or what-have-you).
2522 Returns a hashref of table to class mappings. In some cases it will
2523 contain multiple entries per table for the original and normalized table
2524 names, as above in L</monikers>.
2526 =head1 COLUMN ACCESSOR COLLISIONS
2528 Occasionally you may have a column name that collides with a perl method, such
2529 as C<can>. In such cases, the default action is to set the C<accessor> of the
2530 column spec to C<undef>.
2532 You can then name the accessor yourself by placing code such as the following
2535 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2537 Another option is to use the L</col_collision_map> option.
2539 =head1 RELATIONSHIP NAME COLLISIONS
2541 In very rare cases, you may get a collision between a generated relationship
2542 name and a method in your Result class, for example if you have a foreign key
2543 called C<belongs_to>.
2545 This is a problem because relationship names are also relationship accessor
2546 methods in L<DBIx::Class>.
2548 The default behavior is to append C<_rel> to the relationship name and print
2549 out a warning that refers to this text.
2551 You can also control the renaming with the L</rel_collision_map> option.
2555 L<DBIx::Class::Schema::Loader>
2559 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2563 This library is free software; you can redistribute it and/or modify it under
2564 the same terms as Perl itself.
2569 # vim:et sts=4 sw=4 tw=0: