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 File::Slurp 'read_file';
21 use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path/;
22 use DBIx::Class::Schema::Loader::Optional::Dependencies ();
25 use Encode qw/encode/;
26 use List::MoreUtils 'all';
29 our $VERSION = '0.07010';
31 __PACKAGE__->mk_group_ro_accessors('simple', qw/
38 additional_base_classes
54 default_resultset_class
59 overwrite_modifications
82 __PACKAGE__->mk_group_accessors('simple', qw/
84 schema_version_to_dump
86 _upgrading_from_load_classes
87 _downgrading_to_load_classes
88 _rewriting_result_namespace
93 pod_comment_spillover_length
101 datetime_undef_if_invalid
102 _result_class_methods
108 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
112 See L<DBIx::Class::Schema::Loader>
116 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
117 classes, and implements the common functionality between them.
119 =head1 CONSTRUCTOR OPTIONS
121 These constructor options are the base options for
122 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
124 =head2 skip_relationships
126 Skip setting up relationships. The default is to attempt the loading
129 =head2 skip_load_external
131 Skip loading of other classes in @INC. The default is to merge all other classes
132 with the same name found in @INC into the schema file we are creating.
136 Static schemas (ones dumped to disk) will, by default, use the new-style
137 relationship names and singularized Results, unless you're overwriting an
138 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
139 which case the backward compatible RelBuilder will be activated, and the
140 appropriate monikerization used.
146 will disable the backward-compatible RelBuilder and use
147 the new-style relationship names along with singularized Results, even when
148 overwriting a dump made with an earlier version.
150 The option also takes a hashref:
152 naming => { relationships => 'v7', monikers => 'v7' }
160 How to name relationship accessors.
164 How to name Result classes.
166 =item column_accessors
168 How to name column accessors in Result classes.
178 Latest style, whatever that happens to be.
182 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
186 Monikers singularized as whole words, C<might_have> relationships for FKs on
187 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
189 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
194 All monikers and relationships are inflected using
195 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
196 from relationship names.
198 In general, there is very little difference between v5 and v6 schemas.
202 This mode is identical to C<v6> mode, except that monikerization of CamelCase
203 table names is also done correctly.
205 CamelCase column names in case-preserving mode will also be handled correctly
206 for relationship name inflection. See L</preserve_case>.
208 In this mode, CamelCase L</column_accessors> are normalized based on case
209 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
211 If you don't have any CamelCase table or column names, you can upgrade without
212 breaking any of your code.
216 For L</monikers>, this option does not inflect the table names but makes
217 monikers based on the actual name. For L</column_accessors> this option does
218 not normalize CamelCase column names to lowercase column accessors, but makes
219 accessors that are the same names as the columns (with any non-\w chars
220 replaced with underscores.)
224 For L</monikers>, singularizes the names using the most current inflector. This
225 is the same as setting the option to L</current>.
229 For L</monikers>, pluralizes the names, using the most current inflector.
233 Dynamic schemas will always default to the 0.04XXX relationship names and won't
234 singularize Results for backward compatibility, to activate the new RelBuilder
235 and singularization put this in your C<Schema.pm> file:
237 __PACKAGE__->naming('current');
239 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
240 next major version upgrade:
242 __PACKAGE__->naming('v7');
246 If true, will not print the usual C<Dumping manual schema ... Schema dump
247 completed.> messages. Does not affect warnings (except for warnings related to
248 L</really_erase_my_files>.)
252 By default POD will be generated for columns and relationships, using database
253 metadata for the text if available and supported.
255 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
256 supported for Postgres right now.
258 Set this to C<0> to turn off all POD generation.
260 =head2 pod_comment_mode
262 Controls where table comments appear in the generated POD. Smaller table
263 comments are appended to the C<NAME> section of the documentation, and larger
264 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
265 section to be generated with the comment always, only use C<NAME>, or choose
266 the length threshold at which the comment is forced into the description.
272 Use C<NAME> section only.
276 Force C<DESCRIPTION> always.
280 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
285 =head2 pod_comment_spillover_length
287 When pod_comment_mode is set to C<auto>, this is the length of the comment at
288 which it will be forced into a separate description section.
292 =head2 relationship_attrs
294 Hashref of attributes to pass to each generated relationship, listed
295 by type. Also supports relationship type 'all', containing options to
296 pass to all generated relationships. Attributes set for more specific
297 relationship types override those set in 'all'.
301 relationship_attrs => {
302 belongs_to => { is_deferrable => 0 },
305 use this to turn off DEFERRABLE on your foreign key constraints.
309 If set to true, each constructive L<DBIx::Class> statement the loader
310 decides to execute will be C<warn>-ed before execution.
314 Set the name of the schema to load (schema in the sense that your database
315 vendor means it). Does not currently support loading more than one schema
320 Only load tables matching regex. Best specified as a qr// regex.
324 Exclude tables matching regex. Best specified as a qr// regex.
328 Overrides the default table name to moniker translation. Can be either
329 a hashref of table keys and moniker values, or a coderef for a translator
330 function taking a single scalar table name argument and returning
331 a scalar moniker. If the hash entry does not exist, or the function
332 returns a false value, the code falls back to default behavior
335 The default behavior is to split on case transition and non-alphanumeric
336 boundaries, singularize the resulting phrase, then join the titlecased words
339 Table Name | Moniker Name
340 ---------------------------------
342 luser_group | LuserGroup
343 luser-opts | LuserOpt
344 stations_visited | StationVisited
345 routeChange | RouteChange
347 =head2 col_accessor_map
349 Same as moniker_map, but for column accessor names. If a coderef is
350 passed, the code is called with arguments of
352 the name of the column in the underlying database,
353 default accessor name that DBICSL would ordinarily give this column,
355 table_class => name of the DBIC class we are building,
356 table_moniker => calculated moniker for this table (after moniker_map if present),
357 table_name => name of the database table,
358 full_table_name => schema-qualified name of the database table (RDBMS specific),
359 schema_class => name of the schema class we are building,
360 column_info => hashref of column info (data_type, is_nullable, etc),
365 Similar in idea to moniker_map, but different in the details. It can be
366 a hashref or a code ref.
368 If it is a hashref, keys can be either the default relationship name, or the
369 moniker. The keys that are the default relationship name should map to the
370 name you want to change the relationship to. Keys that are monikers should map
371 to hashes mapping relationship names to their translation. You can do both at
372 once, and the more specific moniker version will be picked up first. So, for
373 instance, you could have
382 and relationships that would have been named C<bar> will now be named C<baz>
383 except that in the table whose moniker is C<Foo> it will be named C<blat>.
385 If it is a coderef, the argument passed will be a hashref of this form:
388 name => default relationship name,
389 type => the relationship type eg: C<has_many>,
390 local_class => name of the DBIC class we are building,
391 local_moniker => moniker of the DBIC class we are building,
392 local_columns => columns in this table in the relationship,
393 remote_class => name of the DBIC class we are related to,
394 remote_moniker => moniker of the DBIC class we are related to,
395 remote_columns => columns in the other table in the relationship,
398 DBICSL will try to use the value returned as the relationship name.
400 =head2 inflect_plural
402 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
403 if hash key does not exist or coderef returns false), but acts as a map
404 for pluralizing relationship names. The default behavior is to utilize
405 L<Lingua::EN::Inflect::Phrase/to_PL>.
407 =head2 inflect_singular
409 As L</inflect_plural> above, but for singularizing relationship names.
410 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
412 =head2 schema_base_class
414 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
416 =head2 result_base_class
418 Base class for your table classes (aka result classes). Defaults to
421 =head2 additional_base_classes
423 List of additional base classes all of your table classes will use.
425 =head2 left_base_classes
427 List of additional base classes all of your table classes will use
428 that need to be leftmost.
430 =head2 additional_classes
432 List of additional classes which all of your table classes will use.
434 =head2 schema_components
436 List of components to load into the Schema class.
440 List of additional components to be loaded into all of your Result
441 classes. A good example would be
442 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
444 =head2 result_components_map
446 A hashref of moniker keys and component values. Unlike L</components>, which
447 loads the given components into every Result class, this option allows you to
448 load certain components for specified Result classes. For example:
450 result_components_map => {
451 StationVisited => '+YourApp::Schema::Component::StationVisited',
453 '+YourApp::Schema::Component::RouteChange',
454 'InflateColumn::DateTime',
458 You may use this in conjunction with L</components>.
462 List of L<Moose> roles to be applied to all of your Result classes.
464 =head2 result_roles_map
466 A hashref of moniker keys and role values. Unlike L</result_roles>, which
467 applies the given roles to every Result class, this option allows you to apply
468 certain roles for specified Result classes. For example:
470 result_roles_map => {
472 'YourApp::Role::Building',
473 'YourApp::Role::Destination',
475 RouteChange => 'YourApp::Role::TripEvent',
478 You may use this in conjunction with L</result_roles>.
480 =head2 use_namespaces
482 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
485 Generate result class names suitable for
486 L<DBIx::Class::Schema/load_namespaces> and call that instead of
487 L<DBIx::Class::Schema/load_classes>. When using this option you can also
488 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
489 C<resultset_namespace>, C<default_resultset_class>), and they will be added
490 to the call (and the generated result class names adjusted appropriately).
492 =head2 dump_directory
494 The value of this option is a perl libdir pathname. Within
495 that directory this module will create a baseline manual
496 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
498 The created schema class will have the same classname as the one on
499 which you are setting this option (and the ResultSource classes will be
500 based on this name as well).
502 Normally you wouldn't hard-code this setting in your schema class, as it
503 is meant for one-time manual usage.
505 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
506 recommended way to access this functionality.
508 =head2 dump_overwrite
510 Deprecated. See L</really_erase_my_files> below, which does *not* mean
511 the same thing as the old C<dump_overwrite> setting from previous releases.
513 =head2 really_erase_my_files
515 Default false. If true, Loader will unconditionally delete any existing
516 files before creating the new ones from scratch when dumping a schema to disk.
518 The default behavior is instead to only replace the top portion of the
519 file, up to and including the final stanza which contains
520 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
521 leaving any customizations you placed after that as they were.
523 When C<really_erase_my_files> is not set, if the output file already exists,
524 but the aforementioned final stanza is not found, or the checksum
525 contained there does not match the generated contents, Loader will
526 croak and not touch the file.
528 You should really be using version control on your schema classes (and all
529 of the rest of your code for that matter). Don't blame me if a bug in this
530 code wipes something out when it shouldn't have, you've been warned.
532 =head2 overwrite_modifications
534 Default false. If false, when updating existing files, Loader will
535 refuse to modify any Loader-generated code that has been modified
536 since its last run (as determined by the checksum Loader put in its
539 If true, Loader will discard any manual modifications that have been
540 made to Loader-generated code.
542 Again, you should be using version control on your schema classes. Be
543 careful with this option.
545 =head2 custom_column_info
547 Hook for adding extra attributes to the
548 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
550 Must be a coderef that returns a hashref with the extra attributes.
552 Receives the table name, column name and column_info.
556 custom_column_info => sub {
557 my ($table_name, $column_name, $column_info) = @_;
559 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
560 return { is_snoopy => 1 };
564 This attribute can also be used to set C<inflate_datetime> on a non-datetime
565 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
567 =head2 datetime_timezone
569 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
570 columns with the DATE/DATETIME/TIMESTAMP data_types.
572 =head2 datetime_locale
574 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
575 columns with the DATE/DATETIME/TIMESTAMP data_types.
577 =head2 datetime_undef_if_invalid
579 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
580 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
583 The default is recommended to deal with data such as C<00/00/00> which
584 sometimes ends up in such columns in MySQL.
588 File in Perl format, which should return a HASH reference, from which to read
593 Usually column names are lowercased, to make them easier to work with in
594 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
597 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
598 case-sensitive collation will turn this option on unconditionally.
600 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
603 =head2 qualify_objects
605 Set to true to prepend the L</db_schema> to table names for C<<
606 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
610 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
611 L<namespace::autoclean>. The default content after the md5 sum also makes the
614 It is safe to upgrade your existing Schema to this option.
616 =head2 col_collision_map
618 This option controls how accessors for column names which collide with perl
619 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
621 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
622 strings which are compiled to regular expressions that map to
623 L<sprintf|perlfunc/sprintf> formats.
627 col_collision_map => 'column_%s'
629 col_collision_map => { '(.*)' => 'column_%s' }
631 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
633 =head2 rel_collision_map
635 Works just like L</col_collision_map>, but for relationship names/accessors
636 rather than column names/accessors.
638 The default is to just append C<_rel> to the relationship name, see
639 L</RELATIONSHIP NAME COLLISIONS>.
641 =head2 uniq_to_primary
643 Automatically promotes the largest unique constraints with non-nullable columns
644 on tables to primary keys, assuming there is only one largest unique
649 None of these methods are intended for direct invocation by regular
650 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
651 L<DBIx::Class::Schema::Loader>.
655 my $CURRENT_V = 'v7';
658 schema_components schema_base_class result_base_class
659 additional_base_classes left_base_classes additional_classes components
663 # ensure that a peice of object data is a valid arrayref, creating
664 # an empty one or encapsulating whatever's there.
665 sub _ensure_arrayref {
670 $self->{$_} = [ $self->{$_} ]
671 unless ref $self->{$_} eq 'ARRAY';
677 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
678 by L<DBIx::Class::Schema::Loader>.
683 my ( $class, %args ) = @_;
685 if (exists $args{column_accessor_map}) {
686 $args{col_accessor_map} = delete $args{column_accessor_map};
689 my $self = { %args };
691 # don't lose undef options
692 for (values %$self) {
693 $_ = 0 unless defined $_;
696 bless $self => $class;
698 if (my $config_file = $self->config_file) {
699 my $config_opts = do $config_file;
701 croak "Error reading config from $config_file: $@" if $@;
703 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
705 while (my ($k, $v) = each %$config_opts) {
706 $self->{$k} = $v unless exists $self->{$k};
710 if (defined $self->{result_component_map}) {
711 if (defined $self->result_components_map) {
712 croak "Specify only one of result_components_map or result_component_map";
714 $self->result_components_map($self->{result_component_map})
717 if (defined $self->{result_role_map}) {
718 if (defined $self->result_roles_map) {
719 croak "Specify only one of result_roles_map or result_role_map";
721 $self->result_roles_map($self->{result_role_map})
724 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
725 if ((not defined $self->use_moose) || (not $self->use_moose))
726 && ((defined $self->result_roles) || (defined $self->result_roles_map));
728 $self->_ensure_arrayref(qw/schema_components
730 additional_base_classes
736 $self->_validate_class_args;
738 croak "result_components_map must be a hash"
739 if defined $self->result_components_map
740 && ref $self->result_components_map ne 'HASH';
742 if ($self->result_components_map) {
743 my %rc_map = %{ $self->result_components_map };
744 foreach my $moniker (keys %rc_map) {
745 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
747 $self->result_components_map(\%rc_map);
750 $self->result_components_map({});
752 $self->_validate_result_components_map;
754 croak "result_roles_map must be a hash"
755 if defined $self->result_roles_map
756 && ref $self->result_roles_map ne 'HASH';
758 if ($self->result_roles_map) {
759 my %rr_map = %{ $self->result_roles_map };
760 foreach my $moniker (keys %rr_map) {
761 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
763 $self->result_roles_map(\%rr_map);
765 $self->result_roles_map({});
767 $self->_validate_result_roles_map;
769 if ($self->use_moose) {
770 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
771 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
772 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
776 $self->{monikers} = {};
777 $self->{tables} = {};
778 $self->{class_to_table} = {};
779 $self->{classes} = {};
780 $self->{_upgrading_classes} = {};
782 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
783 $self->{schema} ||= $self->{schema_class};
785 croak "dump_overwrite is deprecated. Please read the"
786 . " DBIx::Class::Schema::Loader::Base documentation"
787 if $self->{dump_overwrite};
789 $self->{dynamic} = ! $self->{dump_directory};
790 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
795 $self->{dump_directory} ||= $self->{temp_directory};
797 $self->real_dump_directory($self->{dump_directory});
799 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
800 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
802 if (not defined $self->naming) {
803 $self->naming_set(0);
806 $self->naming_set(1);
809 if ((not ref $self->naming) && defined $self->naming) {
810 my $naming_ver = $self->naming;
812 relationships => $naming_ver,
813 monikers => $naming_ver,
814 column_accessors => $naming_ver,
819 for (values %{ $self->naming }) {
820 $_ = $CURRENT_V if $_ eq 'current';
823 $self->{naming} ||= {};
825 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
826 croak 'custom_column_info must be a CODE ref';
829 $self->_check_back_compat;
831 $self->use_namespaces(1) unless defined $self->use_namespaces;
832 $self->generate_pod(1) unless defined $self->generate_pod;
833 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
834 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
836 if (my $col_collision_map = $self->col_collision_map) {
837 if (my $reftype = ref $col_collision_map) {
838 if ($reftype ne 'HASH') {
839 croak "Invalid type $reftype for option 'col_collision_map'";
843 $self->col_collision_map({ '(.*)' => $col_collision_map });
847 if (my $rel_collision_map = $self->rel_collision_map) {
848 if (my $reftype = ref $rel_collision_map) {
849 if ($reftype ne 'HASH') {
850 croak "Invalid type $reftype for option 'rel_collision_map'";
854 $self->rel_collision_map({ '(.*)' => $rel_collision_map });
858 if (defined(my $rel_name_map = $self->rel_name_map)) {
859 my $reftype = ref $rel_name_map;
860 if ($reftype ne 'HASH' && $reftype ne 'CODE') {
861 croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
868 sub _check_back_compat {
871 # dynamic schemas will always be in 0.04006 mode, unless overridden
872 if ($self->dynamic) {
873 # just in case, though no one is likely to dump a dynamic schema
874 $self->schema_version_to_dump('0.04006');
876 if (not $self->naming_set) {
877 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
879 Dynamic schema detected, will run in 0.04006 mode.
881 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
882 to disable this warning.
884 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
889 $self->_upgrading_from('v4');
892 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
893 $self->use_namespaces(1);
896 $self->naming->{relationships} ||= 'v4';
897 $self->naming->{monikers} ||= 'v4';
899 if ($self->use_namespaces) {
900 $self->_upgrading_from_load_classes(1);
903 $self->use_namespaces(0);
909 # otherwise check if we need backcompat mode for a static schema
910 my $filename = $self->get_dump_filename($self->schema_class);
911 return unless -e $filename;
913 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
914 $self->_parse_generated_file($filename);
916 return unless $old_ver;
918 # determine if the existing schema was dumped with use_moose => 1
919 if (! defined $self->use_moose) {
920 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
923 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
925 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
926 my $ds = eval $result_namespace;
928 Could not eval expression '$result_namespace' for result_namespace from
931 $result_namespace = $ds || '';
933 if ($load_classes && (not defined $self->use_namespaces)) {
934 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
936 'load_classes;' static schema detected, turning off 'use_namespaces'.
938 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
939 variable to disable this warning.
941 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
944 $self->use_namespaces(0);
946 elsif ($load_classes && $self->use_namespaces) {
947 $self->_upgrading_from_load_classes(1);
949 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
950 $self->_downgrading_to_load_classes(
951 $result_namespace || 'Result'
954 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
955 if (not $self->result_namespace) {
956 $self->result_namespace($result_namespace || 'Result');
958 elsif ($result_namespace ne $self->result_namespace) {
959 $self->_rewriting_result_namespace(
960 $result_namespace || 'Result'
965 # XXX when we go past .0 this will need fixing
966 my ($v) = $old_ver =~ /([1-9])/;
969 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
971 if (not %{ $self->naming }) {
972 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
974 Version $old_ver static schema detected, turning on backcompat mode.
976 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
977 to disable this warning.
979 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
981 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
982 from version 0.04006.
985 $self->naming->{relationships} ||= $v;
986 $self->naming->{monikers} ||= $v;
987 $self->naming->{column_accessors} ||= $v;
989 $self->schema_version_to_dump($old_ver);
992 $self->_upgrading_from($v);
996 sub _validate_class_args {
999 foreach my $k (@CLASS_ARGS) {
1000 next unless $self->$k;
1002 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
1003 $self->_validate_classes($k, \@classes);
1007 sub _validate_result_components_map {
1010 foreach my $classes (values %{ $self->result_components_map }) {
1011 $self->_validate_classes('result_components_map', $classes);
1015 sub _validate_result_roles_map {
1018 foreach my $classes (values %{ $self->result_roles_map }) {
1019 $self->_validate_classes('result_roles_map', $classes);
1023 sub _validate_classes {
1026 my $classes = shift;
1028 # make a copy to not destroy original
1029 my @classes = @$classes;
1031 foreach my $c (@classes) {
1032 # components default to being under the DBIx::Class namespace unless they
1033 # are preceeded with a '+'
1034 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1035 $c = 'DBIx::Class::' . $c;
1038 # 1 == installed, 0 == not installed, undef == invalid classname
1039 my $installed = Class::Inspector->installed($c);
1040 if ( defined($installed) ) {
1041 if ( $installed == 0 ) {
1042 croak qq/$c, as specified in the loader option "$key", is not installed/;
1045 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1051 sub _find_file_in_inc {
1052 my ($self, $file) = @_;
1054 foreach my $prefix (@INC) {
1055 my $fullpath = File::Spec->catfile($prefix, $file);
1056 return $fullpath if -f $fullpath
1057 # abs_path throws on Windows for nonexistant files
1058 and (try { Cwd::abs_path($fullpath) }) ne
1059 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1065 sub _find_class_in_inc {
1066 my ($self, $class) = @_;
1068 return $self->_find_file_in_inc(class_path($class));
1074 return $self->_upgrading_from
1075 || $self->_upgrading_from_load_classes
1076 || $self->_downgrading_to_load_classes
1077 || $self->_rewriting_result_namespace
1081 sub _rewrite_old_classnames {
1082 my ($self, $code) = @_;
1084 return $code unless $self->_rewriting;
1086 my %old_classes = reverse %{ $self->_upgrading_classes };
1088 my $re = join '|', keys %old_classes;
1089 $re = qr/\b($re)\b/;
1091 $code =~ s/$re/$old_classes{$1} || $1/eg;
1096 sub _load_external {
1097 my ($self, $class) = @_;
1099 return if $self->{skip_load_external};
1101 # so that we don't load our own classes, under any circumstances
1102 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1104 my $real_inc_path = $self->_find_class_in_inc($class);
1106 my $old_class = $self->_upgrading_classes->{$class}
1107 if $self->_rewriting;
1109 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1110 if $old_class && $old_class ne $class;
1112 return unless $real_inc_path || $old_real_inc_path;
1114 if ($real_inc_path) {
1115 # If we make it to here, we loaded an external definition
1116 warn qq/# Loaded external class definition for '$class'\n/
1119 my $code = $self->_rewrite_old_classnames(scalar read_file($real_inc_path, binmode => ':encoding(UTF-8)'));
1121 if ($self->dynamic) { # load the class too
1122 eval_package_without_redefine_warnings($class, $code);
1125 $self->_ext_stmt($class,
1126 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1127 .qq|# They are now part of the custom portion of this file\n|
1128 .qq|# for you to hand-edit. If you do not either delete\n|
1129 .qq|# this section or remove that file from \@INC, this section\n|
1130 .qq|# will be repeated redundantly when you re-create this\n|
1131 .qq|# file again via Loader! See skip_load_external to disable\n|
1132 .qq|# this feature.\n|
1135 $self->_ext_stmt($class, $code);
1136 $self->_ext_stmt($class,
1137 qq|# End of lines loaded from '$real_inc_path' |
1141 if ($old_real_inc_path) {
1142 my $code = read_file($old_real_inc_path, binmode => ':encoding(UTF-8)');
1144 $self->_ext_stmt($class, <<"EOF");
1146 # These lines were loaded from '$old_real_inc_path',
1147 # based on the Result class name that would have been created by an older
1148 # version of the Loader. For a static schema, this happens only once during
1149 # upgrade. See skip_load_external to disable this feature.
1152 $code = $self->_rewrite_old_classnames($code);
1154 if ($self->dynamic) {
1157 Detected external content in '$old_real_inc_path', a class name that would have
1158 been used by an older version of the Loader.
1160 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1161 new name of the Result.
1163 eval_package_without_redefine_warnings($class, $code);
1167 $self->_ext_stmt($class, $code);
1168 $self->_ext_stmt($class,
1169 qq|# End of lines loaded from '$old_real_inc_path' |
1176 Does the actual schema-construction work.
1183 $self->_load_tables(
1184 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1192 Rescan the database for changes. Returns a list of the newly added table
1195 The schema argument should be the schema class or object to be affected. It
1196 should probably be derived from the original schema_class used during L</load>.
1201 my ($self, $schema) = @_;
1203 $self->{schema} = $schema;
1204 $self->_relbuilder->{schema} = $schema;
1207 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1209 foreach my $table (@current) {
1210 if(!exists $self->{_tables}->{$table}) {
1211 push(@created, $table);
1216 @current{@current} = ();
1217 foreach my $table (keys %{ $self->{_tables} }) {
1218 if (not exists $current{$table}) {
1219 $self->_unregister_source_for_table($table);
1223 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1225 my $loaded = $self->_load_tables(@current);
1227 return map { $self->monikers->{$_} } @created;
1233 return if $self->{skip_relationships};
1235 return $self->{relbuilder} ||= do {
1237 no warnings 'uninitialized';
1238 my $relbuilder_suff =
1244 ->{ $self->naming->{relationships}};
1246 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1247 $self->ensure_class_loaded($relbuilder_class);
1248 $relbuilder_class->new( $self );
1254 my ($self, @tables) = @_;
1256 # Save the new tables to the tables list
1258 $self->{_tables}->{$_} = 1;
1261 $self->_make_src_class($_) for @tables;
1263 # sanity-check for moniker clashes
1264 my $inverse_moniker_idx;
1265 for (keys %{$self->monikers}) {
1266 push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1270 for (keys %$inverse_moniker_idx) {
1271 my $tables = $inverse_moniker_idx->{$_};
1273 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1274 join (', ', map { "'$_'" } @$tables),
1281 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1282 . 'Either change the naming style, or supply an explicit moniker_map: '
1283 . join ('; ', @clashes)
1289 $self->_setup_src_meta($_) for @tables;
1291 if(!$self->skip_relationships) {
1292 # The relationship loader needs a working schema
1293 local $self->{quiet} = 1;
1294 local $self->{dump_directory} = $self->{temp_directory};
1295 $self->_reload_classes(\@tables);
1296 $self->_load_relationships(\@tables);
1298 # Remove that temp dir from INC so it doesn't get reloaded
1299 @INC = grep $_ ne $self->dump_directory, @INC;
1302 $self->_load_roles($_) for @tables;
1304 $self->_load_external($_)
1305 for map { $self->classes->{$_} } @tables;
1307 # Reload without unloading first to preserve any symbols from external
1309 $self->_reload_classes(\@tables, { unload => 0 });
1311 # Drop temporary cache
1312 delete $self->{_cache};
1317 sub _reload_classes {
1318 my ($self, $tables, $opts) = @_;
1320 my @tables = @$tables;
1322 my $unload = $opts->{unload};
1323 $unload = 1 unless defined $unload;
1325 # so that we don't repeat custom sections
1326 @INC = grep $_ ne $self->dump_directory, @INC;
1328 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1330 unshift @INC, $self->dump_directory;
1333 my %have_source = map { $_ => $self->schema->source($_) }
1334 $self->schema->sources;
1336 for my $table (@tables) {
1337 my $moniker = $self->monikers->{$table};
1338 my $class = $self->classes->{$table};
1341 no warnings 'redefine';
1342 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1345 if (my $mc = $self->_moose_metaclass($class)) {
1348 Class::Unload->unload($class) if $unload;
1349 my ($source, $resultset_class);
1351 ($source = $have_source{$moniker})
1352 && ($resultset_class = $source->resultset_class)
1353 && ($resultset_class ne 'DBIx::Class::ResultSet')
1355 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1356 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1359 Class::Unload->unload($resultset_class) if $unload;
1360 $self->_reload_class($resultset_class) if $has_file;
1362 $self->_reload_class($class);
1364 push @to_register, [$moniker, $class];
1367 Class::C3->reinitialize;
1368 for (@to_register) {
1369 $self->schema->register_class(@$_);
1373 sub _moose_metaclass {
1374 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1378 my $mc = try { Class::MOP::class_of($class) }
1381 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1384 # We use this instead of ensure_class_loaded when there are package symbols we
1387 my ($self, $class) = @_;
1389 delete $INC{ +class_path($class) };
1392 eval_package_without_redefine_warnings ($class, "require $class");
1395 my $source = read_file($self->_get_dump_filename($class), binmode => ':encoding(UTF-8)');
1396 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1400 sub _get_dump_filename {
1401 my ($self, $class) = (@_);
1403 $class =~ s{::}{/}g;
1404 return $self->dump_directory . q{/} . $class . q{.pm};
1407 =head2 get_dump_filename
1411 Returns the full path to the file for a class that the class has been or will
1412 be dumped to. This is a file in a temp dir for a dynamic schema.
1416 sub get_dump_filename {
1417 my ($self, $class) = (@_);
1419 local $self->{dump_directory} = $self->real_dump_directory;
1421 return $self->_get_dump_filename($class);
1424 sub _ensure_dump_subdirs {
1425 my ($self, $class) = (@_);
1427 my @name_parts = split(/::/, $class);
1428 pop @name_parts; # we don't care about the very last element,
1429 # which is a filename
1431 my $dir = $self->dump_directory;
1434 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1436 last if !@name_parts;
1437 $dir = File::Spec->catdir($dir, shift @name_parts);
1442 my ($self, @classes) = @_;
1444 my $schema_class = $self->schema_class;
1445 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1447 my $target_dir = $self->dump_directory;
1448 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1449 unless $self->dynamic or $self->quiet;
1452 qq|package $schema_class;\n\n|
1453 . qq|# Created by DBIx::Class::Schema::Loader\n|
1454 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1456 if ($self->use_moose) {
1457 $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1460 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1463 my @schema_components = @{ $self->schema_components || [] };
1465 if (@schema_components) {
1466 my $schema_components = dump @schema_components;
1467 $schema_components = "($schema_components)" if @schema_components == 1;
1469 $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1472 if ($self->use_namespaces) {
1473 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1474 my $namespace_options;
1476 my @attr = qw/resultset_namespace default_resultset_class/;
1478 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1480 for my $attr (@attr) {
1482 my $code = dumper_squashed $self->$attr;
1483 $namespace_options .= qq| $attr => $code,\n|
1486 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1487 $schema_text .= qq|;\n|;
1490 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1494 local $self->{version_to_dump} = $self->schema_version_to_dump;
1495 $self->_write_classfile($schema_class, $schema_text, 1);
1498 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1500 foreach my $src_class (@classes) {
1502 qq|package $src_class;\n\n|
1503 . qq|# Created by DBIx::Class::Schema::Loader\n|
1504 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1506 $src_text .= $self->_make_pod_heading($src_class);
1508 $src_text .= qq|use strict;\nuse warnings;\n\n|;
1510 $src_text .= $self->_base_class_pod($result_base_class)
1511 unless $result_base_class eq 'DBIx::Class::Core';
1513 if ($self->use_moose) {
1514 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1516 # these options 'use base' which is compile time
1517 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1518 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1521 $src_text .= qq|\nextends '$result_base_class';\n|;
1525 $src_text .= qq|use base '$result_base_class';\n|;
1528 $self->_write_classfile($src_class, $src_text);
1531 # remove Result dir if downgrading from use_namespaces, and there are no
1533 if (my $result_ns = $self->_downgrading_to_load_classes
1534 || $self->_rewriting_result_namespace) {
1535 my $result_namespace = $self->_result_namespace(
1540 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1541 $result_dir = $self->dump_directory . '/' . $result_dir;
1543 unless (my @files = glob "$result_dir/*") {
1548 warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
1553 my ($self, $version, $ts) = @_;
1554 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1557 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1560 sub _write_classfile {
1561 my ($self, $class, $text, $is_schema) = @_;
1563 my $filename = $self->_get_dump_filename($class);
1564 $self->_ensure_dump_subdirs($class);
1566 if (-f $filename && $self->really_erase_my_files) {
1567 warn "Deleting existing file '$filename' due to "
1568 . "'really_erase_my_files' setting\n" unless $self->quiet;
1572 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1573 = $self->_parse_generated_file($filename);
1575 if (! $old_gen && -f $filename) {
1576 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1577 . " it does not appear to have been generated by Loader"
1580 my $custom_content = $old_custom || '';
1582 # prepend extra custom content from a *renamed* class (singularization effect)
1583 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1584 my $old_filename = $self->_get_dump_filename($renamed_class);
1586 if (-f $old_filename) {
1587 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1589 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1591 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1594 unlink $old_filename;
1598 $custom_content ||= $self->_default_custom_content($is_schema);
1600 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1601 # If there is already custom content, which does not have the Moose content, add it.
1602 if ($self->use_moose) {
1604 my $non_moose_custom_content = do {
1605 local $self->{use_moose} = 0;
1606 $self->_default_custom_content;
1609 if ($custom_content eq $non_moose_custom_content) {
1610 $custom_content = $self->_default_custom_content($is_schema);
1612 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1613 $custom_content .= $self->_default_custom_content($is_schema);
1616 elsif (defined $self->use_moose && $old_gen) {
1617 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'
1618 if $old_gen =~ /use \s+ MooseX?\b/x;
1621 $custom_content = $self->_rewrite_old_classnames($custom_content);
1624 for @{$self->{_dump_storage}->{$class} || []};
1626 # Check and see if the dump is infact differnt
1630 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1631 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1632 return unless $self->_upgrading_from && $is_schema;
1636 $text .= $self->_sig_comment(
1637 $self->version_to_dump,
1638 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1641 open(my $fh, '>:encoding(UTF-8)', $filename)
1642 or croak "Cannot open '$filename' for writing: $!";
1644 # Write the top half and its MD5 sum
1645 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1647 # Write out anything loaded via external partial class file in @INC
1649 for @{$self->{_ext_storage}->{$class} || []};
1651 # Write out any custom content the user has added
1652 print $fh $custom_content;
1655 or croak "Error closing '$filename': $!";
1658 sub _default_moose_custom_content {
1659 my ($self, $is_schema) = @_;
1661 if (not $is_schema) {
1662 return qq|\n__PACKAGE__->meta->make_immutable;|;
1665 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1668 sub _default_custom_content {
1669 my ($self, $is_schema) = @_;
1670 my $default = qq|\n\n# You can replace this text with custom|
1671 . qq| code or comments, and it will be preserved on regeneration|;
1672 if ($self->use_moose) {
1673 $default .= $self->_default_moose_custom_content($is_schema);
1675 $default .= qq|\n1;\n|;
1679 sub _parse_generated_file {
1680 my ($self, $fn) = @_;
1682 return unless -f $fn;
1684 open(my $fh, '<:encoding(UTF-8)', $fn)
1685 or croak "Cannot open '$fn' for reading: $!";
1688 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1690 my ($md5, $ts, $ver, $gen);
1696 # Pull out the version and timestamp from the line above
1697 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1700 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"
1701 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
1710 my $custom = do { local $/; <$fh> }
1715 return ($gen, $md5, $ver, $ts, $custom);
1723 warn "$target: use $_;" if $self->debug;
1724 $self->_raw_stmt($target, "use $_;");
1732 my $blist = join(q{ }, @_);
1734 return unless $blist;
1736 warn "$target: use base qw/$blist/;" if $self->debug;
1737 $self->_raw_stmt($target, "use base qw/$blist/;");
1744 my $rlist = join(q{, }, map { qq{'$_'} } @_);
1746 return unless $rlist;
1748 warn "$target: with $rlist;" if $self->debug;
1749 $self->_raw_stmt($target, "\nwith $rlist;");
1752 sub _result_namespace {
1753 my ($self, $schema_class, $ns) = @_;
1754 my @result_namespace;
1756 $ns = $ns->[0] if ref $ns;
1758 if ($ns =~ /^\+(.*)/) {
1759 # Fully qualified namespace
1760 @result_namespace = ($1)
1763 # Relative namespace
1764 @result_namespace = ($schema_class, $ns);
1767 return wantarray ? @result_namespace : join '::', @result_namespace;
1770 # Create class with applicable bases, setup monikers, etc
1771 sub _make_src_class {
1772 my ($self, $table) = @_;
1774 my $schema = $self->schema;
1775 my $schema_class = $self->schema_class;
1777 my $table_moniker = $self->_table2moniker($table);
1778 my @result_namespace = ($schema_class);
1779 if ($self->use_namespaces) {
1780 my $result_namespace = $self->result_namespace || 'Result';
1781 @result_namespace = $self->_result_namespace(
1786 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1788 if ((my $upgrading_v = $self->_upgrading_from)
1789 || $self->_rewriting) {
1790 local $self->naming->{monikers} = $upgrading_v
1793 my @result_namespace = @result_namespace;
1794 if ($self->_upgrading_from_load_classes) {
1795 @result_namespace = ($schema_class);
1797 elsif (my $ns = $self->_downgrading_to_load_classes) {
1798 @result_namespace = $self->_result_namespace(
1803 elsif ($ns = $self->_rewriting_result_namespace) {
1804 @result_namespace = $self->_result_namespace(
1810 my $old_class = join(q{::}, @result_namespace,
1811 $self->_table2moniker($table));
1813 $self->_upgrading_classes->{$table_class} = $old_class
1814 unless $table_class eq $old_class;
1817 $self->classes->{$table} = $table_class;
1818 $self->monikers->{$table} = $table_moniker;
1819 $self->tables->{$table_moniker} = $table;
1820 $self->class_to_table->{$table_class} = $table;
1822 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
1824 $self->_use ($table_class, @{$self->additional_classes});
1826 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
1828 $self->_inject($table_class, @{$self->left_base_classes});
1830 my @components = @{ $self->components || [] };
1832 push @components, @{ $self->result_components_map->{$table_moniker} }
1833 if exists $self->result_components_map->{$table_moniker};
1835 my @fq_components = @components;
1836 foreach my $component (@fq_components) {
1837 if ($component !~ s/^\+//) {
1838 $component = "DBIx::Class::$component";
1842 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
1844 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
1846 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
1848 $self->_inject($table_class, @{$self->additional_base_classes});
1851 sub _is_result_class_method {
1852 my ($self, $name, $table_name) = @_;
1854 my $table_moniker = $table_name ? $self->monikers->{$table_name} : '';
1856 $self->_result_class_methods({})
1857 if not defined $self->_result_class_methods;
1859 if (not exists $self->_result_class_methods->{$table_moniker}) {
1860 my (@methods, %methods);
1861 my $base = $self->result_base_class || 'DBIx::Class::Core';
1863 my @components = @{ $self->components || [] };
1865 push @components, @{ $self->result_components_map->{$table_moniker} }
1866 if exists $self->result_components_map->{$table_moniker};
1868 for my $c (@components) {
1869 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
1872 my @roles = @{ $self->result_roles || [] };
1874 push @roles, @{ $self->result_roles_map->{$table_moniker} }
1875 if exists $self->result_roles_map->{$table_moniker};
1877 for my $class ($base, @components,
1878 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
1879 $self->ensure_class_loaded($class);
1881 push @methods, @{ Class::Inspector->methods($class) || [] };
1884 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1886 @methods{@methods} = ();
1888 $self->_result_class_methods->{$table_moniker} = \%methods;
1890 my $result_methods = $self->_result_class_methods->{$table_moniker};
1892 return exists $result_methods->{$name};
1895 sub _resolve_col_accessor_collisions {
1896 my ($self, $table, $col_info) = @_;
1898 my $table_name = ref $table ? $$table : $table;
1900 while (my ($col, $info) = each %$col_info) {
1901 my $accessor = $info->{accessor} || $col;
1903 next if $accessor eq 'id'; # special case (very common column)
1905 if ($self->_is_result_class_method($accessor, $table_name)) {
1908 if (my $map = $self->col_collision_map) {
1909 for my $re (keys %$map) {
1910 if (my @matches = $col =~ /$re/) {
1911 $info->{accessor} = sprintf $map->{$re}, @matches;
1919 Column '$col' in table '$table_name' collides with an inherited method.
1920 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1922 $info->{accessor} = undef;
1928 # use the same logic to run moniker_map, col_accessor_map
1930 my ( $self, $map, $default_code, $ident, @extra ) = @_;
1932 my $default_ident = $default_code->( $ident, @extra );
1934 if( $map && ref $map eq 'HASH' ) {
1935 $new_ident = $map->{ $ident };
1937 elsif( $map && ref $map eq 'CODE' ) {
1938 $new_ident = $map->( $ident, $default_ident, @extra );
1941 $new_ident ||= $default_ident;
1946 sub _default_column_accessor_name {
1947 my ( $self, $column_name ) = @_;
1949 my $accessor_name = $column_name;
1950 $accessor_name =~ s/\W+/_/g;
1952 if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
1953 # older naming just lc'd the col accessor and that's all.
1954 return lc $accessor_name;
1956 elsif (($self->naming->{column_accessors}||'') eq 'preserve') {
1957 return $accessor_name;
1960 return join '_', map lc, split_name $column_name;
1963 sub _make_column_accessor_name {
1964 my ($self, $column_name, $column_context_info ) = @_;
1966 my $accessor = $self->_run_user_map(
1967 $self->col_accessor_map,
1968 sub { $self->_default_column_accessor_name( shift ) },
1970 $column_context_info,
1977 my ($self, $identifier) = @_;
1979 my $qt = $self->schema->storage->sql_maker->quote_char || '';
1982 return $qt->[0] . $identifier . $qt->[1];
1985 return "${qt}${identifier}${qt}";
1988 # Set up metadata (cols, pks, etc)
1989 sub _setup_src_meta {
1990 my ($self, $table) = @_;
1992 my $schema = $self->schema;
1993 my $schema_class = $self->schema_class;
1995 my $table_class = $self->classes->{$table};
1996 my $table_moniker = $self->monikers->{$table};
1998 my $table_name = $table;
2000 my $sql_maker = $self->schema->storage->sql_maker;
2001 my $name_sep = $sql_maker->name_sep;
2003 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
2004 $table_name = \ $self->_quote($table_name);
2007 my $full_table_name = ($self->qualify_objects ?
2008 ($self->_quote($self->db_schema) . '.') : '')
2009 . (ref $table_name ? $$table_name : $table_name);
2011 # be careful to not create refs Data::Dump can "optimize"
2012 $full_table_name = \do {"".$full_table_name} if ref $table_name;
2014 $self->_dbic_stmt($table_class, 'table', $full_table_name);
2016 my $cols = $self->_table_columns($table);
2017 my $col_info = $self->__columns_info_for($table);
2019 ### generate all the column accessor names
2020 while (my ($col, $info) = each %$col_info) {
2021 # hashref of other info that could be used by
2022 # user-defined accessor map functions
2024 table_class => $table_class,
2025 table_moniker => $table_moniker,
2026 table_name => $table_name,
2027 full_table_name => $full_table_name,
2028 schema_class => $schema_class,
2029 column_info => $info,
2032 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2035 $self->_resolve_col_accessor_collisions($table, $col_info);
2037 # prune any redundant accessor names
2038 while (my ($col, $info) = each %$col_info) {
2039 no warnings 'uninitialized';
2040 delete $info->{accessor} if $info->{accessor} eq $col;
2043 my $fks = $self->_table_fk_info($table);
2045 foreach my $fkdef (@$fks) {
2046 for my $col (@{ $fkdef->{local_columns} }) {
2047 $col_info->{$col}{is_foreign_key} = 1;
2051 my $pks = $self->_table_pk_info($table) || [];
2053 my %uniq_tag; # used to eliminate duplicate uniqs
2055 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2057 my $uniqs = $self->_table_uniq_info($table) || [];
2060 foreach my $uniq (@$uniqs) {
2061 my ($name, $cols) = @$uniq;
2062 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2063 push @uniqs, [$name, $cols];
2066 my @non_nullable_uniqs = grep {
2067 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2070 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2071 my @by_colnum = sort { $b->[0] <=> $a->[0] }
2072 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2074 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2075 my @keys = map $_->[1], @by_colnum;
2079 # remove the uniq from list
2080 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2086 foreach my $pkcol (@$pks) {
2087 $col_info->{$pkcol}{is_nullable} = 0;
2093 map { $_, ($col_info->{$_}||{}) } @$cols
2096 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2099 foreach my $uniq (@uniqs) {
2100 my ($name, $cols) = @$uniq;
2101 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2105 sub __columns_info_for {
2106 my ($self, $table) = @_;
2108 my $result = $self->_columns_info_for($table);
2110 while (my ($col, $info) = each %$result) {
2111 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
2112 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2114 $result->{$col} = $info;
2122 Returns a sorted list of loaded tables, using the original database table
2130 return keys %{$self->_tables};
2133 # Make a moniker from a table
2134 sub _default_table2moniker {
2135 no warnings 'uninitialized';
2136 my ($self, $table) = @_;
2138 if ($self->naming->{monikers} eq 'v4') {
2139 return join '', map ucfirst, split /[\W_]+/, lc $table;
2141 elsif ($self->naming->{monikers} eq 'v5') {
2142 return join '', map ucfirst, split /[\W_]+/,
2143 Lingua::EN::Inflect::Number::to_S(lc $table);
2145 elsif ($self->naming->{monikers} eq 'v6') {
2146 (my $as_phrase = lc $table) =~ s/_+/ /g;
2147 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2149 return join '', map ucfirst, split /\W+/, $inflected;
2152 my @words = map lc, split_name $table;
2153 my $as_phrase = join ' ', @words;
2155 my $inflected = $self->naming->{monikers} eq 'plural' ?
2156 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2158 $self->naming->{monikers} eq 'preserve' ?
2161 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2163 return join '', map ucfirst, split /\W+/, $inflected;
2166 sub _table2moniker {
2167 my ( $self, $table ) = @_;
2169 $self->_run_user_map(
2171 sub { $self->_default_table2moniker( shift ) },
2176 sub _load_relationships {
2177 my ($self, $tables) = @_;
2181 foreach my $table (@$tables) {
2182 my $tbl_fk_info = $self->_table_fk_info($table);
2183 foreach my $fkdef (@$tbl_fk_info) {
2184 $fkdef->{remote_source} =
2185 $self->monikers->{delete $fkdef->{remote_table}};
2187 my $tbl_uniq_info = $self->_table_uniq_info($table);
2189 my $local_moniker = $self->monikers->{$table};
2191 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2194 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2196 foreach my $src_class (sort keys %$rel_stmts) {
2198 my @src_stmts = map $_->[1],
2199 sort { $a->[0] cmp $b->[0] }
2200 map [ $_->{args}[0], $_ ], @{ $rel_stmts->{$src_class} };
2202 foreach my $stmt (@src_stmts) {
2203 $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2209 my ($self, $table) = @_;
2211 my $table_moniker = $self->monikers->{$table};
2212 my $table_class = $self->classes->{$table};
2214 my @roles = @{ $self->result_roles || [] };
2215 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2216 if exists $self->result_roles_map->{$table_moniker};
2219 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2221 $self->_with($table_class, @roles);
2225 # Overload these in driver class:
2227 # Returns an arrayref of column names
2228 sub _table_columns { croak "ABSTRACT METHOD" }
2230 # Returns arrayref of pk col names
2231 sub _table_pk_info { croak "ABSTRACT METHOD" }
2233 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2234 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2236 # Returns an arrayref of foreign key constraints, each
2237 # being a hashref with 3 keys:
2238 # local_columns (arrayref), remote_columns (arrayref), remote_table
2239 sub _table_fk_info { croak "ABSTRACT METHOD" }
2241 # Returns an array of lower case table names
2242 sub _tables_list { croak "ABSTRACT METHOD" }
2244 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2250 # generate the pod for this statement, storing it with $self->_pod
2251 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2253 my $args = dump(@_);
2254 $args = '(' . $args . ')' if @_ < 2;
2255 my $stmt = $method . $args . q{;};
2257 warn qq|$class\->$stmt\n| if $self->debug;
2258 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2262 sub _make_pod_heading {
2263 my ($self, $class) = @_;
2265 return '' if not $self->generate_pod;
2267 my $table = $self->class_to_table->{$class};
2270 my $pcm = $self->pod_comment_mode;
2271 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2272 $comment = $self->__table_comment($table);
2273 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2274 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2275 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2277 $pod .= "=head1 NAME\n\n";
2279 my $table_descr = $class;
2280 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2282 $pod .= "$table_descr\n\n";
2284 if ($comment and $comment_in_desc) {
2285 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2292 # generates the accompanying pod for a DBIC class method statement,
2293 # storing it with $self->_pod
2299 if ($method eq 'table') {
2301 $table = $$table if ref $table eq 'SCALAR';
2302 $self->_pod($class, "=head1 TABLE: C<$table>");
2303 $self->_pod_cut($class);
2305 elsif ( $method eq 'add_columns' ) {
2306 $self->_pod( $class, "=head1 ACCESSORS" );
2307 my $col_counter = 0;
2309 while( my ($name,$attrs) = splice @cols,0,2 ) {
2311 $self->_pod( $class, '=head2 ' . $name );
2312 $self->_pod( $class,
2314 my $s = $attrs->{$_};
2315 $s = !defined $s ? 'undef' :
2316 length($s) == 0 ? '(empty string)' :
2317 ref($s) eq 'SCALAR' ? $$s :
2318 ref($s) ? dumper_squashed $s :
2319 looks_like_number($s) ? $s : qq{'$s'};
2322 } sort keys %$attrs,
2324 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2325 $self->_pod( $class, $comment );
2328 $self->_pod_cut( $class );
2329 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2330 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2331 my ( $accessor, $rel_class ) = @_;
2332 $self->_pod( $class, "=head2 $accessor" );
2333 $self->_pod( $class, 'Type: ' . $method );
2334 $self->_pod( $class, "Related object: L<$rel_class>" );
2335 $self->_pod_cut( $class );
2336 $self->{_relations_started} { $class } = 1;
2338 elsif ($method eq 'add_unique_constraint') {
2339 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2340 unless $self->{_uniqs_started}{$class};
2342 my ($name, $cols) = @_;
2344 $self->_pod($class, "=head2 C<$name>");
2345 $self->_pod($class, '=over 4');
2347 foreach my $col (@$cols) {
2348 $self->_pod($class, "=item \* L</$col>");
2351 $self->_pod($class, '=back');
2352 $self->_pod_cut($class);
2354 $self->{_uniqs_started}{$class} = 1;
2356 elsif ($method eq 'set_primary_key') {
2357 $self->_pod($class, "=head1 PRIMARY KEY");
2358 $self->_pod($class, '=over 4');
2360 foreach my $col (@_) {
2361 $self->_pod($class, "=item \* L</$col>");
2364 $self->_pod($class, '=back');
2365 $self->_pod_cut($class);
2369 sub _pod_class_list {
2370 my ($self, $class, $title, @classes) = @_;
2372 return unless @classes && $self->generate_pod;
2374 $self->_pod($class, "=head1 $title");
2375 $self->_pod($class, '=over 4');
2377 foreach my $link (@classes) {
2378 $self->_pod($class, "=item * L<$link>");
2381 $self->_pod($class, '=back');
2382 $self->_pod_cut($class);
2385 sub _base_class_pod {
2386 my ($self, $base_class) = @_;
2388 return unless $self->generate_pod;
2391 =head1 BASE CLASS: L<$base_class>
2398 sub _filter_comment {
2399 my ($self, $txt) = @_;
2401 $txt = '' if not defined $txt;
2403 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2408 sub __table_comment {
2411 if (my $code = $self->can('_table_comment')) {
2412 return $self->_filter_comment($self->$code(@_));
2418 sub __column_comment {
2421 if (my $code = $self->can('_column_comment')) {
2422 return $self->_filter_comment($self->$code(@_));
2428 # Stores a POD documentation
2430 my ($self, $class, $stmt) = @_;
2431 $self->_raw_stmt( $class, "\n" . $stmt );
2435 my ($self, $class ) = @_;
2436 $self->_raw_stmt( $class, "\n=cut\n" );
2439 # Store a raw source line for a class (for dumping purposes)
2441 my ($self, $class, $stmt) = @_;
2442 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2445 # Like above, but separately for the externally loaded stuff
2447 my ($self, $class, $stmt) = @_;
2448 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2451 sub _custom_column_info {
2452 my ( $self, $table_name, $column_name, $column_info ) = @_;
2454 if (my $code = $self->custom_column_info) {
2455 return $code->($table_name, $column_name, $column_info) || {};
2460 sub _datetime_column_info {
2461 my ( $self, $table_name, $column_name, $column_info ) = @_;
2463 my $type = $column_info->{data_type} || '';
2464 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2465 or ($type =~ /date|timestamp/i)) {
2466 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2467 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2473 my ($self, $name) = @_;
2475 return $self->preserve_case ? $name : lc($name);
2479 my ($self, $name) = @_;
2481 return $self->preserve_case ? $name : uc($name);
2484 sub _unregister_source_for_table {
2485 my ($self, $table) = @_;
2489 my $schema = $self->schema;
2490 # in older DBIC it's a private method
2491 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2492 $schema->$unregister($self->_table2moniker($table));
2493 delete $self->monikers->{$table};
2494 delete $self->classes->{$table};
2495 delete $self->_upgrading_classes->{$table};
2496 delete $self->{_tables}{$table};
2500 # remove the dump dir from @INC on destruction
2504 @INC = grep $_ ne $self->dump_directory, @INC;
2509 Returns a hashref of loaded table to moniker mappings. There will
2510 be two entries for each table, the original name and the "normalized"
2511 name, in the case that the two are different (such as databases
2512 that like uppercase table names, or preserve your original mixed-case
2513 definitions, or what-have-you).
2517 Returns a hashref of table to class mappings. In some cases it will
2518 contain multiple entries per table for the original and normalized table
2519 names, as above in L</monikers>.
2521 =head1 COLUMN ACCESSOR COLLISIONS
2523 Occasionally you may have a column name that collides with a perl method, such
2524 as C<can>. In such cases, the default action is to set the C<accessor> of the
2525 column spec to C<undef>.
2527 You can then name the accessor yourself by placing code such as the following
2530 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2532 Another option is to use the L</col_collision_map> option.
2534 =head1 RELATIONSHIP NAME COLLISIONS
2536 In very rare cases, you may get a collision between a generated relationship
2537 name and a method in your Result class, for example if you have a foreign key
2538 called C<belongs_to>.
2540 This is a problem because relationship names are also relationship accessor
2541 methods in L<DBIx::Class>.
2543 The default behavior is to append C<_rel> to the relationship name and print
2544 out a warning that refers to this text.
2546 You can also control the renaming with the L</rel_collision_map> option.
2550 L<DBIx::Class::Schema::Loader>
2554 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2558 This library is free software; you can redistribute it and/or modify it under
2559 the same terms as Perl itself.
2564 # vim:et sts=4 sw=4 tw=0: