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
53 default_resultset_class
58 overwrite_modifications
80 __PACKAGE__->mk_group_accessors('simple', qw/
82 schema_version_to_dump
84 _upgrading_from_load_classes
85 _downgrading_to_load_classes
86 _rewriting_result_namespace
91 pod_comment_spillover_length
99 datetime_undef_if_invalid
100 _result_class_methods
106 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
110 See L<DBIx::Class::Schema::Loader>
114 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
115 classes, and implements the common functionality between them.
117 =head1 CONSTRUCTOR OPTIONS
119 These constructor options are the base options for
120 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
122 =head2 skip_relationships
124 Skip setting up relationships. The default is to attempt the loading
127 =head2 skip_load_external
129 Skip loading of other classes in @INC. The default is to merge all other classes
130 with the same name found in @INC into the schema file we are creating.
134 Static schemas (ones dumped to disk) will, by default, use the new-style
135 relationship names and singularized Results, unless you're overwriting an
136 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
137 which case the backward compatible RelBuilder will be activated, and the
138 appropriate monikerization used.
144 will disable the backward-compatible RelBuilder and use
145 the new-style relationship names along with singularized Results, even when
146 overwriting a dump made with an earlier version.
148 The option also takes a hashref:
150 naming => { relationships => 'v7', monikers => 'v7' }
158 How to name relationship accessors.
162 How to name Result classes.
164 =item column_accessors
166 How to name column accessors in Result classes.
176 Latest style, whatever that happens to be.
180 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
184 Monikers singularized as whole words, C<might_have> relationships for FKs on
185 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
187 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
192 All monikers and relationships are inflected using
193 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
194 from relationship names.
196 In general, there is very little difference between v5 and v6 schemas.
200 This mode is identical to C<v6> mode, except that monikerization of CamelCase
201 table names is also done correctly.
203 CamelCase column names in case-preserving mode will also be handled correctly
204 for relationship name inflection. See L</preserve_case>.
206 In this mode, CamelCase L</column_accessors> are normalized based on case
207 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
209 If you don't have any CamelCase table or column names, you can upgrade without
210 breaking any of your code.
214 For L</monikers>, this option does not inflect the table names but makes
215 monikers based on the actual name. For L</column_accessors> this option does
216 not normalize CamelCase column names to lowercase column accessors, but makes
217 accessors that are the same names as the columns (with any non-\w chars
218 replaced with underscores.)
222 For L</monikers>, singularizes the names using the most current inflector. This
223 is the same as setting the option to L</current>.
227 For L</monikers>, pluralizes the names, using the most current inflector.
231 Dynamic schemas will always default to the 0.04XXX relationship names and won't
232 singularize Results for backward compatibility, to activate the new RelBuilder
233 and singularization put this in your C<Schema.pm> file:
235 __PACKAGE__->naming('current');
237 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
238 next major version upgrade:
240 __PACKAGE__->naming('v7');
244 By default POD will be generated for columns and relationships, using database
245 metadata for the text if available and supported.
247 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
248 supported for Postgres right now.
250 Set this to C<0> to turn off all POD generation.
252 =head2 pod_comment_mode
254 Controls where table comments appear in the generated POD. Smaller table
255 comments are appended to the C<NAME> section of the documentation, and larger
256 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
257 section to be generated with the comment always, only use C<NAME>, or choose
258 the length threshold at which the comment is forced into the description.
264 Use C<NAME> section only.
268 Force C<DESCRIPTION> always.
272 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
277 =head2 pod_comment_spillover_length
279 When pod_comment_mode is set to C<auto>, this is the length of the comment at
280 which it will be forced into a separate description section.
284 =head2 relationship_attrs
286 Hashref of attributes to pass to each generated relationship, listed
287 by type. Also supports relationship type 'all', containing options to
288 pass to all generated relationships. Attributes set for more specific
289 relationship types override those set in 'all'.
293 relationship_attrs => {
294 belongs_to => { is_deferrable => 0 },
297 use this to turn off DEFERRABLE on your foreign key constraints.
301 If set to true, each constructive L<DBIx::Class> statement the loader
302 decides to execute will be C<warn>-ed before execution.
306 Set the name of the schema to load (schema in the sense that your database
309 Can be set to an arrayref of schema names for multiple schemas, or the special
310 value C<%> for all schemas.
312 Multiple schemas have only been tested on PostgreSQL.
316 Only load tables matching regex. Best specified as a qr// regex.
320 Exclude tables matching regex. Best specified as a qr// regex.
324 Overrides the default table name to moniker translation. Can be either
325 a hashref of table keys and moniker values, or a coderef for a translator
326 function taking a single scalar table name argument and returning
327 a scalar moniker. If the hash entry does not exist, or the function
328 returns a false value, the code falls back to default behavior
331 The default behavior is to split on case transition and non-alphanumeric
332 boundaries, singularize the resulting phrase, then join the titlecased words
335 Table Name | Moniker Name
336 ---------------------------------
338 luser_group | LuserGroup
339 luser-opts | LuserOpt
340 stations_visited | StationVisited
341 routeChange | RouteChange
343 =head2 col_accessor_map
345 Same as moniker_map, but for column accessor names. If a coderef is
346 passed, the code is called with arguments of
348 the name of the column in the underlying database,
349 default accessor name that DBICSL would ordinarily give this column,
351 table_class => name of the DBIC class we are building,
352 table_moniker => calculated moniker for this table (after moniker_map if present),
353 table_name => name of the database table,
354 full_table_name => schema-qualified name of the database table (RDBMS specific),
355 schema_class => name of the schema class we are building,
356 column_info => hashref of column info (data_type, is_nullable, etc),
361 Similar in idea to moniker_map, but different in the details. It can be
362 a hashref or a code ref.
364 If it is a hashref, keys can be either the default relationship name, or the
365 moniker. The keys that are the default relationship name should map to the
366 name you want to change the relationship to. Keys that are monikers should map
367 to hashes mapping relationship names to their translation. You can do both at
368 once, and the more specific moniker version will be picked up first. So, for
369 instance, you could have
378 and relationships that would have been named C<bar> will now be named C<baz>
379 except that in the table whose moniker is C<Foo> it will be named C<blat>.
381 If it is a coderef, the argument passed will be a hashref of this form:
384 name => default relationship name,
385 type => the relationship type eg: C<has_many>,
386 local_class => name of the DBIC class we are building,
387 local_moniker => moniker of the DBIC class we are building,
388 local_columns => columns in this table in the relationship,
389 remote_class => name of the DBIC class we are related to,
390 remote_moniker => moniker of the DBIC class we are related to,
391 remote_columns => columns in the other table in the relationship,
394 DBICSL will try to use the value returned as the relationship name.
396 =head2 inflect_plural
398 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
399 if hash key does not exist or coderef returns false), but acts as a map
400 for pluralizing relationship names. The default behavior is to utilize
401 L<Lingua::EN::Inflect::Phrase/to_PL>.
403 =head2 inflect_singular
405 As L</inflect_plural> above, but for singularizing relationship names.
406 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
408 =head2 schema_base_class
410 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
412 =head2 result_base_class
414 Base class for your table classes (aka result classes). Defaults to
417 =head2 additional_base_classes
419 List of additional base classes all of your table classes will use.
421 =head2 left_base_classes
423 List of additional base classes all of your table classes will use
424 that need to be leftmost.
426 =head2 additional_classes
428 List of additional classes which all of your table classes will use.
432 List of additional components to be loaded into all of your table
433 classes. A good example would be
434 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
436 =head2 result_components_map
438 A hashref of moniker keys and component values. Unlike L</components>, which
439 loads the given components into every Result class, this option allows you to
440 load certain components for specified Result classes. For example:
442 result_components_map => {
443 StationVisited => '+YourApp::Schema::Component::StationVisited',
445 '+YourApp::Schema::Component::RouteChange',
446 'InflateColumn::DateTime',
450 You may use this in conjunction with L</components>.
454 List of L<Moose> roles to be applied to all of your Result classes.
456 =head2 result_roles_map
458 A hashref of moniker keys and role values. Unlike L</result_roles>, which
459 applies the given roles to every Result class, this option allows you to apply
460 certain roles for specified Result classes. For example:
462 result_roles_map => {
464 'YourApp::Role::Building',
465 'YourApp::Role::Destination',
467 RouteChange => 'YourApp::Role::TripEvent',
470 You may use this in conjunction with L</result_roles>.
472 =head2 use_namespaces
474 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
477 Generate result class names suitable for
478 L<DBIx::Class::Schema/load_namespaces> and call that instead of
479 L<DBIx::Class::Schema/load_classes>. When using this option you can also
480 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
481 C<resultset_namespace>, C<default_resultset_class>), and they will be added
482 to the call (and the generated result class names adjusted appropriately).
484 =head2 dump_directory
486 The value of this option is a perl libdir pathname. Within
487 that directory this module will create a baseline manual
488 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
490 The created schema class will have the same classname as the one on
491 which you are setting this option (and the ResultSource classes will be
492 based on this name as well).
494 Normally you wouldn't hard-code this setting in your schema class, as it
495 is meant for one-time manual usage.
497 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
498 recommended way to access this functionality.
500 =head2 dump_overwrite
502 Deprecated. See L</really_erase_my_files> below, which does *not* mean
503 the same thing as the old C<dump_overwrite> setting from previous releases.
505 =head2 really_erase_my_files
507 Default false. If true, Loader will unconditionally delete any existing
508 files before creating the new ones from scratch when dumping a schema to disk.
510 The default behavior is instead to only replace the top portion of the
511 file, up to and including the final stanza which contains
512 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
513 leaving any customizations you placed after that as they were.
515 When C<really_erase_my_files> is not set, if the output file already exists,
516 but the aforementioned final stanza is not found, or the checksum
517 contained there does not match the generated contents, Loader will
518 croak and not touch the file.
520 You should really be using version control on your schema classes (and all
521 of the rest of your code for that matter). Don't blame me if a bug in this
522 code wipes something out when it shouldn't have, you've been warned.
524 =head2 overwrite_modifications
526 Default false. If false, when updating existing files, Loader will
527 refuse to modify any Loader-generated code that has been modified
528 since its last run (as determined by the checksum Loader put in its
531 If true, Loader will discard any manual modifications that have been
532 made to Loader-generated code.
534 Again, you should be using version control on your schema classes. Be
535 careful with this option.
537 =head2 custom_column_info
539 Hook for adding extra attributes to the
540 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
542 Must be a coderef that returns a hashref with the extra attributes.
544 Receives the table name, column name and column_info.
548 custom_column_info => sub {
549 my ($table_name, $column_name, $column_info) = @_;
551 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
552 return { is_snoopy => 1 };
556 This attribute can also be used to set C<inflate_datetime> on a non-datetime
557 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
559 =head2 datetime_timezone
561 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
562 columns with the DATE/DATETIME/TIMESTAMP data_types.
564 =head2 datetime_locale
566 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
567 columns with the DATE/DATETIME/TIMESTAMP data_types.
569 =head2 datetime_undef_if_invalid
571 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
572 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
575 The default is recommended to deal with data such as C<00/00/00> which
576 sometimes ends up in such columns in MySQL.
580 File in Perl format, which should return a HASH reference, from which to read
585 Usually column names are lowercased, to make them easier to work with in
586 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
589 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
590 case-sensitive collation will turn this option on unconditionally.
592 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
595 =head2 qualify_objects
597 Set to true to prepend the L</db_schema> to table names for C<<
598 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
602 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
603 L<namespace::autoclean>. The default content after the md5 sum also makes the
606 It is safe to upgrade your existing Schema to this option.
608 =head2 col_collision_map
610 This option controls how accessors for column names which collide with perl
611 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
613 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
614 strings which are compiled to regular expressions that map to
615 L<sprintf|perlfunc/sprintf> formats.
619 col_collision_map => 'column_%s'
621 col_collision_map => { '(.*)' => 'column_%s' }
623 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
625 =head2 rel_collision_map
627 Works just like L</col_collision_map>, but for relationship names/accessors
628 rather than column names/accessors.
630 The default is to just append C<_rel> to the relationship name, see
631 L</RELATIONSHIP NAME COLLISIONS>.
633 =head2 uniq_to_primary
635 Automatically promotes the largest unique constraints with non-nullable columns
636 on tables to primary keys, assuming there is only one largest unique
641 None of these methods are intended for direct invocation by regular
642 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
643 L<DBIx::Class::Schema::Loader>.
647 my $CURRENT_V = 'v7';
650 schema_base_class result_base_class additional_base_classes
651 left_base_classes additional_classes components result_roles
654 # ensure that a peice of object data is a valid arrayref, creating
655 # an empty one or encapsulating whatever's there.
656 sub _ensure_arrayref {
661 $self->{$_} = [ $self->{$_} ]
662 unless ref $self->{$_} eq 'ARRAY';
668 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
669 by L<DBIx::Class::Schema::Loader>.
674 my ( $class, %args ) = @_;
676 if (exists $args{column_accessor_map}) {
677 $args{col_accessor_map} = delete $args{column_accessor_map};
680 my $self = { %args };
682 # don't lose undef options
683 for (values %$self) {
684 $_ = 0 unless defined $_;
687 bless $self => $class;
689 if (my $config_file = $self->config_file) {
690 my $config_opts = do $config_file;
692 croak "Error reading config from $config_file: $@" if $@;
694 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
696 while (my ($k, $v) = each %$config_opts) {
697 $self->{$k} = $v unless exists $self->{$k};
701 if (defined $self->{result_component_map}) {
702 if (defined $self->result_components_map) {
703 croak "Specify only one of result_components_map or result_component_map";
705 $self->result_components_map($self->{result_component_map})
708 if (defined $self->{result_role_map}) {
709 if (defined $self->result_roles_map) {
710 croak "Specify only one of result_roles_map or result_role_map";
712 $self->result_roles_map($self->{result_role_map})
715 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
716 if ((not defined $self->use_moose) || (not $self->use_moose))
717 && ((defined $self->result_roles) || (defined $self->result_roles_map));
719 $self->_ensure_arrayref(qw/additional_classes
720 additional_base_classes
726 $self->_validate_class_args;
728 croak "result_components_map must be a hash"
729 if defined $self->result_components_map
730 && ref $self->result_components_map ne 'HASH';
732 if ($self->result_components_map) {
733 my %rc_map = %{ $self->result_components_map };
734 foreach my $moniker (keys %rc_map) {
735 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
737 $self->result_components_map(\%rc_map);
740 $self->result_components_map({});
742 $self->_validate_result_components_map;
744 croak "result_roles_map must be a hash"
745 if defined $self->result_roles_map
746 && ref $self->result_roles_map ne 'HASH';
748 if ($self->result_roles_map) {
749 my %rr_map = %{ $self->result_roles_map };
750 foreach my $moniker (keys %rr_map) {
751 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
753 $self->result_roles_map(\%rr_map);
755 $self->result_roles_map({});
757 $self->_validate_result_roles_map;
759 if ($self->use_moose) {
760 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
761 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
762 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
766 $self->{monikers} = {};
767 $self->{tables} = {};
768 $self->{class_to_table} = {};
769 $self->{classes} = {};
770 $self->{_upgrading_classes} = {};
772 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
773 $self->{schema} ||= $self->{schema_class};
775 croak "dump_overwrite is deprecated. Please read the"
776 . " DBIx::Class::Schema::Loader::Base documentation"
777 if $self->{dump_overwrite};
779 $self->{dynamic} = ! $self->{dump_directory};
780 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
785 $self->{dump_directory} ||= $self->{temp_directory};
787 $self->real_dump_directory($self->{dump_directory});
789 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
790 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
792 if (not defined $self->naming) {
793 $self->naming_set(0);
796 $self->naming_set(1);
799 if ((not ref $self->naming) && defined $self->naming) {
800 my $naming_ver = $self->naming;
802 relationships => $naming_ver,
803 monikers => $naming_ver,
804 column_accessors => $naming_ver,
809 for (values %{ $self->naming }) {
810 $_ = $CURRENT_V if $_ eq 'current';
813 $self->{naming} ||= {};
815 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
816 croak 'custom_column_info must be a CODE ref';
819 $self->_check_back_compat;
821 $self->use_namespaces(1) unless defined $self->use_namespaces;
822 $self->generate_pod(1) unless defined $self->generate_pod;
823 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
824 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
826 if (my $col_collision_map = $self->col_collision_map) {
827 if (my $reftype = ref $col_collision_map) {
828 if ($reftype ne 'HASH') {
829 croak "Invalid type $reftype for option 'col_collision_map'";
833 $self->col_collision_map({ '(.*)' => $col_collision_map });
837 if (my $rel_collision_map = $self->rel_collision_map) {
838 if (my $reftype = ref $rel_collision_map) {
839 if ($reftype ne 'HASH') {
840 croak "Invalid type $reftype for option 'rel_collision_map'";
844 $self->rel_collision_map({ '(.*)' => $rel_collision_map });
848 if (defined(my $rel_name_map = $self->rel_name_map)) {
849 my $reftype = ref $rel_name_map;
850 if ($reftype ne 'HASH' && $reftype ne 'CODE') {
851 croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
855 if (defined $self->db_schema) {
856 if (ref $self->db_schema eq 'ARRAY') {
857 if (@{ $self->db_schema } > 1) {
858 $self->{qualify_objects} = 1;
860 elsif (@{ $self->db_schema } == 0) {
861 $self->{db_schema} = undef;
864 elsif (not ref $self->db_schema) {
865 if ($self->db_schema eq '%') {
866 $self->{qualify_objects} = 1;
869 $self->{db_schema} = [ $self->db_schema ];
872 croak 'db_schema must be an array or single value';
879 sub _check_back_compat {
882 # dynamic schemas will always be in 0.04006 mode, unless overridden
883 if ($self->dynamic) {
884 # just in case, though no one is likely to dump a dynamic schema
885 $self->schema_version_to_dump('0.04006');
887 if (not $self->naming_set) {
888 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
890 Dynamic schema detected, will run in 0.04006 mode.
892 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
893 to disable this warning.
895 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
900 $self->_upgrading_from('v4');
903 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
904 $self->use_namespaces(1);
907 $self->naming->{relationships} ||= 'v4';
908 $self->naming->{monikers} ||= 'v4';
910 if ($self->use_namespaces) {
911 $self->_upgrading_from_load_classes(1);
914 $self->use_namespaces(0);
920 # otherwise check if we need backcompat mode for a static schema
921 my $filename = $self->get_dump_filename($self->schema_class);
922 return unless -e $filename;
924 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
925 $self->_parse_generated_file($filename);
927 return unless $old_ver;
929 # determine if the existing schema was dumped with use_moose => 1
930 if (! defined $self->use_moose) {
931 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
934 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
936 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
937 my $ds = eval $result_namespace;
939 Could not eval expression '$result_namespace' for result_namespace from
942 $result_namespace = $ds || '';
944 if ($load_classes && (not defined $self->use_namespaces)) {
945 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
947 'load_classes;' static schema detected, turning off 'use_namespaces'.
949 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
950 variable to disable this warning.
952 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
955 $self->use_namespaces(0);
957 elsif ($load_classes && $self->use_namespaces) {
958 $self->_upgrading_from_load_classes(1);
960 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
961 $self->_downgrading_to_load_classes(
962 $result_namespace || 'Result'
965 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
966 if (not $self->result_namespace) {
967 $self->result_namespace($result_namespace || 'Result');
969 elsif ($result_namespace ne $self->result_namespace) {
970 $self->_rewriting_result_namespace(
971 $result_namespace || 'Result'
976 # XXX when we go past .0 this will need fixing
977 my ($v) = $old_ver =~ /([1-9])/;
980 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
982 if (not %{ $self->naming }) {
983 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
985 Version $old_ver static schema detected, turning on backcompat mode.
987 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
988 to disable this warning.
990 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
992 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
993 from version 0.04006.
996 $self->naming->{relationships} ||= $v;
997 $self->naming->{monikers} ||= $v;
998 $self->naming->{column_accessors} ||= $v;
1000 $self->schema_version_to_dump($old_ver);
1003 $self->_upgrading_from($v);
1007 sub _validate_class_args {
1010 foreach my $k (@CLASS_ARGS) {
1011 next unless $self->$k;
1013 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
1014 $self->_validate_classes($k, \@classes);
1018 sub _validate_result_components_map {
1021 foreach my $classes (values %{ $self->result_components_map }) {
1022 $self->_validate_classes('result_components_map', $classes);
1026 sub _validate_result_roles_map {
1029 foreach my $classes (values %{ $self->result_roles_map }) {
1030 $self->_validate_classes('result_roles_map', $classes);
1034 sub _validate_classes {
1037 my $classes = shift;
1039 # make a copy to not destroy original
1040 my @classes = @$classes;
1042 foreach my $c (@classes) {
1043 # components default to being under the DBIx::Class namespace unless they
1044 # are preceeded with a '+'
1045 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1046 $c = 'DBIx::Class::' . $c;
1049 # 1 == installed, 0 == not installed, undef == invalid classname
1050 my $installed = Class::Inspector->installed($c);
1051 if ( defined($installed) ) {
1052 if ( $installed == 0 ) {
1053 croak qq/$c, as specified in the loader option "$key", is not installed/;
1056 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1062 sub _find_file_in_inc {
1063 my ($self, $file) = @_;
1065 foreach my $prefix (@INC) {
1066 my $fullpath = File::Spec->catfile($prefix, $file);
1067 return $fullpath if -f $fullpath
1068 # abs_path throws on Windows for nonexistant files
1069 and (try { Cwd::abs_path($fullpath) }) ne
1070 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1076 sub _find_class_in_inc {
1077 my ($self, $class) = @_;
1079 return $self->_find_file_in_inc(class_path($class));
1085 return $self->_upgrading_from
1086 || $self->_upgrading_from_load_classes
1087 || $self->_downgrading_to_load_classes
1088 || $self->_rewriting_result_namespace
1092 sub _rewrite_old_classnames {
1093 my ($self, $code) = @_;
1095 return $code unless $self->_rewriting;
1097 my %old_classes = reverse %{ $self->_upgrading_classes };
1099 my $re = join '|', keys %old_classes;
1100 $re = qr/\b($re)\b/;
1102 $code =~ s/$re/$old_classes{$1} || $1/eg;
1107 sub _load_external {
1108 my ($self, $class) = @_;
1110 return if $self->{skip_load_external};
1112 # so that we don't load our own classes, under any circumstances
1113 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1115 my $real_inc_path = $self->_find_class_in_inc($class);
1117 my $old_class = $self->_upgrading_classes->{$class}
1118 if $self->_rewriting;
1120 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1121 if $old_class && $old_class ne $class;
1123 return unless $real_inc_path || $old_real_inc_path;
1125 if ($real_inc_path) {
1126 # If we make it to here, we loaded an external definition
1127 warn qq/# Loaded external class definition for '$class'\n/
1130 my $code = $self->_rewrite_old_classnames(scalar read_file($real_inc_path, binmode => ':encoding(UTF-8)'));
1132 if ($self->dynamic) { # load the class too
1133 eval_package_without_redefine_warnings($class, $code);
1136 $self->_ext_stmt($class,
1137 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1138 .qq|# They are now part of the custom portion of this file\n|
1139 .qq|# for you to hand-edit. If you do not either delete\n|
1140 .qq|# this section or remove that file from \@INC, this section\n|
1141 .qq|# will be repeated redundantly when you re-create this\n|
1142 .qq|# file again via Loader! See skip_load_external to disable\n|
1143 .qq|# this feature.\n|
1146 $self->_ext_stmt($class, $code);
1147 $self->_ext_stmt($class,
1148 qq|# End of lines loaded from '$real_inc_path' |
1152 if ($old_real_inc_path) {
1153 my $code = read_file($old_real_inc_path, binmode => ':encoding(UTF-8)');
1155 $self->_ext_stmt($class, <<"EOF");
1157 # These lines were loaded from '$old_real_inc_path',
1158 # based on the Result class name that would have been created by an older
1159 # version of the Loader. For a static schema, this happens only once during
1160 # upgrade. See skip_load_external to disable this feature.
1163 $code = $self->_rewrite_old_classnames($code);
1165 if ($self->dynamic) {
1168 Detected external content in '$old_real_inc_path', a class name that would have
1169 been used by an older version of the Loader.
1171 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1172 new name of the Result.
1174 eval_package_without_redefine_warnings($class, $code);
1178 $self->_ext_stmt($class, $code);
1179 $self->_ext_stmt($class,
1180 qq|# End of lines loaded from '$old_real_inc_path' |
1187 Does the actual schema-construction work.
1194 $self->_load_tables(
1195 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1203 Rescan the database for changes. Returns a list of the newly added table
1206 The schema argument should be the schema class or object to be affected. It
1207 should probably be derived from the original schema_class used during L</load>.
1212 my ($self, $schema) = @_;
1214 $self->{schema} = $schema;
1215 $self->_relbuilder->{schema} = $schema;
1218 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1220 foreach my $table (@current) {
1221 if(!exists $self->{_tables}->{$table}) {
1222 push(@created, $table);
1227 @current{@current} = ();
1228 foreach my $table (keys %{ $self->{_tables} }) {
1229 if (not exists $current{$table}) {
1230 $self->_unregister_source_for_table($table);
1234 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1236 my $loaded = $self->_load_tables(@current);
1238 return map { $self->monikers->{$_} } @created;
1244 return if $self->{skip_relationships};
1246 return $self->{relbuilder} ||= do {
1248 no warnings 'uninitialized';
1249 my $relbuilder_suff =
1255 ->{ $self->naming->{relationships}};
1257 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1258 $self->ensure_class_loaded($relbuilder_class);
1259 $relbuilder_class->new( $self );
1265 my ($self, @tables) = @_;
1267 # Save the new tables to the tables list
1269 $self->{_tables}->{$_} = 1;
1272 $self->_make_src_class($_) for @tables;
1274 # sanity-check for moniker clashes
1275 my $inverse_moniker_idx;
1276 for (keys %{$self->monikers}) {
1277 push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1281 for (keys %$inverse_moniker_idx) {
1282 my $tables = $inverse_moniker_idx->{$_};
1284 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1285 join (', ', map { "'$_'" } @$tables),
1292 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1293 . 'Either change the naming style, or supply an explicit moniker_map: '
1294 . join ('; ', @clashes)
1300 $self->_setup_src_meta($_) for @tables;
1302 if(!$self->skip_relationships) {
1303 # The relationship loader needs a working schema
1305 local $self->{dump_directory} = $self->{temp_directory};
1306 $self->_reload_classes(\@tables);
1307 $self->_load_relationships(\@tables);
1310 # Remove that temp dir from INC so it doesn't get reloaded
1311 @INC = grep $_ ne $self->dump_directory, @INC;
1314 $self->_load_roles($_) for @tables;
1316 $self->_load_external($_)
1317 for map { $self->classes->{$_} } @tables;
1319 # Reload without unloading first to preserve any symbols from external
1321 $self->_reload_classes(\@tables, { unload => 0 });
1323 # Drop temporary cache
1324 delete $self->{_cache};
1329 sub _reload_classes {
1330 my ($self, $tables, $opts) = @_;
1332 my @tables = @$tables;
1334 my $unload = $opts->{unload};
1335 $unload = 1 unless defined $unload;
1337 # so that we don't repeat custom sections
1338 @INC = grep $_ ne $self->dump_directory, @INC;
1340 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1342 unshift @INC, $self->dump_directory;
1345 my %have_source = map { $_ => $self->schema->source($_) }
1346 $self->schema->sources;
1348 for my $table (@tables) {
1349 my $moniker = $self->monikers->{$table};
1350 my $class = $self->classes->{$table};
1353 no warnings 'redefine';
1354 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1357 if (my $mc = $self->_moose_metaclass($class)) {
1360 Class::Unload->unload($class) if $unload;
1361 my ($source, $resultset_class);
1363 ($source = $have_source{$moniker})
1364 && ($resultset_class = $source->resultset_class)
1365 && ($resultset_class ne 'DBIx::Class::ResultSet')
1367 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1368 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1371 Class::Unload->unload($resultset_class) if $unload;
1372 $self->_reload_class($resultset_class) if $has_file;
1374 $self->_reload_class($class);
1376 push @to_register, [$moniker, $class];
1379 Class::C3->reinitialize;
1380 for (@to_register) {
1381 $self->schema->register_class(@$_);
1385 sub _moose_metaclass {
1386 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1390 my $mc = try { Class::MOP::class_of($class) }
1393 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1396 # We use this instead of ensure_class_loaded when there are package symbols we
1399 my ($self, $class) = @_;
1401 delete $INC{ +class_path($class) };
1404 eval_package_without_redefine_warnings ($class, "require $class");
1407 my $source = read_file($self->_get_dump_filename($class), binmode => ':encoding(UTF-8)');
1408 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1412 sub _get_dump_filename {
1413 my ($self, $class) = (@_);
1415 $class =~ s{::}{/}g;
1416 return $self->dump_directory . q{/} . $class . q{.pm};
1419 =head2 get_dump_filename
1423 Returns the full path to the file for a class that the class has been or will
1424 be dumped to. This is a file in a temp dir for a dynamic schema.
1428 sub get_dump_filename {
1429 my ($self, $class) = (@_);
1431 local $self->{dump_directory} = $self->real_dump_directory;
1433 return $self->_get_dump_filename($class);
1436 sub _ensure_dump_subdirs {
1437 my ($self, $class) = (@_);
1439 my @name_parts = split(/::/, $class);
1440 pop @name_parts; # we don't care about the very last element,
1441 # which is a filename
1443 my $dir = $self->dump_directory;
1446 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1448 last if !@name_parts;
1449 $dir = File::Spec->catdir($dir, shift @name_parts);
1454 my ($self, @classes) = @_;
1456 my $schema_class = $self->schema_class;
1457 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1459 my $target_dir = $self->dump_directory;
1460 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1461 unless $self->{dynamic} or $self->{quiet};
1464 qq|package $schema_class;\n\n|
1465 . qq|# Created by DBIx::Class::Schema::Loader\n|
1466 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1468 if ($self->use_moose) {
1469 $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1472 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1475 if ($self->use_namespaces) {
1476 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1477 my $namespace_options;
1479 my @attr = qw/resultset_namespace default_resultset_class/;
1481 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1483 for my $attr (@attr) {
1485 my $code = dumper_squashed $self->$attr;
1486 $namespace_options .= qq| $attr => $code,\n|
1489 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1490 $schema_text .= qq|;\n|;
1493 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1497 local $self->{version_to_dump} = $self->schema_version_to_dump;
1498 $self->_write_classfile($schema_class, $schema_text, 1);
1501 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1503 foreach my $src_class (@classes) {
1505 qq|package $src_class;\n\n|
1506 . qq|# Created by DBIx::Class::Schema::Loader\n|
1507 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1509 $src_text .= $self->_make_pod_heading($src_class);
1511 $src_text .= qq|use strict;\nuse warnings;\n\n|;
1513 $src_text .= $self->_base_class_pod($result_base_class)
1514 unless $result_base_class eq 'DBIx::Class::Core';
1516 if ($self->use_moose) {
1517 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1519 # these options 'use base' which is compile time
1520 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1521 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1524 $src_text .= qq|\nextends '$result_base_class';\n|;
1528 $src_text .= qq|use base '$result_base_class';\n|;
1531 $self->_write_classfile($src_class, $src_text);
1534 # remove Result dir if downgrading from use_namespaces, and there are no
1536 if (my $result_ns = $self->_downgrading_to_load_classes
1537 || $self->_rewriting_result_namespace) {
1538 my $result_namespace = $self->_result_namespace(
1543 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1544 $result_dir = $self->dump_directory . '/' . $result_dir;
1546 unless (my @files = glob "$result_dir/*") {
1551 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1556 my ($self, $version, $ts) = @_;
1557 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1560 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1563 sub _write_classfile {
1564 my ($self, $class, $text, $is_schema) = @_;
1566 my $filename = $self->_get_dump_filename($class);
1567 $self->_ensure_dump_subdirs($class);
1569 if (-f $filename && $self->really_erase_my_files) {
1570 warn "Deleting existing file '$filename' due to "
1571 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1575 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1576 = $self->_parse_generated_file($filename);
1578 if (! $old_gen && -f $filename) {
1579 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1580 . " it does not appear to have been generated by Loader"
1583 my $custom_content = $old_custom || '';
1585 # prepend extra custom content from a *renamed* class (singularization effect)
1586 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1587 my $old_filename = $self->_get_dump_filename($renamed_class);
1589 if (-f $old_filename) {
1590 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1592 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1594 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1597 unlink $old_filename;
1601 $custom_content ||= $self->_default_custom_content($is_schema);
1603 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1604 # If there is already custom content, which does not have the Moose content, add it.
1605 if ($self->use_moose) {
1607 my $non_moose_custom_content = do {
1608 local $self->{use_moose} = 0;
1609 $self->_default_custom_content;
1612 if ($custom_content eq $non_moose_custom_content) {
1613 $custom_content = $self->_default_custom_content($is_schema);
1615 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1616 $custom_content .= $self->_default_custom_content($is_schema);
1619 elsif (defined $self->use_moose && $old_gen) {
1620 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'
1621 if $old_gen =~ /use \s+ MooseX?\b/x;
1624 $custom_content = $self->_rewrite_old_classnames($custom_content);
1627 for @{$self->{_dump_storage}->{$class} || []};
1629 # Check and see if the dump is infact differnt
1633 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1634 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1635 return unless $self->_upgrading_from && $is_schema;
1639 $text .= $self->_sig_comment(
1640 $self->version_to_dump,
1641 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1644 open(my $fh, '>:encoding(UTF-8)', $filename)
1645 or croak "Cannot open '$filename' for writing: $!";
1647 # Write the top half and its MD5 sum
1648 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1650 # Write out anything loaded via external partial class file in @INC
1652 for @{$self->{_ext_storage}->{$class} || []};
1654 # Write out any custom content the user has added
1655 print $fh $custom_content;
1658 or croak "Error closing '$filename': $!";
1661 sub _default_moose_custom_content {
1662 my ($self, $is_schema) = @_;
1664 if (not $is_schema) {
1665 return qq|\n__PACKAGE__->meta->make_immutable;|;
1668 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1671 sub _default_custom_content {
1672 my ($self, $is_schema) = @_;
1673 my $default = qq|\n\n# You can replace this text with custom|
1674 . qq| code or comments, and it will be preserved on regeneration|;
1675 if ($self->use_moose) {
1676 $default .= $self->_default_moose_custom_content($is_schema);
1678 $default .= qq|\n1;\n|;
1682 sub _parse_generated_file {
1683 my ($self, $fn) = @_;
1685 return unless -f $fn;
1687 open(my $fh, '<:encoding(UTF-8)', $fn)
1688 or croak "Cannot open '$fn' for reading: $!";
1691 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1693 my ($md5, $ts, $ver, $gen);
1699 # Pull out the version and timestamp from the line above
1700 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1703 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"
1704 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
1713 my $custom = do { local $/; <$fh> }
1718 return ($gen, $md5, $ver, $ts, $custom);
1726 warn "$target: use $_;" if $self->debug;
1727 $self->_raw_stmt($target, "use $_;");
1735 my $blist = join(q{ }, @_);
1737 return unless $blist;
1739 warn "$target: use base qw/$blist/;" if $self->debug;
1740 $self->_raw_stmt($target, "use base qw/$blist/;");
1747 my $rlist = join(q{, }, map { qq{'$_'} } @_);
1749 return unless $rlist;
1751 warn "$target: with $rlist;" if $self->debug;
1752 $self->_raw_stmt($target, "\nwith $rlist;");
1755 sub _result_namespace {
1756 my ($self, $schema_class, $ns) = @_;
1757 my @result_namespace;
1759 $ns = $ns->[0] if ref $ns;
1761 if ($ns =~ /^\+(.*)/) {
1762 # Fully qualified namespace
1763 @result_namespace = ($1)
1766 # Relative namespace
1767 @result_namespace = ($schema_class, $ns);
1770 return wantarray ? @result_namespace : join '::', @result_namespace;
1773 # Create class with applicable bases, setup monikers, etc
1774 sub _make_src_class {
1775 my ($self, $table) = @_;
1777 my $schema = $self->schema;
1778 my $schema_class = $self->schema_class;
1780 my $table_moniker = $self->_table2moniker($table);
1781 my @result_namespace = ($schema_class);
1782 if ($self->use_namespaces) {
1783 my $result_namespace = $self->result_namespace || 'Result';
1784 @result_namespace = $self->_result_namespace(
1789 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1791 if ((my $upgrading_v = $self->_upgrading_from)
1792 || $self->_rewriting) {
1793 local $self->naming->{monikers} = $upgrading_v
1796 my @result_namespace = @result_namespace;
1797 if ($self->_upgrading_from_load_classes) {
1798 @result_namespace = ($schema_class);
1800 elsif (my $ns = $self->_downgrading_to_load_classes) {
1801 @result_namespace = $self->_result_namespace(
1806 elsif ($ns = $self->_rewriting_result_namespace) {
1807 @result_namespace = $self->_result_namespace(
1813 my $old_class = join(q{::}, @result_namespace,
1814 $self->_table2moniker($table));
1816 $self->_upgrading_classes->{$table_class} = $old_class
1817 unless $table_class eq $old_class;
1820 $self->classes->{$table} = $table_class;
1821 $self->monikers->{$table} = $table_moniker;
1822 $self->tables->{$table_moniker} = $table;
1823 $self->class_to_table->{$table_class} = $table;
1825 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
1827 $self->_use ($table_class, @{$self->additional_classes});
1829 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
1831 $self->_inject($table_class, @{$self->left_base_classes});
1833 my @components = @{ $self->components || [] };
1835 push @components, @{ $self->result_components_map->{$table_moniker} }
1836 if exists $self->result_components_map->{$table_moniker};
1838 my @fq_components = @components;
1839 foreach my $component (@fq_components) {
1840 if ($component !~ s/^\+//) {
1841 $component = "DBIx::Class::$component";
1845 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
1847 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
1849 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
1851 $self->_inject($table_class, @{$self->additional_base_classes});
1854 sub _is_result_class_method {
1855 my ($self, $name, $table_name) = @_;
1857 my $table_moniker = $table_name ? $self->monikers->{$table_name} : '';
1859 $self->_result_class_methods({})
1860 if not defined $self->_result_class_methods;
1862 if (not exists $self->_result_class_methods->{$table_moniker}) {
1863 my (@methods, %methods);
1864 my $base = $self->result_base_class || 'DBIx::Class::Core';
1866 my @components = @{ $self->components || [] };
1868 push @components, @{ $self->result_components_map->{$table_moniker} }
1869 if exists $self->result_components_map->{$table_moniker};
1871 for my $c (@components) {
1872 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
1875 my @roles = @{ $self->result_roles || [] };
1877 push @roles, @{ $self->result_roles_map->{$table_moniker} }
1878 if exists $self->result_roles_map->{$table_moniker};
1880 for my $class ($base, @components,
1881 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
1882 $self->ensure_class_loaded($class);
1884 push @methods, @{ Class::Inspector->methods($class) || [] };
1887 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1889 @methods{@methods} = ();
1891 $self->_result_class_methods->{$table_moniker} = \%methods;
1893 my $result_methods = $self->_result_class_methods->{$table_moniker};
1895 return exists $result_methods->{$name};
1898 sub _resolve_col_accessor_collisions {
1899 my ($self, $table, $col_info) = @_;
1901 while (my ($col, $info) = each %$col_info) {
1902 my $accessor = $info->{accessor} || $col;
1904 next if $accessor eq 'id'; # special case (very common column)
1906 if ($self->_is_result_class_method($accessor, $table)) {
1909 if (my $map = $self->col_collision_map) {
1910 for my $re (keys %$map) {
1911 if (my @matches = $col =~ /$re/) {
1912 $info->{accessor} = sprintf $map->{$re}, @matches;
1920 Column '$col' in table '$table' collides with an inherited method.
1921 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1923 $info->{accessor} = undef;
1929 # use the same logic to run moniker_map, col_accessor_map
1931 my ( $self, $map, $default_code, $ident, @extra ) = @_;
1933 my $default_ident = $default_code->( $ident, @extra );
1935 if( $map && ref $map eq 'HASH' ) {
1936 $new_ident = $map->{ $ident };
1938 elsif( $map && ref $map eq 'CODE' ) {
1939 $new_ident = $map->( $ident, $default_ident, @extra );
1942 $new_ident ||= $default_ident;
1947 sub _default_column_accessor_name {
1948 my ( $self, $column_name ) = @_;
1950 my $accessor_name = $column_name;
1951 $accessor_name =~ s/\W+/_/g;
1953 if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
1954 # older naming just lc'd the col accessor and that's all.
1955 return lc $accessor_name;
1957 elsif (($self->naming->{column_accessors}||'') eq 'preserve') {
1958 return $accessor_name;
1961 return join '_', map lc, split_name $column_name;
1964 sub _make_column_accessor_name {
1965 my ($self, $column_name, $column_context_info ) = @_;
1967 my $accessor = $self->_run_user_map(
1968 $self->col_accessor_map,
1969 sub { $self->_default_column_accessor_name( shift ) },
1971 $column_context_info,
1978 my ($self, $identifier) = @_;
1980 my $qt = $self->schema->storage->sql_maker->quote_char || '';
1983 return $qt->[0] . $identifier . $qt->[1];
1986 return "${qt}${identifier}${qt}";
1989 # Set up metadata (cols, pks, etc)
1990 sub _setup_src_meta {
1991 my ($self, $table) = @_;
1993 my $schema = $self->schema;
1994 my $schema_class = $self->schema_class;
1996 my $table_class = $self->classes->{$table};
1997 my $table_moniker = $self->monikers->{$table};
1999 my $table_name = $table;
2001 my $sql_maker = $self->schema->storage->sql_maker;
2002 my $name_sep = $sql_maker->name_sep;
2004 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
2005 $table_name = \ $self->_quote($table_name);
2008 my $full_table_name = ($self->qualify_objects ?
2009 ($self->_quote($table->schema) . '.') : '')
2010 . (ref $table_name eq 'SCALAR' ? $$table_name : $table_name);
2012 # be careful to not create refs Data::Dump can "optimize"
2013 $full_table_name = \do {"".$full_table_name} if ref $table_name;
2015 $self->_dbic_stmt($table_class, 'table', $full_table_name);
2017 my $cols = $self->_table_columns($table);
2018 my $col_info = $self->__columns_info_for($table);
2020 ### generate all the column accessor names
2021 while (my ($col, $info) = each %$col_info) {
2022 # hashref of other info that could be used by
2023 # user-defined accessor map functions
2025 table_class => $table_class,
2026 table_moniker => $table_moniker,
2027 table_name => $table_name,
2028 full_table_name => $full_table_name,
2029 schema_class => $schema_class,
2030 column_info => $info,
2033 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2036 $self->_resolve_col_accessor_collisions($table, $col_info);
2038 # prune any redundant accessor names
2039 while (my ($col, $info) = each %$col_info) {
2040 no warnings 'uninitialized';
2041 delete $info->{accessor} if $info->{accessor} eq $col;
2044 my $fks = $self->_table_fk_info($table);
2046 foreach my $fkdef (@$fks) {
2047 for my $col (@{ $fkdef->{local_columns} }) {
2048 $col_info->{$col}{is_foreign_key} = 1;
2052 my $pks = $self->_table_pk_info($table) || [];
2054 my %uniq_tag; # used to eliminate duplicate uniqs
2056 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2058 my $uniqs = $self->_table_uniq_info($table) || [];
2061 foreach my $uniq (@$uniqs) {
2062 my ($name, $cols) = @$uniq;
2063 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2064 push @uniqs, [$name, $cols];
2067 my @non_nullable_uniqs = grep {
2068 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2071 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2072 my @by_colnum = sort { $b->[0] <=> $a->[0] }
2073 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2075 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2076 my @keys = map $_->[1], @by_colnum;
2080 # remove the uniq from list
2081 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2087 foreach my $pkcol (@$pks) {
2088 $col_info->{$pkcol}{is_nullable} = 0;
2094 map { $_, ($col_info->{$_}||{}) } @$cols
2097 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2100 foreach my $uniq (@uniqs) {
2101 my ($name, $cols) = @$uniq;
2102 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2106 sub __columns_info_for {
2107 my ($self, $table) = @_;
2109 my $result = $self->_columns_info_for($table);
2111 while (my ($col, $info) = each %$result) {
2112 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
2113 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2115 $result->{$col} = $info;
2123 Returns a sorted list of loaded tables, using the original database table
2131 return keys %{$self->_tables};
2134 # Make a moniker from a table
2135 sub _default_table2moniker {
2136 no warnings 'uninitialized';
2137 my ($self, $table) = @_;
2139 if ($self->naming->{monikers} eq 'v4') {
2140 return join '', map ucfirst, split /[\W_]+/, lc $table;
2142 elsif ($self->naming->{monikers} eq 'v5') {
2143 return join '', map ucfirst, split /[\W_]+/,
2144 Lingua::EN::Inflect::Number::to_S(lc $table);
2146 elsif ($self->naming->{monikers} eq 'v6') {
2147 (my $as_phrase = lc $table) =~ s/_+/ /g;
2148 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2150 return join '', map ucfirst, split /\W+/, $inflected;
2153 my @words = map lc, split_name $table;
2154 my $as_phrase = join ' ', @words;
2156 my $inflected = $self->naming->{monikers} eq 'plural' ?
2157 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2159 $self->naming->{monikers} eq 'preserve' ?
2162 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2164 return join '', map ucfirst, split /\W+/, $inflected;
2167 sub _table2moniker {
2168 my ( $self, $table ) = @_;
2170 $self->_run_user_map(
2172 sub { $self->_default_table2moniker( shift ) },
2177 sub _load_relationships {
2178 my ($self, $tables) = @_;
2182 foreach my $table (@$tables) {
2183 my $tbl_fk_info = $self->_table_fk_info($table);
2184 foreach my $fkdef (@$tbl_fk_info) {
2185 $fkdef->{remote_source} =
2186 $self->monikers->{delete $fkdef->{remote_table}};
2188 my $tbl_uniq_info = $self->_table_uniq_info($table);
2190 my $local_moniker = $self->monikers->{$table};
2192 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2195 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2197 foreach my $src_class (sort keys %$rel_stmts) {
2198 my $src_stmts = $rel_stmts->{$src_class};
2199 foreach my $stmt (@$src_stmts) {
2200 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
2206 my ($self, $table) = @_;
2208 my $table_moniker = $self->monikers->{$table};
2209 my $table_class = $self->classes->{$table};
2211 my @roles = @{ $self->result_roles || [] };
2212 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2213 if exists $self->result_roles_map->{$table_moniker};
2216 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2218 $self->_with($table_class, @roles);
2222 # Overload these in driver class:
2224 # Returns an arrayref of column names
2225 sub _table_columns { croak "ABSTRACT METHOD" }
2227 # Returns arrayref of pk col names
2228 sub _table_pk_info { croak "ABSTRACT METHOD" }
2230 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2231 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2233 # Returns an arrayref of foreign key constraints, each
2234 # being a hashref with 3 keys:
2235 # local_columns (arrayref), remote_columns (arrayref), remote_table
2236 sub _table_fk_info { croak "ABSTRACT METHOD" }
2238 # Returns an array of lower case table names
2239 sub _tables_list { croak "ABSTRACT METHOD" }
2241 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2247 # generate the pod for this statement, storing it with $self->_pod
2248 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2250 my $args = dump(@_);
2251 $args = '(' . $args . ')' if @_ < 2;
2252 my $stmt = $method . $args . q{;};
2254 warn qq|$class\->$stmt\n| if $self->debug;
2255 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2259 sub _make_pod_heading {
2260 my ($self, $class) = @_;
2262 return '' if not $self->generate_pod;
2264 my $table = $self->class_to_table->{$class};
2267 my $pcm = $self->pod_comment_mode;
2268 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2269 $comment = $self->__table_comment($table);
2270 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2271 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2272 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2274 $pod .= "=head1 NAME\n\n";
2276 my $table_descr = $class;
2277 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2279 $pod .= "$table_descr\n\n";
2281 if ($comment and $comment_in_desc) {
2282 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2289 # generates the accompanying pod for a DBIC class method statement,
2290 # storing it with $self->_pod
2296 if ($method eq 'table') {
2298 $table = $$table if ref $table eq 'SCALAR';
2299 $self->_pod($class, "=head1 TABLE: C<$table>");
2300 $self->_pod_cut($class);
2302 elsif ( $method eq 'add_columns' ) {
2303 $self->_pod( $class, "=head1 ACCESSORS" );
2304 my $col_counter = 0;
2306 while( my ($name,$attrs) = splice @cols,0,2 ) {
2308 $self->_pod( $class, '=head2 ' . $name );
2309 $self->_pod( $class,
2311 my $s = $attrs->{$_};
2312 $s = !defined $s ? 'undef' :
2313 length($s) == 0 ? '(empty string)' :
2314 ref($s) eq 'SCALAR' ? $$s :
2315 ref($s) ? dumper_squashed $s :
2316 looks_like_number($s) ? $s : qq{'$s'};
2319 } sort keys %$attrs,
2321 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2322 $self->_pod( $class, $comment );
2325 $self->_pod_cut( $class );
2326 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2327 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2328 my ( $accessor, $rel_class ) = @_;
2329 $self->_pod( $class, "=head2 $accessor" );
2330 $self->_pod( $class, 'Type: ' . $method );
2331 $self->_pod( $class, "Related object: L<$rel_class>" );
2332 $self->_pod_cut( $class );
2333 $self->{_relations_started} { $class } = 1;
2335 elsif ($method eq 'add_unique_constraint') {
2336 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2337 unless $self->{_uniqs_started}{$class};
2339 my ($name, $cols) = @_;
2341 $self->_pod($class, "=head2 C<$name>");
2342 $self->_pod($class, '=over 4');
2344 foreach my $col (@$cols) {
2345 $self->_pod($class, "=item \* L</$col>");
2348 $self->_pod($class, '=back');
2349 $self->_pod_cut($class);
2351 $self->{_uniqs_started}{$class} = 1;
2353 elsif ($method eq 'set_primary_key') {
2354 $self->_pod($class, "=head1 PRIMARY KEY");
2355 $self->_pod($class, '=over 4');
2357 foreach my $col (@_) {
2358 $self->_pod($class, "=item \* L</$col>");
2361 $self->_pod($class, '=back');
2362 $self->_pod_cut($class);
2366 sub _pod_class_list {
2367 my ($self, $class, $title, @classes) = @_;
2369 return unless @classes && $self->generate_pod;
2371 $self->_pod($class, "=head1 $title");
2372 $self->_pod($class, '=over 4');
2374 foreach my $link (@classes) {
2375 $self->_pod($class, "=item * L<$link>");
2378 $self->_pod($class, '=back');
2379 $self->_pod_cut($class);
2382 sub _base_class_pod {
2383 my ($self, $base_class) = @_;
2385 return unless $self->generate_pod;
2388 =head1 BASE CLASS: L<$base_class>
2395 sub _filter_comment {
2396 my ($self, $txt) = @_;
2398 $txt = '' if not defined $txt;
2400 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2405 sub __table_comment {
2408 if (my $code = $self->can('_table_comment')) {
2409 return $self->_filter_comment($self->$code(@_));
2415 sub __column_comment {
2418 if (my $code = $self->can('_column_comment')) {
2419 return $self->_filter_comment($self->$code(@_));
2425 # Stores a POD documentation
2427 my ($self, $class, $stmt) = @_;
2428 $self->_raw_stmt( $class, "\n" . $stmt );
2432 my ($self, $class ) = @_;
2433 $self->_raw_stmt( $class, "\n=cut\n" );
2436 # Store a raw source line for a class (for dumping purposes)
2438 my ($self, $class, $stmt) = @_;
2439 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2442 # Like above, but separately for the externally loaded stuff
2444 my ($self, $class, $stmt) = @_;
2445 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2448 sub _custom_column_info {
2449 my ( $self, $table_name, $column_name, $column_info ) = @_;
2451 if (my $code = $self->custom_column_info) {
2452 return $code->($table_name, $column_name, $column_info) || {};
2457 sub _datetime_column_info {
2458 my ( $self, $table_name, $column_name, $column_info ) = @_;
2460 my $type = $column_info->{data_type} || '';
2461 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2462 or ($type =~ /date|timestamp/i)) {
2463 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2464 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2470 my ($self, $name) = @_;
2472 return $self->preserve_case ? $name : lc($name);
2476 my ($self, $name) = @_;
2478 return $self->preserve_case ? $name : uc($name);
2481 sub _unregister_source_for_table {
2482 my ($self, $table) = @_;
2486 my $schema = $self->schema;
2487 # in older DBIC it's a private method
2488 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2489 $schema->$unregister($self->_table2moniker($table));
2490 delete $self->monikers->{$table};
2491 delete $self->classes->{$table};
2492 delete $self->_upgrading_classes->{$table};
2493 delete $self->{_tables}{$table};
2497 # remove the dump dir from @INC on destruction
2501 @INC = grep $_ ne $self->dump_directory, @INC;
2506 Returns a hashref of loaded table to moniker mappings. There will
2507 be two entries for each table, the original name and the "normalized"
2508 name, in the case that the two are different (such as databases
2509 that like uppercase table names, or preserve your original mixed-case
2510 definitions, or what-have-you).
2514 Returns a hashref of table to class mappings. In some cases it will
2515 contain multiple entries per table for the original and normalized table
2516 names, as above in L</monikers>.
2518 =head1 COLUMN ACCESSOR COLLISIONS
2520 Occasionally you may have a column name that collides with a perl method, such
2521 as C<can>. In such cases, the default action is to set the C<accessor> of the
2522 column spec to C<undef>.
2524 You can then name the accessor yourself by placing code such as the following
2527 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2529 Another option is to use the L</col_collision_map> option.
2531 =head1 RELATIONSHIP NAME COLLISIONS
2533 In very rare cases, you may get a collision between a generated relationship
2534 name and a method in your Result class, for example if you have a foreign key
2535 called C<belongs_to>.
2537 This is a problem because relationship names are also relationship accessor
2538 methods in L<DBIx::Class>.
2540 The default behavior is to append C<_rel> to the relationship name and print
2541 out a warning that refers to this text.
2543 You can also control the renaming with the L</rel_collision_map> option.
2547 L<DBIx::Class::Schema::Loader>
2551 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2555 This library is free software; you can redistribute it and/or modify it under
2556 the same terms as Perl itself.
2561 # vim:et sts=4 sw=4 tw=0: