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
307 vendor means it). Does not currently support loading more than one schema
312 Only load tables matching regex. Best specified as a qr// regex.
316 Exclude tables matching regex. Best specified as a qr// regex.
320 Overrides the default table name to moniker translation. Can be either
321 a hashref of table keys and moniker values, or a coderef for a translator
322 function taking a single scalar table name argument and returning
323 a scalar moniker. If the hash entry does not exist, or the function
324 returns a false value, the code falls back to default behavior
327 The default behavior is to split on case transition and non-alphanumeric
328 boundaries, singularize the resulting phrase, then join the titlecased words
331 Table Name | Moniker Name
332 ---------------------------------
334 luser_group | LuserGroup
335 luser-opts | LuserOpt
336 stations_visited | StationVisited
337 routeChange | RouteChange
339 =head2 col_accessor_map
341 Same as moniker_map, but for column accessor names. If a coderef is
342 passed, the code is called with arguments of
344 the name of the column in the underlying database,
345 default accessor name that DBICSL would ordinarily give this column,
347 table_class => name of the DBIC class we are building,
348 table_moniker => calculated moniker for this table (after moniker_map if present),
349 table_name => name of the database table,
350 full_table_name => schema-qualified name of the database table (RDBMS specific),
351 schema_class => name of the schema class we are building,
352 column_info => hashref of column info (data_type, is_nullable, etc),
357 Similar in idea to moniker_map, but different in the details. It can be
358 a hashref or a code ref.
360 If it is a hashref, keys can be either the default relationship name, or the
361 moniker. The keys that are the default relationship name should map to the
362 name you want to change the relationship to. Keys that are monikers should map
363 to hashes mapping relationship names to their translation. You can do both at
364 once, and the more specific moniker version will be picked up first. So, for
365 instance, you could have
374 and relationships that would have been named C<bar> will now be named C<baz>
375 except that in the table whose moniker is C<Foo> it will be named C<blat>.
377 If it is a coderef, the argument passed will be a hashref of this form:
380 name => default relationship name,
381 type => the relationship type eg: C<has_many>,
382 local_class => name of the DBIC class we are building,
383 local_moniker => moniker of the DBIC class we are building,
384 local_columns => columns in this table in the relationship,
385 remote_class => name of the DBIC class we are related to,
386 remote_moniker => moniker of the DBIC class we are related to,
387 remote_columns => columns in the other table in the relationship,
390 DBICSL will try to use the value returned as the relationship name.
392 =head2 inflect_plural
394 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
395 if hash key does not exist or coderef returns false), but acts as a map
396 for pluralizing relationship names. The default behavior is to utilize
397 L<Lingua::EN::Inflect::Phrase/to_PL>.
399 =head2 inflect_singular
401 As L</inflect_plural> above, but for singularizing relationship names.
402 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
404 =head2 schema_base_class
406 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
408 =head2 result_base_class
410 Base class for your table classes (aka result classes). Defaults to
413 =head2 additional_base_classes
415 List of additional base classes all of your table classes will use.
417 =head2 left_base_classes
419 List of additional base classes all of your table classes will use
420 that need to be leftmost.
422 =head2 additional_classes
424 List of additional classes which all of your table classes will use.
428 List of additional components to be loaded into all of your table
429 classes. A good example would be
430 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
432 =head2 result_components_map
434 A hashref of moniker keys and component values. Unlike L</components>, which
435 loads the given components into every Result class, this option allows you to
436 load certain components for specified Result classes. For example:
438 result_components_map => {
439 StationVisited => '+YourApp::Schema::Component::StationVisited',
441 '+YourApp::Schema::Component::RouteChange',
442 'InflateColumn::DateTime',
446 You may use this in conjunction with L</components>.
450 List of L<Moose> roles to be applied to all of your Result classes.
452 =head2 result_roles_map
454 A hashref of moniker keys and role values. Unlike L</result_roles>, which
455 applies the given roles to every Result class, this option allows you to apply
456 certain roles for specified Result classes. For example:
458 result_roles_map => {
460 'YourApp::Role::Building',
461 'YourApp::Role::Destination',
463 RouteChange => 'YourApp::Role::TripEvent',
466 You may use this in conjunction with L</result_roles>.
468 =head2 use_namespaces
470 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
473 Generate result class names suitable for
474 L<DBIx::Class::Schema/load_namespaces> and call that instead of
475 L<DBIx::Class::Schema/load_classes>. When using this option you can also
476 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
477 C<resultset_namespace>, C<default_resultset_class>), and they will be added
478 to the call (and the generated result class names adjusted appropriately).
480 =head2 dump_directory
482 The value of this option is a perl libdir pathname. Within
483 that directory this module will create a baseline manual
484 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
486 The created schema class will have the same classname as the one on
487 which you are setting this option (and the ResultSource classes will be
488 based on this name as well).
490 Normally you wouldn't hard-code this setting in your schema class, as it
491 is meant for one-time manual usage.
493 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
494 recommended way to access this functionality.
496 =head2 dump_overwrite
498 Deprecated. See L</really_erase_my_files> below, which does *not* mean
499 the same thing as the old C<dump_overwrite> setting from previous releases.
501 =head2 really_erase_my_files
503 Default false. If true, Loader will unconditionally delete any existing
504 files before creating the new ones from scratch when dumping a schema to disk.
506 The default behavior is instead to only replace the top portion of the
507 file, up to and including the final stanza which contains
508 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
509 leaving any customizations you placed after that as they were.
511 When C<really_erase_my_files> is not set, if the output file already exists,
512 but the aforementioned final stanza is not found, or the checksum
513 contained there does not match the generated contents, Loader will
514 croak and not touch the file.
516 You should really be using version control on your schema classes (and all
517 of the rest of your code for that matter). Don't blame me if a bug in this
518 code wipes something out when it shouldn't have, you've been warned.
520 =head2 overwrite_modifications
522 Default false. If false, when updating existing files, Loader will
523 refuse to modify any Loader-generated code that has been modified
524 since its last run (as determined by the checksum Loader put in its
527 If true, Loader will discard any manual modifications that have been
528 made to Loader-generated code.
530 Again, you should be using version control on your schema classes. Be
531 careful with this option.
533 =head2 custom_column_info
535 Hook for adding extra attributes to the
536 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
538 Must be a coderef that returns a hashref with the extra attributes.
540 Receives the table name, column name and column_info.
544 custom_column_info => sub {
545 my ($table_name, $column_name, $column_info) = @_;
547 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
548 return { is_snoopy => 1 };
552 This attribute can also be used to set C<inflate_datetime> on a non-datetime
553 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
555 =head2 datetime_timezone
557 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
558 columns with the DATE/DATETIME/TIMESTAMP data_types.
560 =head2 datetime_locale
562 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
563 columns with the DATE/DATETIME/TIMESTAMP data_types.
565 =head2 datetime_undef_if_invalid
567 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
568 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
571 The default is recommended to deal with data such as C<00/00/00> which
572 sometimes ends up in such columns in MySQL.
576 File in Perl format, which should return a HASH reference, from which to read
581 Usually column names are lowercased, to make them easier to work with in
582 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
585 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
586 case-sensitive collation will turn this option on unconditionally.
588 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
591 =head2 qualify_objects
593 Set to true to prepend the L</db_schema> to table names for C<<
594 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
598 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
599 L<namespace::autoclean>. The default content after the md5 sum also makes the
602 It is safe to upgrade your existing Schema to this option.
604 =head2 col_collision_map
606 This option controls how accessors for column names which collide with perl
607 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
609 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
610 strings which are compiled to regular expressions that map to
611 L<sprintf|perlfunc/sprintf> formats.
615 col_collision_map => 'column_%s'
617 col_collision_map => { '(.*)' => 'column_%s' }
619 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
621 =head2 rel_collision_map
623 Works just like L</col_collision_map>, but for relationship names/accessors
624 rather than column names/accessors.
626 The default is to just append C<_rel> to the relationship name, see
627 L</RELATIONSHIP NAME COLLISIONS>.
629 =head2 uniq_to_primary
631 Automatically promotes the largest unique constraints with non-nullable columns
632 on tables to primary keys, assuming there is only one largest unique
637 None of these methods are intended for direct invocation by regular
638 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
639 L<DBIx::Class::Schema::Loader>.
643 my $CURRENT_V = 'v7';
646 schema_base_class result_base_class additional_base_classes
647 left_base_classes additional_classes components result_roles
650 # ensure that a peice of object data is a valid arrayref, creating
651 # an empty one or encapsulating whatever's there.
652 sub _ensure_arrayref {
657 $self->{$_} = [ $self->{$_} ]
658 unless ref $self->{$_} eq 'ARRAY';
664 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
665 by L<DBIx::Class::Schema::Loader>.
670 my ( $class, %args ) = @_;
672 if (exists $args{column_accessor_map}) {
673 $args{col_accessor_map} = delete $args{column_accessor_map};
676 my $self = { %args };
678 # don't lose undef options
679 for (values %$self) {
680 $_ = 0 unless defined $_;
683 bless $self => $class;
685 if (my $config_file = $self->config_file) {
686 my $config_opts = do $config_file;
688 croak "Error reading config from $config_file: $@" if $@;
690 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
692 while (my ($k, $v) = each %$config_opts) {
693 $self->{$k} = $v unless exists $self->{$k};
697 if (defined $self->{result_component_map}) {
698 if (defined $self->result_components_map) {
699 croak "Specify only one of result_components_map or result_component_map";
701 $self->result_components_map($self->{result_component_map})
704 if (defined $self->{result_role_map}) {
705 if (defined $self->result_roles_map) {
706 croak "Specify only one of result_roles_map or result_role_map";
708 $self->result_roles_map($self->{result_role_map})
711 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
712 if ((not defined $self->use_moose) || (not $self->use_moose))
713 && ((defined $self->result_roles) || (defined $self->result_roles_map));
715 $self->_ensure_arrayref(qw/additional_classes
716 additional_base_classes
722 $self->_validate_class_args;
724 croak "result_components_map must be a hash"
725 if defined $self->result_components_map
726 && ref $self->result_components_map ne 'HASH';
728 if ($self->result_components_map) {
729 my %rc_map = %{ $self->result_components_map };
730 foreach my $moniker (keys %rc_map) {
731 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
733 $self->result_components_map(\%rc_map);
736 $self->result_components_map({});
738 $self->_validate_result_components_map;
740 croak "result_roles_map must be a hash"
741 if defined $self->result_roles_map
742 && ref $self->result_roles_map ne 'HASH';
744 if ($self->result_roles_map) {
745 my %rr_map = %{ $self->result_roles_map };
746 foreach my $moniker (keys %rr_map) {
747 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
749 $self->result_roles_map(\%rr_map);
751 $self->result_roles_map({});
753 $self->_validate_result_roles_map;
755 if ($self->use_moose) {
756 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
757 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
758 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
762 $self->{monikers} = {};
763 $self->{tables} = {};
764 $self->{class_to_table} = {};
765 $self->{classes} = {};
766 $self->{_upgrading_classes} = {};
768 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
769 $self->{schema} ||= $self->{schema_class};
771 croak "dump_overwrite is deprecated. Please read the"
772 . " DBIx::Class::Schema::Loader::Base documentation"
773 if $self->{dump_overwrite};
775 $self->{dynamic} = ! $self->{dump_directory};
776 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
781 $self->{dump_directory} ||= $self->{temp_directory};
783 $self->real_dump_directory($self->{dump_directory});
785 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
786 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
788 if (not defined $self->naming) {
789 $self->naming_set(0);
792 $self->naming_set(1);
795 if ((not ref $self->naming) && defined $self->naming) {
796 my $naming_ver = $self->naming;
798 relationships => $naming_ver,
799 monikers => $naming_ver,
800 column_accessors => $naming_ver,
805 for (values %{ $self->naming }) {
806 $_ = $CURRENT_V if $_ eq 'current';
809 $self->{naming} ||= {};
811 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
812 croak 'custom_column_info must be a CODE ref';
815 $self->_check_back_compat;
817 $self->use_namespaces(1) unless defined $self->use_namespaces;
818 $self->generate_pod(1) unless defined $self->generate_pod;
819 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
820 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
822 if (my $col_collision_map = $self->col_collision_map) {
823 if (my $reftype = ref $col_collision_map) {
824 if ($reftype ne 'HASH') {
825 croak "Invalid type $reftype for option 'col_collision_map'";
829 $self->col_collision_map({ '(.*)' => $col_collision_map });
833 if (my $rel_collision_map = $self->rel_collision_map) {
834 if (my $reftype = ref $rel_collision_map) {
835 if ($reftype ne 'HASH') {
836 croak "Invalid type $reftype for option 'rel_collision_map'";
840 $self->rel_collision_map({ '(.*)' => $rel_collision_map });
844 if (defined(my $rel_name_map = $self->rel_name_map)) {
845 my $reftype = ref $rel_name_map;
846 if ($reftype ne 'HASH' && $reftype ne 'CODE') {
847 croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
854 sub _check_back_compat {
857 # dynamic schemas will always be in 0.04006 mode, unless overridden
858 if ($self->dynamic) {
859 # just in case, though no one is likely to dump a dynamic schema
860 $self->schema_version_to_dump('0.04006');
862 if (not $self->naming_set) {
863 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
865 Dynamic schema detected, will run in 0.04006 mode.
867 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
868 to disable this warning.
870 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
875 $self->_upgrading_from('v4');
878 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
879 $self->use_namespaces(1);
882 $self->naming->{relationships} ||= 'v4';
883 $self->naming->{monikers} ||= 'v4';
885 if ($self->use_namespaces) {
886 $self->_upgrading_from_load_classes(1);
889 $self->use_namespaces(0);
895 # otherwise check if we need backcompat mode for a static schema
896 my $filename = $self->get_dump_filename($self->schema_class);
897 return unless -e $filename;
899 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
900 $self->_parse_generated_file($filename);
902 return unless $old_ver;
904 # determine if the existing schema was dumped with use_moose => 1
905 if (! defined $self->use_moose) {
906 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
909 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
911 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
912 my $ds = eval $result_namespace;
914 Could not eval expression '$result_namespace' for result_namespace from
917 $result_namespace = $ds || '';
919 if ($load_classes && (not defined $self->use_namespaces)) {
920 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
922 'load_classes;' static schema detected, turning off 'use_namespaces'.
924 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
925 variable to disable this warning.
927 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
930 $self->use_namespaces(0);
932 elsif ($load_classes && $self->use_namespaces) {
933 $self->_upgrading_from_load_classes(1);
935 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
936 $self->_downgrading_to_load_classes(
937 $result_namespace || 'Result'
940 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
941 if (not $self->result_namespace) {
942 $self->result_namespace($result_namespace || 'Result');
944 elsif ($result_namespace ne $self->result_namespace) {
945 $self->_rewriting_result_namespace(
946 $result_namespace || 'Result'
951 # XXX when we go past .0 this will need fixing
952 my ($v) = $old_ver =~ /([1-9])/;
955 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
957 if (not %{ $self->naming }) {
958 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
960 Version $old_ver static schema detected, turning on backcompat mode.
962 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
963 to disable this warning.
965 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
967 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
968 from version 0.04006.
971 $self->naming->{relationships} ||= $v;
972 $self->naming->{monikers} ||= $v;
973 $self->naming->{column_accessors} ||= $v;
975 $self->schema_version_to_dump($old_ver);
978 $self->_upgrading_from($v);
982 sub _validate_class_args {
985 foreach my $k (@CLASS_ARGS) {
986 next unless $self->$k;
988 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
989 $self->_validate_classes($k, \@classes);
993 sub _validate_result_components_map {
996 foreach my $classes (values %{ $self->result_components_map }) {
997 $self->_validate_classes('result_components_map', $classes);
1001 sub _validate_result_roles_map {
1004 foreach my $classes (values %{ $self->result_roles_map }) {
1005 $self->_validate_classes('result_roles_map', $classes);
1009 sub _validate_classes {
1012 my $classes = shift;
1014 # make a copy to not destroy original
1015 my @classes = @$classes;
1017 foreach my $c (@classes) {
1018 # components default to being under the DBIx::Class namespace unless they
1019 # are preceeded with a '+'
1020 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1021 $c = 'DBIx::Class::' . $c;
1024 # 1 == installed, 0 == not installed, undef == invalid classname
1025 my $installed = Class::Inspector->installed($c);
1026 if ( defined($installed) ) {
1027 if ( $installed == 0 ) {
1028 croak qq/$c, as specified in the loader option "$key", is not installed/;
1031 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1037 sub _find_file_in_inc {
1038 my ($self, $file) = @_;
1040 foreach my $prefix (@INC) {
1041 my $fullpath = File::Spec->catfile($prefix, $file);
1042 return $fullpath if -f $fullpath
1043 # abs_path throws on Windows for nonexistant files
1044 and (try { Cwd::abs_path($fullpath) }) ne
1045 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1051 sub _find_class_in_inc {
1052 my ($self, $class) = @_;
1054 return $self->_find_file_in_inc(class_path($class));
1060 return $self->_upgrading_from
1061 || $self->_upgrading_from_load_classes
1062 || $self->_downgrading_to_load_classes
1063 || $self->_rewriting_result_namespace
1067 sub _rewrite_old_classnames {
1068 my ($self, $code) = @_;
1070 return $code unless $self->_rewriting;
1072 my %old_classes = reverse %{ $self->_upgrading_classes };
1074 my $re = join '|', keys %old_classes;
1075 $re = qr/\b($re)\b/;
1077 $code =~ s/$re/$old_classes{$1} || $1/eg;
1082 sub _load_external {
1083 my ($self, $class) = @_;
1085 return if $self->{skip_load_external};
1087 # so that we don't load our own classes, under any circumstances
1088 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1090 my $real_inc_path = $self->_find_class_in_inc($class);
1092 my $old_class = $self->_upgrading_classes->{$class}
1093 if $self->_rewriting;
1095 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1096 if $old_class && $old_class ne $class;
1098 return unless $real_inc_path || $old_real_inc_path;
1100 if ($real_inc_path) {
1101 # If we make it to here, we loaded an external definition
1102 warn qq/# Loaded external class definition for '$class'\n/
1105 my $code = $self->_rewrite_old_classnames(scalar read_file($real_inc_path, binmode => ':encoding(UTF-8)'));
1107 if ($self->dynamic) { # load the class too
1108 eval_package_without_redefine_warnings($class, $code);
1111 $self->_ext_stmt($class,
1112 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1113 .qq|# They are now part of the custom portion of this file\n|
1114 .qq|# for you to hand-edit. If you do not either delete\n|
1115 .qq|# this section or remove that file from \@INC, this section\n|
1116 .qq|# will be repeated redundantly when you re-create this\n|
1117 .qq|# file again via Loader! See skip_load_external to disable\n|
1118 .qq|# this feature.\n|
1121 $self->_ext_stmt($class, $code);
1122 $self->_ext_stmt($class,
1123 qq|# End of lines loaded from '$real_inc_path' |
1127 if ($old_real_inc_path) {
1128 my $code = read_file($old_real_inc_path, binmode => ':encoding(UTF-8)');
1130 $self->_ext_stmt($class, <<"EOF");
1132 # These lines were loaded from '$old_real_inc_path',
1133 # based on the Result class name that would have been created by an older
1134 # version of the Loader. For a static schema, this happens only once during
1135 # upgrade. See skip_load_external to disable this feature.
1138 $code = $self->_rewrite_old_classnames($code);
1140 if ($self->dynamic) {
1143 Detected external content in '$old_real_inc_path', a class name that would have
1144 been used by an older version of the Loader.
1146 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1147 new name of the Result.
1149 eval_package_without_redefine_warnings($class, $code);
1153 $self->_ext_stmt($class, $code);
1154 $self->_ext_stmt($class,
1155 qq|# End of lines loaded from '$old_real_inc_path' |
1162 Does the actual schema-construction work.
1169 $self->_load_tables(
1170 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1178 Rescan the database for changes. Returns a list of the newly added table
1181 The schema argument should be the schema class or object to be affected. It
1182 should probably be derived from the original schema_class used during L</load>.
1187 my ($self, $schema) = @_;
1189 $self->{schema} = $schema;
1190 $self->_relbuilder->{schema} = $schema;
1193 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1195 foreach my $table (@current) {
1196 if(!exists $self->{_tables}->{$table}) {
1197 push(@created, $table);
1202 @current{@current} = ();
1203 foreach my $table (keys %{ $self->{_tables} }) {
1204 if (not exists $current{$table}) {
1205 $self->_unregister_source_for_table($table);
1209 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1211 my $loaded = $self->_load_tables(@current);
1213 return map { $self->monikers->{$_} } @created;
1219 return if $self->{skip_relationships};
1221 return $self->{relbuilder} ||= do {
1223 no warnings 'uninitialized';
1224 my $relbuilder_suff =
1230 ->{ $self->naming->{relationships}};
1232 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1233 $self->ensure_class_loaded($relbuilder_class);
1234 $relbuilder_class->new( $self );
1240 my ($self, @tables) = @_;
1242 # Save the new tables to the tables list
1244 $self->{_tables}->{$_} = 1;
1247 $self->_make_src_class($_) for @tables;
1249 # sanity-check for moniker clashes
1250 my $inverse_moniker_idx;
1251 for (keys %{$self->monikers}) {
1252 push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1256 for (keys %$inverse_moniker_idx) {
1257 my $tables = $inverse_moniker_idx->{$_};
1259 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1260 join (', ', map { "'$_'" } @$tables),
1267 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1268 . 'Either change the naming style, or supply an explicit moniker_map: '
1269 . join ('; ', @clashes)
1275 $self->_setup_src_meta($_) for @tables;
1277 if(!$self->skip_relationships) {
1278 # The relationship loader needs a working schema
1280 local $self->{dump_directory} = $self->{temp_directory};
1281 $self->_reload_classes(\@tables);
1282 $self->_load_relationships(\@tables);
1285 # Remove that temp dir from INC so it doesn't get reloaded
1286 @INC = grep $_ ne $self->dump_directory, @INC;
1289 $self->_load_roles($_) for @tables;
1291 $self->_load_external($_)
1292 for map { $self->classes->{$_} } @tables;
1294 # Reload without unloading first to preserve any symbols from external
1296 $self->_reload_classes(\@tables, { unload => 0 });
1298 # Drop temporary cache
1299 delete $self->{_cache};
1304 sub _reload_classes {
1305 my ($self, $tables, $opts) = @_;
1307 my @tables = @$tables;
1309 my $unload = $opts->{unload};
1310 $unload = 1 unless defined $unload;
1312 # so that we don't repeat custom sections
1313 @INC = grep $_ ne $self->dump_directory, @INC;
1315 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1317 unshift @INC, $self->dump_directory;
1320 my %have_source = map { $_ => $self->schema->source($_) }
1321 $self->schema->sources;
1323 for my $table (@tables) {
1324 my $moniker = $self->monikers->{$table};
1325 my $class = $self->classes->{$table};
1328 no warnings 'redefine';
1329 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1332 if (my $mc = $self->_moose_metaclass($class)) {
1335 Class::Unload->unload($class) if $unload;
1336 my ($source, $resultset_class);
1338 ($source = $have_source{$moniker})
1339 && ($resultset_class = $source->resultset_class)
1340 && ($resultset_class ne 'DBIx::Class::ResultSet')
1342 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1343 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1346 Class::Unload->unload($resultset_class) if $unload;
1347 $self->_reload_class($resultset_class) if $has_file;
1349 $self->_reload_class($class);
1351 push @to_register, [$moniker, $class];
1354 Class::C3->reinitialize;
1355 for (@to_register) {
1356 $self->schema->register_class(@$_);
1360 sub _moose_metaclass {
1361 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1365 my $mc = try { Class::MOP::class_of($class) }
1368 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1371 # We use this instead of ensure_class_loaded when there are package symbols we
1374 my ($self, $class) = @_;
1376 delete $INC{ +class_path($class) };
1379 eval_package_without_redefine_warnings ($class, "require $class");
1382 my $source = read_file($self->_get_dump_filename($class), binmode => ':encoding(UTF-8)');
1383 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1387 sub _get_dump_filename {
1388 my ($self, $class) = (@_);
1390 $class =~ s{::}{/}g;
1391 return $self->dump_directory . q{/} . $class . q{.pm};
1394 =head2 get_dump_filename
1398 Returns the full path to the file for a class that the class has been or will
1399 be dumped to. This is a file in a temp dir for a dynamic schema.
1403 sub get_dump_filename {
1404 my ($self, $class) = (@_);
1406 local $self->{dump_directory} = $self->real_dump_directory;
1408 return $self->_get_dump_filename($class);
1411 sub _ensure_dump_subdirs {
1412 my ($self, $class) = (@_);
1414 my @name_parts = split(/::/, $class);
1415 pop @name_parts; # we don't care about the very last element,
1416 # which is a filename
1418 my $dir = $self->dump_directory;
1421 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1423 last if !@name_parts;
1424 $dir = File::Spec->catdir($dir, shift @name_parts);
1429 my ($self, @classes) = @_;
1431 my $schema_class = $self->schema_class;
1432 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1434 my $target_dir = $self->dump_directory;
1435 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1436 unless $self->{dynamic} or $self->{quiet};
1439 qq|package $schema_class;\n\n|
1440 . qq|# Created by DBIx::Class::Schema::Loader\n|
1441 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1443 if ($self->use_moose) {
1444 $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1447 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1450 if ($self->use_namespaces) {
1451 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1452 my $namespace_options;
1454 my @attr = qw/resultset_namespace default_resultset_class/;
1456 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1458 for my $attr (@attr) {
1460 my $code = dumper_squashed $self->$attr;
1461 $namespace_options .= qq| $attr => $code,\n|
1464 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1465 $schema_text .= qq|;\n|;
1468 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1472 local $self->{version_to_dump} = $self->schema_version_to_dump;
1473 $self->_write_classfile($schema_class, $schema_text, 1);
1476 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1478 foreach my $src_class (@classes) {
1480 qq|package $src_class;\n\n|
1481 . qq|# Created by DBIx::Class::Schema::Loader\n|
1482 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1484 $src_text .= $self->_make_pod_heading($src_class);
1486 $src_text .= qq|use strict;\nuse warnings;\n\n|;
1488 $src_text .= $self->_base_class_pod($result_base_class)
1489 unless $result_base_class eq 'DBIx::Class::Core';
1491 if ($self->use_moose) {
1492 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1494 # these options 'use base' which is compile time
1495 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1496 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1499 $src_text .= qq|\nextends '$result_base_class';\n|;
1503 $src_text .= qq|use base '$result_base_class';\n|;
1506 $self->_write_classfile($src_class, $src_text);
1509 # remove Result dir if downgrading from use_namespaces, and there are no
1511 if (my $result_ns = $self->_downgrading_to_load_classes
1512 || $self->_rewriting_result_namespace) {
1513 my $result_namespace = $self->_result_namespace(
1518 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1519 $result_dir = $self->dump_directory . '/' . $result_dir;
1521 unless (my @files = glob "$result_dir/*") {
1526 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1531 my ($self, $version, $ts) = @_;
1532 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1535 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1538 sub _write_classfile {
1539 my ($self, $class, $text, $is_schema) = @_;
1541 my $filename = $self->_get_dump_filename($class);
1542 $self->_ensure_dump_subdirs($class);
1544 if (-f $filename && $self->really_erase_my_files) {
1545 warn "Deleting existing file '$filename' due to "
1546 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1550 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1551 = $self->_parse_generated_file($filename);
1553 if (! $old_gen && -f $filename) {
1554 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1555 . " it does not appear to have been generated by Loader"
1558 my $custom_content = $old_custom || '';
1560 # prepend extra custom content from a *renamed* class (singularization effect)
1561 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1562 my $old_filename = $self->_get_dump_filename($renamed_class);
1564 if (-f $old_filename) {
1565 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1567 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1569 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1572 unlink $old_filename;
1576 $custom_content ||= $self->_default_custom_content($is_schema);
1578 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1579 # If there is already custom content, which does not have the Moose content, add it.
1580 if ($self->use_moose) {
1582 my $non_moose_custom_content = do {
1583 local $self->{use_moose} = 0;
1584 $self->_default_custom_content;
1587 if ($custom_content eq $non_moose_custom_content) {
1588 $custom_content = $self->_default_custom_content($is_schema);
1590 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1591 $custom_content .= $self->_default_custom_content($is_schema);
1594 elsif (defined $self->use_moose && $old_gen) {
1595 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'
1596 if $old_gen =~ /use \s+ MooseX?\b/x;
1599 $custom_content = $self->_rewrite_old_classnames($custom_content);
1602 for @{$self->{_dump_storage}->{$class} || []};
1604 # Check and see if the dump is infact differnt
1608 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1609 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1610 return unless $self->_upgrading_from && $is_schema;
1614 $text .= $self->_sig_comment(
1615 $self->version_to_dump,
1616 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1619 open(my $fh, '>:encoding(UTF-8)', $filename)
1620 or croak "Cannot open '$filename' for writing: $!";
1622 # Write the top half and its MD5 sum
1623 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1625 # Write out anything loaded via external partial class file in @INC
1627 for @{$self->{_ext_storage}->{$class} || []};
1629 # Write out any custom content the user has added
1630 print $fh $custom_content;
1633 or croak "Error closing '$filename': $!";
1636 sub _default_moose_custom_content {
1637 my ($self, $is_schema) = @_;
1639 if (not $is_schema) {
1640 return qq|\n__PACKAGE__->meta->make_immutable;|;
1643 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1646 sub _default_custom_content {
1647 my ($self, $is_schema) = @_;
1648 my $default = qq|\n\n# You can replace this text with custom|
1649 . qq| code or comments, and it will be preserved on regeneration|;
1650 if ($self->use_moose) {
1651 $default .= $self->_default_moose_custom_content($is_schema);
1653 $default .= qq|\n1;\n|;
1657 sub _parse_generated_file {
1658 my ($self, $fn) = @_;
1660 return unless -f $fn;
1662 open(my $fh, '<:encoding(UTF-8)', $fn)
1663 or croak "Cannot open '$fn' for reading: $!";
1666 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1668 my ($md5, $ts, $ver, $gen);
1674 # Pull out the version and timestamp from the line above
1675 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1678 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"
1679 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
1688 my $custom = do { local $/; <$fh> }
1693 return ($gen, $md5, $ver, $ts, $custom);
1701 warn "$target: use $_;" if $self->debug;
1702 $self->_raw_stmt($target, "use $_;");
1710 my $blist = join(q{ }, @_);
1712 return unless $blist;
1714 warn "$target: use base qw/$blist/;" if $self->debug;
1715 $self->_raw_stmt($target, "use base qw/$blist/;");
1722 my $rlist = join(q{, }, map { qq{'$_'} } @_);
1724 return unless $rlist;
1726 warn "$target: with $rlist;" if $self->debug;
1727 $self->_raw_stmt($target, "\nwith $rlist;");
1730 sub _result_namespace {
1731 my ($self, $schema_class, $ns) = @_;
1732 my @result_namespace;
1734 $ns = $ns->[0] if ref $ns;
1736 if ($ns =~ /^\+(.*)/) {
1737 # Fully qualified namespace
1738 @result_namespace = ($1)
1741 # Relative namespace
1742 @result_namespace = ($schema_class, $ns);
1745 return wantarray ? @result_namespace : join '::', @result_namespace;
1748 # Create class with applicable bases, setup monikers, etc
1749 sub _make_src_class {
1750 my ($self, $table) = @_;
1752 my $schema = $self->schema;
1753 my $schema_class = $self->schema_class;
1755 my $table_moniker = $self->_table2moniker($table);
1756 my @result_namespace = ($schema_class);
1757 if ($self->use_namespaces) {
1758 my $result_namespace = $self->result_namespace || 'Result';
1759 @result_namespace = $self->_result_namespace(
1764 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1766 if ((my $upgrading_v = $self->_upgrading_from)
1767 || $self->_rewriting) {
1768 local $self->naming->{monikers} = $upgrading_v
1771 my @result_namespace = @result_namespace;
1772 if ($self->_upgrading_from_load_classes) {
1773 @result_namespace = ($schema_class);
1775 elsif (my $ns = $self->_downgrading_to_load_classes) {
1776 @result_namespace = $self->_result_namespace(
1781 elsif ($ns = $self->_rewriting_result_namespace) {
1782 @result_namespace = $self->_result_namespace(
1788 my $old_class = join(q{::}, @result_namespace,
1789 $self->_table2moniker($table));
1791 $self->_upgrading_classes->{$table_class} = $old_class
1792 unless $table_class eq $old_class;
1795 $self->classes->{$table} = $table_class;
1796 $self->monikers->{$table} = $table_moniker;
1797 $self->tables->{$table_moniker} = $table;
1798 $self->class_to_table->{$table_class} = $table;
1800 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
1802 $self->_use ($table_class, @{$self->additional_classes});
1804 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
1806 $self->_inject($table_class, @{$self->left_base_classes});
1808 my @components = @{ $self->components || [] };
1810 push @components, @{ $self->result_components_map->{$table_moniker} }
1811 if exists $self->result_components_map->{$table_moniker};
1813 my @fq_components = @components;
1814 foreach my $component (@fq_components) {
1815 if ($component !~ s/^\+//) {
1816 $component = "DBIx::Class::$component";
1820 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
1822 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
1824 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
1826 $self->_inject($table_class, @{$self->additional_base_classes});
1829 sub _is_result_class_method {
1830 my ($self, $name, $table_name) = @_;
1832 my $table_moniker = $table_name ? $self->monikers->{$table_name} : '';
1834 $self->_result_class_methods({})
1835 if not defined $self->_result_class_methods;
1837 if (not exists $self->_result_class_methods->{$table_moniker}) {
1838 my (@methods, %methods);
1839 my $base = $self->result_base_class || 'DBIx::Class::Core';
1841 my @components = @{ $self->components || [] };
1843 push @components, @{ $self->result_components_map->{$table_moniker} }
1844 if exists $self->result_components_map->{$table_moniker};
1846 for my $c (@components) {
1847 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
1850 my @roles = @{ $self->result_roles || [] };
1852 push @roles, @{ $self->result_roles_map->{$table_moniker} }
1853 if exists $self->result_roles_map->{$table_moniker};
1855 for my $class ($base, @components,
1856 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
1857 $self->ensure_class_loaded($class);
1859 push @methods, @{ Class::Inspector->methods($class) || [] };
1862 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1864 @methods{@methods} = ();
1866 $self->_result_class_methods->{$table_moniker} = \%methods;
1868 my $result_methods = $self->_result_class_methods->{$table_moniker};
1870 return exists $result_methods->{$name};
1873 sub _resolve_col_accessor_collisions {
1874 my ($self, $table, $col_info) = @_;
1876 my $table_name = ref $table ? $$table : $table;
1878 while (my ($col, $info) = each %$col_info) {
1879 my $accessor = $info->{accessor} || $col;
1881 next if $accessor eq 'id'; # special case (very common column)
1883 if ($self->_is_result_class_method($accessor, $table_name)) {
1886 if (my $map = $self->col_collision_map) {
1887 for my $re (keys %$map) {
1888 if (my @matches = $col =~ /$re/) {
1889 $info->{accessor} = sprintf $map->{$re}, @matches;
1897 Column '$col' in table '$table_name' collides with an inherited method.
1898 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1900 $info->{accessor} = undef;
1906 # use the same logic to run moniker_map, col_accessor_map
1908 my ( $self, $map, $default_code, $ident, @extra ) = @_;
1910 my $default_ident = $default_code->( $ident, @extra );
1912 if( $map && ref $map eq 'HASH' ) {
1913 $new_ident = $map->{ $ident };
1915 elsif( $map && ref $map eq 'CODE' ) {
1916 $new_ident = $map->( $ident, $default_ident, @extra );
1919 $new_ident ||= $default_ident;
1924 sub _default_column_accessor_name {
1925 my ( $self, $column_name ) = @_;
1927 my $accessor_name = $column_name;
1928 $accessor_name =~ s/\W+/_/g;
1930 if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
1931 # older naming just lc'd the col accessor and that's all.
1932 return lc $accessor_name;
1934 elsif (($self->naming->{column_accessors}||'') eq 'preserve') {
1935 return $accessor_name;
1938 return join '_', map lc, split_name $column_name;
1941 sub _make_column_accessor_name {
1942 my ($self, $column_name, $column_context_info ) = @_;
1944 my $accessor = $self->_run_user_map(
1945 $self->col_accessor_map,
1946 sub { $self->_default_column_accessor_name( shift ) },
1948 $column_context_info,
1955 my ($self, $identifier) = @_;
1957 my $qt = $self->schema->storage->sql_maker->quote_char || '';
1960 return $qt->[0] . $identifier . $qt->[1];
1963 return "${qt}${identifier}${qt}";
1966 # Set up metadata (cols, pks, etc)
1967 sub _setup_src_meta {
1968 my ($self, $table) = @_;
1970 my $schema = $self->schema;
1971 my $schema_class = $self->schema_class;
1973 my $table_class = $self->classes->{$table};
1974 my $table_moniker = $self->monikers->{$table};
1976 my $table_name = $table;
1978 my $sql_maker = $self->schema->storage->sql_maker;
1979 my $name_sep = $sql_maker->name_sep;
1981 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1982 $table_name = \ $self->_quote($table_name);
1985 my $full_table_name = ($self->qualify_objects ?
1986 ($self->_quote($self->db_schema) . '.') : '')
1987 . (ref $table_name ? $$table_name : $table_name);
1989 # be careful to not create refs Data::Dump can "optimize"
1990 $full_table_name = \do {"".$full_table_name} if ref $table_name;
1992 $self->_dbic_stmt($table_class, 'table', $full_table_name);
1994 my $cols = $self->_table_columns($table);
1995 my $col_info = $self->__columns_info_for($table);
1997 ### generate all the column accessor names
1998 while (my ($col, $info) = each %$col_info) {
1999 # hashref of other info that could be used by
2000 # user-defined accessor map functions
2002 table_class => $table_class,
2003 table_moniker => $table_moniker,
2004 table_name => $table_name,
2005 full_table_name => $full_table_name,
2006 schema_class => $schema_class,
2007 column_info => $info,
2010 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2013 $self->_resolve_col_accessor_collisions($table, $col_info);
2015 # prune any redundant accessor names
2016 while (my ($col, $info) = each %$col_info) {
2017 no warnings 'uninitialized';
2018 delete $info->{accessor} if $info->{accessor} eq $col;
2021 my $fks = $self->_table_fk_info($table);
2023 foreach my $fkdef (@$fks) {
2024 for my $col (@{ $fkdef->{local_columns} }) {
2025 $col_info->{$col}{is_foreign_key} = 1;
2029 my $pks = $self->_table_pk_info($table) || [];
2031 my %uniq_tag; # used to eliminate duplicate uniqs
2033 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2035 my $uniqs = $self->_table_uniq_info($table) || [];
2038 foreach my $uniq (@$uniqs) {
2039 my ($name, $cols) = @$uniq;
2040 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2041 push @uniqs, [$name, $cols];
2044 my @non_nullable_uniqs = grep {
2045 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2048 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2049 my @by_colnum = sort { $b->[0] <=> $a->[0] }
2050 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2052 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2053 my @keys = map $_->[1], @by_colnum;
2057 # remove the uniq from list
2058 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2064 foreach my $pkcol (@$pks) {
2065 $col_info->{$pkcol}{is_nullable} = 0;
2071 map { $_, ($col_info->{$_}||{}) } @$cols
2074 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2077 foreach my $uniq (@uniqs) {
2078 my ($name, $cols) = @$uniq;
2079 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2083 sub __columns_info_for {
2084 my ($self, $table) = @_;
2086 my $result = $self->_columns_info_for($table);
2088 while (my ($col, $info) = each %$result) {
2089 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
2090 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2092 $result->{$col} = $info;
2100 Returns a sorted list of loaded tables, using the original database table
2108 return keys %{$self->_tables};
2111 # Make a moniker from a table
2112 sub _default_table2moniker {
2113 no warnings 'uninitialized';
2114 my ($self, $table) = @_;
2116 if ($self->naming->{monikers} eq 'v4') {
2117 return join '', map ucfirst, split /[\W_]+/, lc $table;
2119 elsif ($self->naming->{monikers} eq 'v5') {
2120 return join '', map ucfirst, split /[\W_]+/,
2121 Lingua::EN::Inflect::Number::to_S(lc $table);
2123 elsif ($self->naming->{monikers} eq 'v6') {
2124 (my $as_phrase = lc $table) =~ s/_+/ /g;
2125 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2127 return join '', map ucfirst, split /\W+/, $inflected;
2130 my @words = map lc, split_name $table;
2131 my $as_phrase = join ' ', @words;
2133 my $inflected = $self->naming->{monikers} eq 'plural' ?
2134 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2136 $self->naming->{monikers} eq 'preserve' ?
2139 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2141 return join '', map ucfirst, split /\W+/, $inflected;
2144 sub _table2moniker {
2145 my ( $self, $table ) = @_;
2147 $self->_run_user_map(
2149 sub { $self->_default_table2moniker( shift ) },
2154 sub _load_relationships {
2155 my ($self, $tables) = @_;
2159 foreach my $table (@$tables) {
2160 my $tbl_fk_info = $self->_table_fk_info($table);
2161 foreach my $fkdef (@$tbl_fk_info) {
2162 $fkdef->{remote_source} =
2163 $self->monikers->{delete $fkdef->{remote_table}};
2165 my $tbl_uniq_info = $self->_table_uniq_info($table);
2167 my $local_moniker = $self->monikers->{$table};
2169 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2172 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2174 foreach my $src_class (sort keys %$rel_stmts) {
2175 my $src_stmts = $rel_stmts->{$src_class};
2176 foreach my $stmt (@$src_stmts) {
2177 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
2183 my ($self, $table) = @_;
2185 my $table_moniker = $self->monikers->{$table};
2186 my $table_class = $self->classes->{$table};
2188 my @roles = @{ $self->result_roles || [] };
2189 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2190 if exists $self->result_roles_map->{$table_moniker};
2193 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2195 $self->_with($table_class, @roles);
2199 # Overload these in driver class:
2201 # Returns an arrayref of column names
2202 sub _table_columns { croak "ABSTRACT METHOD" }
2204 # Returns arrayref of pk col names
2205 sub _table_pk_info { croak "ABSTRACT METHOD" }
2207 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2208 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2210 # Returns an arrayref of foreign key constraints, each
2211 # being a hashref with 3 keys:
2212 # local_columns (arrayref), remote_columns (arrayref), remote_table
2213 sub _table_fk_info { croak "ABSTRACT METHOD" }
2215 # Returns an array of lower case table names
2216 sub _tables_list { croak "ABSTRACT METHOD" }
2218 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2224 # generate the pod for this statement, storing it with $self->_pod
2225 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2227 my $args = dump(@_);
2228 $args = '(' . $args . ')' if @_ < 2;
2229 my $stmt = $method . $args . q{;};
2231 warn qq|$class\->$stmt\n| if $self->debug;
2232 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2236 sub _make_pod_heading {
2237 my ($self, $class) = @_;
2239 return '' if not $self->generate_pod;
2241 my $table = $self->class_to_table->{$class};
2244 my $pcm = $self->pod_comment_mode;
2245 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2246 $comment = $self->__table_comment($table);
2247 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2248 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2249 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2251 $pod .= "=head1 NAME\n\n";
2253 my $table_descr = $class;
2254 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2256 $pod .= "$table_descr\n\n";
2258 if ($comment and $comment_in_desc) {
2259 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2266 # generates the accompanying pod for a DBIC class method statement,
2267 # storing it with $self->_pod
2273 if ($method eq 'table') {
2275 $table = $$table if ref $table eq 'SCALAR';
2276 $self->_pod($class, "=head1 TABLE: C<$table>");
2277 $self->_pod_cut($class);
2279 elsif ( $method eq 'add_columns' ) {
2280 $self->_pod( $class, "=head1 ACCESSORS" );
2281 my $col_counter = 0;
2283 while( my ($name,$attrs) = splice @cols,0,2 ) {
2285 $self->_pod( $class, '=head2 ' . $name );
2286 $self->_pod( $class,
2288 my $s = $attrs->{$_};
2289 $s = !defined $s ? 'undef' :
2290 length($s) == 0 ? '(empty string)' :
2291 ref($s) eq 'SCALAR' ? $$s :
2292 ref($s) ? dumper_squashed $s :
2293 looks_like_number($s) ? $s : qq{'$s'};
2296 } sort keys %$attrs,
2298 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2299 $self->_pod( $class, $comment );
2302 $self->_pod_cut( $class );
2303 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2304 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2305 my ( $accessor, $rel_class ) = @_;
2306 $self->_pod( $class, "=head2 $accessor" );
2307 $self->_pod( $class, 'Type: ' . $method );
2308 $self->_pod( $class, "Related object: L<$rel_class>" );
2309 $self->_pod_cut( $class );
2310 $self->{_relations_started} { $class } = 1;
2312 elsif ($method eq 'add_unique_constraint') {
2313 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2314 unless $self->{_uniqs_started}{$class};
2316 my ($name, $cols) = @_;
2318 $self->_pod($class, "=head2 C<$name>");
2319 $self->_pod($class, '=over 4');
2321 foreach my $col (@$cols) {
2322 $self->_pod($class, "=item \* L</$col>");
2325 $self->_pod($class, '=back');
2326 $self->_pod_cut($class);
2328 $self->{_uniqs_started}{$class} = 1;
2330 elsif ($method eq 'set_primary_key') {
2331 $self->_pod($class, "=head1 PRIMARY KEY");
2332 $self->_pod($class, '=over 4');
2334 foreach my $col (@_) {
2335 $self->_pod($class, "=item \* L</$col>");
2338 $self->_pod($class, '=back');
2339 $self->_pod_cut($class);
2343 sub _pod_class_list {
2344 my ($self, $class, $title, @classes) = @_;
2346 return unless @classes && $self->generate_pod;
2348 $self->_pod($class, "=head1 $title");
2349 $self->_pod($class, '=over 4');
2351 foreach my $link (@classes) {
2352 $self->_pod($class, "=item * L<$link>");
2355 $self->_pod($class, '=back');
2356 $self->_pod_cut($class);
2359 sub _base_class_pod {
2360 my ($self, $base_class) = @_;
2362 return unless $self->generate_pod;
2365 =head1 BASE CLASS: L<$base_class>
2372 sub _filter_comment {
2373 my ($self, $txt) = @_;
2375 $txt = '' if not defined $txt;
2377 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2382 sub __table_comment {
2385 if (my $code = $self->can('_table_comment')) {
2386 return $self->_filter_comment($self->$code(@_));
2392 sub __column_comment {
2395 if (my $code = $self->can('_column_comment')) {
2396 return $self->_filter_comment($self->$code(@_));
2402 # Stores a POD documentation
2404 my ($self, $class, $stmt) = @_;
2405 $self->_raw_stmt( $class, "\n" . $stmt );
2409 my ($self, $class ) = @_;
2410 $self->_raw_stmt( $class, "\n=cut\n" );
2413 # Store a raw source line for a class (for dumping purposes)
2415 my ($self, $class, $stmt) = @_;
2416 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2419 # Like above, but separately for the externally loaded stuff
2421 my ($self, $class, $stmt) = @_;
2422 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2425 sub _custom_column_info {
2426 my ( $self, $table_name, $column_name, $column_info ) = @_;
2428 if (my $code = $self->custom_column_info) {
2429 return $code->($table_name, $column_name, $column_info) || {};
2434 sub _datetime_column_info {
2435 my ( $self, $table_name, $column_name, $column_info ) = @_;
2437 my $type = $column_info->{data_type} || '';
2438 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2439 or ($type =~ /date|timestamp/i)) {
2440 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2441 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2447 my ($self, $name) = @_;
2449 return $self->preserve_case ? $name : lc($name);
2453 my ($self, $name) = @_;
2455 return $self->preserve_case ? $name : uc($name);
2458 sub _unregister_source_for_table {
2459 my ($self, $table) = @_;
2463 my $schema = $self->schema;
2464 # in older DBIC it's a private method
2465 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2466 $schema->$unregister($self->_table2moniker($table));
2467 delete $self->monikers->{$table};
2468 delete $self->classes->{$table};
2469 delete $self->_upgrading_classes->{$table};
2470 delete $self->{_tables}{$table};
2474 # remove the dump dir from @INC on destruction
2478 @INC = grep $_ ne $self->dump_directory, @INC;
2483 Returns a hashref of loaded table to moniker mappings. There will
2484 be two entries for each table, the original name and the "normalized"
2485 name, in the case that the two are different (such as databases
2486 that like uppercase table names, or preserve your original mixed-case
2487 definitions, or what-have-you).
2491 Returns a hashref of table to class mappings. In some cases it will
2492 contain multiple entries per table for the original and normalized table
2493 names, as above in L</monikers>.
2495 =head1 COLUMN ACCESSOR COLLISIONS
2497 Occasionally you may have a column name that collides with a perl method, such
2498 as C<can>. In such cases, the default action is to set the C<accessor> of the
2499 column spec to C<undef>.
2501 You can then name the accessor yourself by placing code such as the following
2504 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2506 Another option is to use the L</col_collision_map> option.
2508 =head1 RELATIONSHIP NAME COLLISIONS
2510 In very rare cases, you may get a collision between a generated relationship
2511 name and a method in your Result class, for example if you have a foreign key
2512 called C<belongs_to>.
2514 This is a problem because relationship names are also relationship accessor
2515 methods in L<DBIx::Class>.
2517 The default behavior is to append C<_rel> to the relationship name and print
2518 out a warning that refers to this text.
2520 You can also control the renaming with the L</rel_collision_map> option.
2524 L<DBIx::Class::Schema::Loader>
2528 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2532 This library is free software; you can redistribute it and/or modify it under
2533 the same terms as Perl itself.
2538 # vim:et sts=4 sw=4 tw=0: