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
98 datetime_undef_if_invalid
105 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
109 See L<DBIx::Class::Schema::Loader>
113 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
114 classes, and implements the common functionality between them.
116 =head1 CONSTRUCTOR OPTIONS
118 These constructor options are the base options for
119 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
121 =head2 skip_relationships
123 Skip setting up relationships. The default is to attempt the loading
126 =head2 skip_load_external
128 Skip loading of other classes in @INC. The default is to merge all other classes
129 with the same name found in @INC into the schema file we are creating.
133 Static schemas (ones dumped to disk) will, by default, use the new-style
134 relationship names and singularized Results, unless you're overwriting an
135 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
136 which case the backward compatible RelBuilder will be activated, and the
137 appropriate monikerization used.
143 will disable the backward-compatible RelBuilder and use
144 the new-style relationship names along with singularized Results, even when
145 overwriting a dump made with an earlier version.
147 The option also takes a hashref:
149 naming => { relationships => 'v7', monikers => 'v7' }
157 How to name relationship accessors.
161 How to name Result classes.
163 =item column_accessors
165 How to name column accessors in Result classes.
175 Latest style, whatever that happens to be.
179 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
183 Monikers singularized as whole words, C<might_have> relationships for FKs on
184 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
186 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
191 All monikers and relationships are inflected using
192 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
193 from relationship names.
195 In general, there is very little difference between v5 and v6 schemas.
199 This mode is identical to C<v6> mode, except that monikerization of CamelCase
200 table names is also done correctly.
202 CamelCase column names in case-preserving mode will also be handled correctly
203 for relationship name inflection. See L</preserve_case>.
205 In this mode, CamelCase L</column_accessors> are normalized based on case
206 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
208 If you don't have any CamelCase table or column names, you can upgrade without
209 breaking any of your code.
213 For L</monikers>, this option does not inflect the table names but makes
214 monikers based on the actual name. For L</column_accessors> this option does
215 not normalize CamelCase column names to lowercase column accessors, but makes
216 accessors that are the same names as the columns (with any non-\w chars
217 replaced with underscores.)
221 For L</monikers>, singularizes the names using the most current inflector. This
222 is the same as setting the option to L</current>.
226 For L</monikers>, pluralizes the names, using the most current inflector.
230 Dynamic schemas will always default to the 0.04XXX relationship names and won't
231 singularize Results for backward compatibility, to activate the new RelBuilder
232 and singularization put this in your C<Schema.pm> file:
234 __PACKAGE__->naming('current');
236 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
237 next major version upgrade:
239 __PACKAGE__->naming('v7');
243 By default POD will be generated for columns and relationships, using database
244 metadata for the text if available and supported.
246 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
247 supported for Postgres right now.
249 Set this to C<0> to turn off all POD generation.
251 =head2 pod_comment_mode
253 Controls where table comments appear in the generated POD. Smaller table
254 comments are appended to the C<NAME> section of the documentation, and larger
255 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
256 section to be generated with the comment always, only use C<NAME>, or choose
257 the length threshold at which the comment is forced into the description.
263 Use C<NAME> section only.
267 Force C<DESCRIPTION> always.
271 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
276 =head2 pod_comment_spillover_length
278 When pod_comment_mode is set to C<auto>, this is the length of the comment at
279 which it will be forced into a separate description section.
283 =head2 relationship_attrs
285 Hashref of attributes to pass to each generated relationship, listed
286 by type. Also supports relationship type 'all', containing options to
287 pass to all generated relationships. Attributes set for more specific
288 relationship types override those set in 'all'.
292 relationship_attrs => {
293 belongs_to => { is_deferrable => 0 },
296 use this to turn off DEFERRABLE on your foreign key constraints.
300 If set to true, each constructive L<DBIx::Class> statement the loader
301 decides to execute will be C<warn>-ed before execution.
305 Set the name of the schema to load (schema in the sense that your database
306 vendor means it). Does not currently support loading more than one schema
311 Only load tables matching regex. Best specified as a qr// regex.
315 Exclude tables matching regex. Best specified as a qr// regex.
319 Overrides the default table name to moniker translation. Can be either
320 a hashref of table keys and moniker values, or a coderef for a translator
321 function taking a single scalar table name argument and returning
322 a scalar moniker. If the hash entry does not exist, or the function
323 returns a false value, the code falls back to default behavior
326 The default behavior is to split on case transition and non-alphanumeric
327 boundaries, singularize the resulting phrase, then join the titlecased words
330 Table Name | Moniker Name
331 ---------------------------------
333 luser_group | LuserGroup
334 luser-opts | LuserOpt
335 stations_visited | StationVisited
336 routeChange | RouteChange
338 =head2 col_accessor_map
340 Same as moniker_map, but for column accessor names. If a coderef is
341 passed, the code is called with arguments of
343 the name of the column in the underlying database,
344 default accessor name that DBICSL would ordinarily give this column,
346 table_class => name of the DBIC class we are building,
347 table_moniker => calculated moniker for this table (after moniker_map if present),
348 table_name => name of the database table,
349 full_table_name => schema-qualified name of the database table (RDBMS specific),
350 schema_class => name of the schema class we are building,
351 column_info => hashref of column info (data_type, is_nullable, etc),
354 =head2 inflect_plural
356 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
357 if hash key does not exist or coderef returns false), but acts as a map
358 for pluralizing relationship names. The default behavior is to utilize
359 L<Lingua::EN::Inflect::Phrase/to_PL>.
361 =head2 inflect_singular
363 As L</inflect_plural> above, but for singularizing relationship names.
364 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
366 =head2 schema_base_class
368 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
370 =head2 result_base_class
372 Base class for your table classes (aka result classes). Defaults to
375 =head2 additional_base_classes
377 List of additional base classes all of your table classes will use.
379 =head2 left_base_classes
381 List of additional base classes all of your table classes will use
382 that need to be leftmost.
384 =head2 additional_classes
386 List of additional classes which all of your table classes will use.
390 List of additional components to be loaded into all of your table
391 classes. A good example would be
392 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
394 =head2 result_components_map
396 A hashref of moniker keys and component values. Unlike L</components>, which
397 loads the given components into every Result class, this option allows you to
398 load certain components for specified Result classes. For example:
400 result_components_map => {
401 StationVisited => '+YourApp::Schema::Component::StationVisited',
403 '+YourApp::Schema::Component::RouteChange',
404 'InflateColumn::DateTime',
408 You may use this in conjunction with L</components>.
412 List of L<Moose> roles to be applied to all of your Result classes.
414 =head2 result_roles_map
416 A hashref of moniker keys and role values. Unlike L</result_roles>, which
417 applies the given roles to every Result class, this option allows you to apply
418 certain roles for specified Result classes. For example:
420 result_roles_map => {
422 'YourApp::Role::Building',
423 'YourApp::Role::Destination',
425 RouteChange => 'YourApp::Role::TripEvent',
428 You may use this in conjunction with L</result_roles>.
430 =head2 use_namespaces
432 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
435 Generate result class names suitable for
436 L<DBIx::Class::Schema/load_namespaces> and call that instead of
437 L<DBIx::Class::Schema/load_classes>. When using this option you can also
438 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
439 C<resultset_namespace>, C<default_resultset_class>), and they will be added
440 to the call (and the generated result class names adjusted appropriately).
442 =head2 dump_directory
444 The value of this option is a perl libdir pathname. Within
445 that directory this module will create a baseline manual
446 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
448 The created schema class will have the same classname as the one on
449 which you are setting this option (and the ResultSource classes will be
450 based on this name as well).
452 Normally you wouldn't hard-code this setting in your schema class, as it
453 is meant for one-time manual usage.
455 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
456 recommended way to access this functionality.
458 =head2 dump_overwrite
460 Deprecated. See L</really_erase_my_files> below, which does *not* mean
461 the same thing as the old C<dump_overwrite> setting from previous releases.
463 =head2 really_erase_my_files
465 Default false. If true, Loader will unconditionally delete any existing
466 files before creating the new ones from scratch when dumping a schema to disk.
468 The default behavior is instead to only replace the top portion of the
469 file, up to and including the final stanza which contains
470 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
471 leaving any customizations you placed after that as they were.
473 When C<really_erase_my_files> is not set, if the output file already exists,
474 but the aforementioned final stanza is not found, or the checksum
475 contained there does not match the generated contents, Loader will
476 croak and not touch the file.
478 You should really be using version control on your schema classes (and all
479 of the rest of your code for that matter). Don't blame me if a bug in this
480 code wipes something out when it shouldn't have, you've been warned.
482 =head2 overwrite_modifications
484 Default false. If false, when updating existing files, Loader will
485 refuse to modify any Loader-generated code that has been modified
486 since its last run (as determined by the checksum Loader put in its
489 If true, Loader will discard any manual modifications that have been
490 made to Loader-generated code.
492 Again, you should be using version control on your schema classes. Be
493 careful with this option.
495 =head2 custom_column_info
497 Hook for adding extra attributes to the
498 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
500 Must be a coderef that returns a hashref with the extra attributes.
502 Receives the table name, column name and column_info.
506 custom_column_info => sub {
507 my ($table_name, $column_name, $column_info) = @_;
509 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
510 return { is_snoopy => 1 };
514 This attribute can also be used to set C<inflate_datetime> on a non-datetime
515 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
517 =head2 datetime_timezone
519 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
520 columns with the DATE/DATETIME/TIMESTAMP data_types.
522 =head2 datetime_locale
524 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
525 columns with the DATE/DATETIME/TIMESTAMP data_types.
527 =head2 datetime_undef_if_invalid
529 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
530 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
533 The default is recommended to deal with data such as C<00/00/00> which
534 sometimes ends up in such columns in MySQL.
538 File in Perl format, which should return a HASH reference, from which to read
543 Usually column names are lowercased, to make them easier to work with in
544 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
547 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
548 case-sensitive collation will turn this option on unconditionally.
550 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
553 =head2 qualify_objects
555 Set to true to prepend the L</db_schema> to table names for C<<
556 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
560 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
561 L<namespace::autoclean>. The default content after the md5 sum also makes the
564 It is safe to upgrade your existing Schema to this option.
566 =head2 col_collision_map
568 This option controls how accessors for column names which collide with perl
569 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
571 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
572 strings which are compiled to regular expressions that map to
573 L<sprintf|perlfunc/sprintf> formats.
577 col_collision_map => 'column_%s'
579 col_collision_map => { '(.*)' => 'column_%s' }
581 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
583 =head2 rel_collision_map
585 Works just like L</col_collision_map>, but for relationship names/accessors
586 rather than column names/accessors.
588 The default is to just append C<_rel> to the relationship name, see
589 L</RELATIONSHIP NAME COLLISIONS>.
591 =head2 uniq_to_primary
593 Automatically promotes the largest unique constraints with non-nullable columns
594 on tables to primary keys, assuming there is only one largest unique
599 None of these methods are intended for direct invocation by regular
600 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
601 L<DBIx::Class::Schema::Loader>.
605 my $CURRENT_V = 'v7';
608 schema_base_class result_base_class additional_base_classes
609 left_base_classes additional_classes components result_roles
612 # ensure that a peice of object data is a valid arrayref, creating
613 # an empty one or encapsulating whatever's there.
614 sub _ensure_arrayref {
619 $self->{$_} = [ $self->{$_} ]
620 unless ref $self->{$_} eq 'ARRAY';
626 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
627 by L<DBIx::Class::Schema::Loader>.
632 my ( $class, %args ) = @_;
634 if (exists $args{column_accessor_map}) {
635 $args{col_accessor_map} = delete $args{column_accessor_map};
638 my $self = { %args };
640 # don't lose undef options
641 for (values %$self) {
642 $_ = 0 unless defined $_;
645 bless $self => $class;
647 if (my $config_file = $self->config_file) {
648 my $config_opts = do $config_file;
650 croak "Error reading config from $config_file: $@" if $@;
652 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
654 while (my ($k, $v) = each %$config_opts) {
655 $self->{$k} = $v unless exists $self->{$k};
659 $self->result_components_map($self->{result_component_map})
660 if defined $self->{result_component_map};
662 $self->result_roles_map($self->{result_role_map})
663 if defined $self->{result_role_map};
665 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
666 if ((not defined $self->use_moose) || (not $self->use_moose))
667 && ((defined $self->result_roles) || (defined $self->result_roles_map));
669 $self->_ensure_arrayref(qw/additional_classes
670 additional_base_classes
676 $self->_validate_class_args;
678 croak "result_components_map must be a hash"
679 if defined $self->result_components_map
680 && ref $self->result_components_map ne 'HASH';
682 if ($self->result_components_map) {
683 my %rc_map = %{ $self->result_components_map };
684 foreach my $moniker (keys %rc_map) {
685 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
687 $self->result_components_map(\%rc_map);
690 $self->result_components_map({});
692 $self->_validate_result_components_map;
694 croak "result_roles_map must be a hash"
695 if defined $self->result_roles_map
696 && ref $self->result_roles_map ne 'HASH';
698 if ($self->result_roles_map) {
699 my %rr_map = %{ $self->result_roles_map };
700 foreach my $moniker (keys %rr_map) {
701 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
703 $self->result_roles_map(\%rr_map);
705 $self->result_roles_map({});
707 $self->_validate_result_roles_map;
709 if ($self->use_moose) {
710 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
711 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
712 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
716 $self->{monikers} = {};
717 $self->{tables} = {};
718 $self->{class_to_table} = {};
719 $self->{classes} = {};
720 $self->{_upgrading_classes} = {};
722 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
723 $self->{schema} ||= $self->{schema_class};
725 croak "dump_overwrite is deprecated. Please read the"
726 . " DBIx::Class::Schema::Loader::Base documentation"
727 if $self->{dump_overwrite};
729 $self->{dynamic} = ! $self->{dump_directory};
730 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
735 $self->{dump_directory} ||= $self->{temp_directory};
737 $self->real_dump_directory($self->{dump_directory});
739 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
740 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
742 if (not defined $self->naming) {
743 $self->naming_set(0);
746 $self->naming_set(1);
749 if ((not ref $self->naming) && defined $self->naming) {
750 my $naming_ver = $self->naming;
752 relationships => $naming_ver,
753 monikers => $naming_ver,
754 column_accessors => $naming_ver,
759 for (values %{ $self->naming }) {
760 $_ = $CURRENT_V if $_ eq 'current';
763 $self->{naming} ||= {};
765 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
766 croak 'custom_column_info must be a CODE ref';
769 $self->_check_back_compat;
771 $self->use_namespaces(1) unless defined $self->use_namespaces;
772 $self->generate_pod(1) unless defined $self->generate_pod;
773 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
774 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
776 if (my $col_collision_map = $self->col_collision_map) {
777 if (my $reftype = ref $col_collision_map) {
778 if ($reftype ne 'HASH') {
779 croak "Invalid type $reftype for option 'col_collision_map'";
783 $self->col_collision_map({ '(.*)' => $col_collision_map });
790 sub _check_back_compat {
793 # dynamic schemas will always be in 0.04006 mode, unless overridden
794 if ($self->dynamic) {
795 # just in case, though no one is likely to dump a dynamic schema
796 $self->schema_version_to_dump('0.04006');
798 if (not $self->naming_set) {
799 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
801 Dynamic schema detected, will run in 0.04006 mode.
803 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
804 to disable this warning.
806 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
811 $self->_upgrading_from('v4');
814 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
815 $self->use_namespaces(1);
818 $self->naming->{relationships} ||= 'v4';
819 $self->naming->{monikers} ||= 'v4';
821 if ($self->use_namespaces) {
822 $self->_upgrading_from_load_classes(1);
825 $self->use_namespaces(0);
831 # otherwise check if we need backcompat mode for a static schema
832 my $filename = $self->get_dump_filename($self->schema_class);
833 return unless -e $filename;
835 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
836 $self->_parse_generated_file($filename);
838 return unless $old_ver;
840 # determine if the existing schema was dumped with use_moose => 1
841 if (! defined $self->use_moose) {
842 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
845 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
847 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
848 my $ds = eval $result_namespace;
850 Could not eval expression '$result_namespace' for result_namespace from
853 $result_namespace = $ds || '';
855 if ($load_classes && (not defined $self->use_namespaces)) {
856 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
858 'load_classes;' static schema detected, turning off 'use_namespaces'.
860 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
861 variable to disable this warning.
863 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
866 $self->use_namespaces(0);
868 elsif ($load_classes && $self->use_namespaces) {
869 $self->_upgrading_from_load_classes(1);
871 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
872 $self->_downgrading_to_load_classes(
873 $result_namespace || 'Result'
876 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
877 if (not $self->result_namespace) {
878 $self->result_namespace($result_namespace || 'Result');
880 elsif ($result_namespace ne $self->result_namespace) {
881 $self->_rewriting_result_namespace(
882 $result_namespace || 'Result'
887 # XXX when we go past .0 this will need fixing
888 my ($v) = $old_ver =~ /([1-9])/;
891 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
893 if (not %{ $self->naming }) {
894 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
896 Version $old_ver static schema detected, turning on backcompat mode.
898 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
899 to disable this warning.
901 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
903 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
904 from version 0.04006.
907 $self->naming->{relationships} ||= $v;
908 $self->naming->{monikers} ||= $v;
909 $self->naming->{column_accessors} ||= $v;
911 $self->schema_version_to_dump($old_ver);
914 $self->_upgrading_from($v);
918 sub _validate_class_args {
921 foreach my $k (@CLASS_ARGS) {
922 next unless $self->$k;
924 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
925 $self->_validate_classes($k, \@classes);
929 sub _validate_result_components_map {
932 foreach my $classes (values %{ $self->result_components_map }) {
933 $self->_validate_classes('result_components_map', $classes);
937 sub _validate_result_roles_map {
940 foreach my $classes (values %{ $self->result_roles_map }) {
941 $self->_validate_classes('result_roles_map', $classes);
945 sub _validate_classes {
950 # make a copy to not destroy original
951 my @classes = @$classes;
953 foreach my $c (@classes) {
954 # components default to being under the DBIx::Class namespace unless they
955 # are preceeded with a '+'
956 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
957 $c = 'DBIx::Class::' . $c;
960 # 1 == installed, 0 == not installed, undef == invalid classname
961 my $installed = Class::Inspector->installed($c);
962 if ( defined($installed) ) {
963 if ( $installed == 0 ) {
964 croak qq/$c, as specified in the loader option "$key", is not installed/;
967 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
973 sub _find_file_in_inc {
974 my ($self, $file) = @_;
976 foreach my $prefix (@INC) {
977 my $fullpath = File::Spec->catfile($prefix, $file);
978 return $fullpath if -f $fullpath
979 # abs_path throws on Windows for nonexistant files
980 and (try { Cwd::abs_path($fullpath) }) ne
981 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
987 sub _find_class_in_inc {
988 my ($self, $class) = @_;
990 return $self->_find_file_in_inc(class_path($class));
996 return $self->_upgrading_from
997 || $self->_upgrading_from_load_classes
998 || $self->_downgrading_to_load_classes
999 || $self->_rewriting_result_namespace
1003 sub _rewrite_old_classnames {
1004 my ($self, $code) = @_;
1006 return $code unless $self->_rewriting;
1008 my %old_classes = reverse %{ $self->_upgrading_classes };
1010 my $re = join '|', keys %old_classes;
1011 $re = qr/\b($re)\b/;
1013 $code =~ s/$re/$old_classes{$1} || $1/eg;
1018 sub _load_external {
1019 my ($self, $class) = @_;
1021 return if $self->{skip_load_external};
1023 # so that we don't load our own classes, under any circumstances
1024 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1026 my $real_inc_path = $self->_find_class_in_inc($class);
1028 my $old_class = $self->_upgrading_classes->{$class}
1029 if $self->_rewriting;
1031 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1032 if $old_class && $old_class ne $class;
1034 return unless $real_inc_path || $old_real_inc_path;
1036 if ($real_inc_path) {
1037 # If we make it to here, we loaded an external definition
1038 warn qq/# Loaded external class definition for '$class'\n/
1041 my $code = $self->_rewrite_old_classnames(scalar read_file($real_inc_path, binmode => ':encoding(UTF-8)'));
1043 if ($self->dynamic) { # load the class too
1044 eval_package_without_redefine_warnings($class, $code);
1047 $self->_ext_stmt($class,
1048 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1049 .qq|# They are now part of the custom portion of this file\n|
1050 .qq|# for you to hand-edit. If you do not either delete\n|
1051 .qq|# this section or remove that file from \@INC, this section\n|
1052 .qq|# will be repeated redundantly when you re-create this\n|
1053 .qq|# file again via Loader! See skip_load_external to disable\n|
1054 .qq|# this feature.\n|
1057 $self->_ext_stmt($class, $code);
1058 $self->_ext_stmt($class,
1059 qq|# End of lines loaded from '$real_inc_path' |
1063 if ($old_real_inc_path) {
1064 my $code = read_file($old_real_inc_path, binmode => ':encoding(UTF-8)');
1066 $self->_ext_stmt($class, <<"EOF");
1068 # These lines were loaded from '$old_real_inc_path',
1069 # based on the Result class name that would have been created by an older
1070 # version of the Loader. For a static schema, this happens only once during
1071 # upgrade. See skip_load_external to disable this feature.
1074 $code = $self->_rewrite_old_classnames($code);
1076 if ($self->dynamic) {
1079 Detected external content in '$old_real_inc_path', a class name that would have
1080 been used by an older version of the Loader.
1082 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1083 new name of the Result.
1085 eval_package_without_redefine_warnings($class, $code);
1089 $self->_ext_stmt($class, $code);
1090 $self->_ext_stmt($class,
1091 qq|# End of lines loaded from '$old_real_inc_path' |
1098 Does the actual schema-construction work.
1105 $self->_load_tables(
1106 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1114 Rescan the database for changes. Returns a list of the newly added table
1117 The schema argument should be the schema class or object to be affected. It
1118 should probably be derived from the original schema_class used during L</load>.
1123 my ($self, $schema) = @_;
1125 $self->{schema} = $schema;
1126 $self->_relbuilder->{schema} = $schema;
1129 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1131 foreach my $table (@current) {
1132 if(!exists $self->{_tables}->{$table}) {
1133 push(@created, $table);
1138 @current{@current} = ();
1139 foreach my $table (keys %{ $self->{_tables} }) {
1140 if (not exists $current{$table}) {
1141 $self->_unregister_source_for_table($table);
1145 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1147 my $loaded = $self->_load_tables(@current);
1149 return map { $self->monikers->{$_} } @created;
1155 return if $self->{skip_relationships};
1157 return $self->{relbuilder} ||= do {
1159 no warnings 'uninitialized';
1160 my $relbuilder_suff =
1166 ->{ $self->naming->{relationships}};
1168 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1169 $self->ensure_class_loaded($relbuilder_class);
1170 $relbuilder_class->new( $self );
1176 my ($self, @tables) = @_;
1178 # Save the new tables to the tables list
1180 $self->{_tables}->{$_} = 1;
1183 $self->_make_src_class($_) for @tables;
1185 # sanity-check for moniker clashes
1186 my $inverse_moniker_idx;
1187 for (keys %{$self->monikers}) {
1188 push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1192 for (keys %$inverse_moniker_idx) {
1193 my $tables = $inverse_moniker_idx->{$_};
1195 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1196 join (', ', map { "'$_'" } @$tables),
1203 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1204 . 'Either change the naming style, or supply an explicit moniker_map: '
1205 . join ('; ', @clashes)
1211 $self->_setup_src_meta($_) for @tables;
1213 if(!$self->skip_relationships) {
1214 # The relationship loader needs a working schema
1216 local $self->{dump_directory} = $self->{temp_directory};
1217 $self->_reload_classes(\@tables);
1218 $self->_load_relationships(\@tables);
1221 # Remove that temp dir from INC so it doesn't get reloaded
1222 @INC = grep $_ ne $self->dump_directory, @INC;
1225 $self->_load_roles($_) for @tables;
1227 $self->_load_external($_)
1228 for map { $self->classes->{$_} } @tables;
1230 # Reload without unloading first to preserve any symbols from external
1232 $self->_reload_classes(\@tables, { unload => 0 });
1234 # Drop temporary cache
1235 delete $self->{_cache};
1240 sub _reload_classes {
1241 my ($self, $tables, $opts) = @_;
1243 my @tables = @$tables;
1245 my $unload = $opts->{unload};
1246 $unload = 1 unless defined $unload;
1248 # so that we don't repeat custom sections
1249 @INC = grep $_ ne $self->dump_directory, @INC;
1251 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1253 unshift @INC, $self->dump_directory;
1256 my %have_source = map { $_ => $self->schema->source($_) }
1257 $self->schema->sources;
1259 for my $table (@tables) {
1260 my $moniker = $self->monikers->{$table};
1261 my $class = $self->classes->{$table};
1264 no warnings 'redefine';
1265 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1268 if (my $mc = $self->_moose_metaclass($class)) {
1271 Class::Unload->unload($class) if $unload;
1272 my ($source, $resultset_class);
1274 ($source = $have_source{$moniker})
1275 && ($resultset_class = $source->resultset_class)
1276 && ($resultset_class ne 'DBIx::Class::ResultSet')
1278 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1279 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1282 Class::Unload->unload($resultset_class) if $unload;
1283 $self->_reload_class($resultset_class) if $has_file;
1285 $self->_reload_class($class);
1287 push @to_register, [$moniker, $class];
1290 Class::C3->reinitialize;
1291 for (@to_register) {
1292 $self->schema->register_class(@$_);
1296 sub _moose_metaclass {
1297 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1301 my $mc = try { Class::MOP::class_of($class) }
1304 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1307 # We use this instead of ensure_class_loaded when there are package symbols we
1310 my ($self, $class) = @_;
1312 delete $INC{ +class_path($class) };
1315 eval_package_without_redefine_warnings ($class, "require $class");
1318 my $source = read_file($self->_get_dump_filename($class), binmode => ':encoding(UTF-8)');
1319 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1323 sub _get_dump_filename {
1324 my ($self, $class) = (@_);
1326 $class =~ s{::}{/}g;
1327 return $self->dump_directory . q{/} . $class . q{.pm};
1330 =head2 get_dump_filename
1334 Returns the full path to the file for a class that the class has been or will
1335 be dumped to. This is a file in a temp dir for a dynamic schema.
1339 sub get_dump_filename {
1340 my ($self, $class) = (@_);
1342 local $self->{dump_directory} = $self->real_dump_directory;
1344 return $self->_get_dump_filename($class);
1347 sub _ensure_dump_subdirs {
1348 my ($self, $class) = (@_);
1350 my @name_parts = split(/::/, $class);
1351 pop @name_parts; # we don't care about the very last element,
1352 # which is a filename
1354 my $dir = $self->dump_directory;
1357 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1359 last if !@name_parts;
1360 $dir = File::Spec->catdir($dir, shift @name_parts);
1365 my ($self, @classes) = @_;
1367 my $schema_class = $self->schema_class;
1368 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1370 my $target_dir = $self->dump_directory;
1371 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1372 unless $self->{dynamic} or $self->{quiet};
1375 qq|package $schema_class;\n\n|
1376 . qq|# Created by DBIx::Class::Schema::Loader\n|
1377 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1379 if ($self->use_moose) {
1380 $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1383 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1386 if ($self->use_namespaces) {
1387 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1388 my $namespace_options;
1390 my @attr = qw/resultset_namespace default_resultset_class/;
1392 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1394 for my $attr (@attr) {
1396 my $code = dumper_squashed $self->$attr;
1397 $namespace_options .= qq| $attr => $code,\n|
1400 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1401 $schema_text .= qq|;\n|;
1404 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1408 local $self->{version_to_dump} = $self->schema_version_to_dump;
1409 $self->_write_classfile($schema_class, $schema_text, 1);
1412 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1414 foreach my $src_class (@classes) {
1416 qq|package $src_class;\n\n|
1417 . qq|# Created by DBIx::Class::Schema::Loader\n|
1418 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1420 $src_text .= $self->_make_pod_heading($src_class);
1422 $src_text .= qq|use strict;\nuse warnings;\n\n|;
1424 $src_text .= $self->_base_class_pod($result_base_class)
1425 unless $result_base_class eq 'DBIx::Class::Core';
1427 if ($self->use_moose) {
1428 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1430 # these options 'use base' which is compile time
1431 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1432 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1435 $src_text .= qq|\nextends '$result_base_class';\n|;
1439 $src_text .= qq|use base '$result_base_class';\n|;
1442 $self->_write_classfile($src_class, $src_text);
1445 # remove Result dir if downgrading from use_namespaces, and there are no
1447 if (my $result_ns = $self->_downgrading_to_load_classes
1448 || $self->_rewriting_result_namespace) {
1449 my $result_namespace = $self->_result_namespace(
1454 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1455 $result_dir = $self->dump_directory . '/' . $result_dir;
1457 unless (my @files = glob "$result_dir/*") {
1462 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1467 my ($self, $version, $ts) = @_;
1468 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1471 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1474 sub _write_classfile {
1475 my ($self, $class, $text, $is_schema) = @_;
1477 my $filename = $self->_get_dump_filename($class);
1478 $self->_ensure_dump_subdirs($class);
1480 if (-f $filename && $self->really_erase_my_files) {
1481 warn "Deleting existing file '$filename' due to "
1482 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1486 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1487 = $self->_parse_generated_file($filename);
1489 if (! $old_gen && -f $filename) {
1490 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1491 . " it does not appear to have been generated by Loader"
1494 my $custom_content = $old_custom || '';
1496 # prepend extra custom content from a *renamed* class (singularization effect)
1497 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1498 my $old_filename = $self->_get_dump_filename($renamed_class);
1500 if (-f $old_filename) {
1501 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1503 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1505 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1508 unlink $old_filename;
1512 $custom_content ||= $self->_default_custom_content($is_schema);
1514 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1515 # If there is already custom content, which does not have the Moose content, add it.
1516 if ($self->use_moose) {
1518 my $non_moose_custom_content = do {
1519 local $self->{use_moose} = 0;
1520 $self->_default_custom_content;
1523 if ($custom_content eq $non_moose_custom_content) {
1524 $custom_content = $self->_default_custom_content($is_schema);
1526 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1527 $custom_content .= $self->_default_custom_content($is_schema);
1530 elsif (defined $self->use_moose && $old_gen) {
1531 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'
1532 if $old_gen =~ /use \s+ MooseX?\b/x;
1535 $custom_content = $self->_rewrite_old_classnames($custom_content);
1538 for @{$self->{_dump_storage}->{$class} || []};
1540 # Check and see if the dump is infact differnt
1544 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1545 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1546 return unless $self->_upgrading_from && $is_schema;
1550 $text .= $self->_sig_comment(
1551 $self->version_to_dump,
1552 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1555 open(my $fh, '>:encoding(UTF-8)', $filename)
1556 or croak "Cannot open '$filename' for writing: $!";
1558 # Write the top half and its MD5 sum
1559 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1561 # Write out anything loaded via external partial class file in @INC
1563 for @{$self->{_ext_storage}->{$class} || []};
1565 # Write out any custom content the user has added
1566 print $fh $custom_content;
1569 or croak "Error closing '$filename': $!";
1572 sub _default_moose_custom_content {
1573 my ($self, $is_schema) = @_;
1575 if (not $is_schema) {
1576 return qq|\n__PACKAGE__->meta->make_immutable;|;
1579 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1582 sub _default_custom_content {
1583 my ($self, $is_schema) = @_;
1584 my $default = qq|\n\n# You can replace this text with custom|
1585 . qq| code or comments, and it will be preserved on regeneration|;
1586 if ($self->use_moose) {
1587 $default .= $self->_default_moose_custom_content($is_schema);
1589 $default .= qq|\n1;\n|;
1593 sub _parse_generated_file {
1594 my ($self, $fn) = @_;
1596 return unless -f $fn;
1598 open(my $fh, '<:encoding(UTF-8)', $fn)
1599 or croak "Cannot open '$fn' for reading: $!";
1602 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1604 my ($md5, $ts, $ver, $gen);
1610 # Pull out the version and timestamp from the line above
1611 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1614 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"
1615 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
1624 my $custom = do { local $/; <$fh> }
1629 return ($gen, $md5, $ver, $ts, $custom);
1637 warn "$target: use $_;" if $self->debug;
1638 $self->_raw_stmt($target, "use $_;");
1646 my $blist = join(q{ }, @_);
1648 return unless $blist;
1650 warn "$target: use base qw/$blist/;" if $self->debug;
1651 $self->_raw_stmt($target, "use base qw/$blist/;");
1658 my $rlist = join(q{, }, map { qq{'$_'} } @_);
1660 return unless $rlist;
1662 warn "$target: with $rlist;" if $self->debug;
1663 $self->_raw_stmt($target, "\nwith $rlist;");
1666 sub _result_namespace {
1667 my ($self, $schema_class, $ns) = @_;
1668 my @result_namespace;
1670 $ns = $ns->[0] if ref $ns;
1672 if ($ns =~ /^\+(.*)/) {
1673 # Fully qualified namespace
1674 @result_namespace = ($1)
1677 # Relative namespace
1678 @result_namespace = ($schema_class, $ns);
1681 return wantarray ? @result_namespace : join '::', @result_namespace;
1684 # Create class with applicable bases, setup monikers, etc
1685 sub _make_src_class {
1686 my ($self, $table) = @_;
1688 my $schema = $self->schema;
1689 my $schema_class = $self->schema_class;
1691 my $table_moniker = $self->_table2moniker($table);
1692 my @result_namespace = ($schema_class);
1693 if ($self->use_namespaces) {
1694 my $result_namespace = $self->result_namespace || 'Result';
1695 @result_namespace = $self->_result_namespace(
1700 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1702 if ((my $upgrading_v = $self->_upgrading_from)
1703 || $self->_rewriting) {
1704 local $self->naming->{monikers} = $upgrading_v
1707 my @result_namespace = @result_namespace;
1708 if ($self->_upgrading_from_load_classes) {
1709 @result_namespace = ($schema_class);
1711 elsif (my $ns = $self->_downgrading_to_load_classes) {
1712 @result_namespace = $self->_result_namespace(
1717 elsif ($ns = $self->_rewriting_result_namespace) {
1718 @result_namespace = $self->_result_namespace(
1724 my $old_class = join(q{::}, @result_namespace,
1725 $self->_table2moniker($table));
1727 $self->_upgrading_classes->{$table_class} = $old_class
1728 unless $table_class eq $old_class;
1731 $self->classes->{$table} = $table_class;
1732 $self->monikers->{$table} = $table_moniker;
1733 $self->tables->{$table_moniker} = $table;
1734 $self->class_to_table->{$table_class} = $table;
1736 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
1738 $self->_use ($table_class, @{$self->additional_classes});
1740 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
1742 $self->_inject($table_class, @{$self->left_base_classes});
1744 my @components = @{ $self->components || [] };
1746 push @components, @{ $self->result_components_map->{$table_moniker} }
1747 if exists $self->result_components_map->{$table_moniker};
1749 my @fq_components = @components;
1750 foreach my $component (@fq_components) {
1751 if ($component !~ s/^\+//) {
1752 $component = "DBIx::Class::$component";
1756 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
1758 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
1760 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
1762 $self->_inject($table_class, @{$self->additional_base_classes});
1765 sub _is_result_class_method {
1766 my ($self, $name, $table_name) = @_;
1768 my $table_moniker = $table_name ? $self->monikers->{$table_name} : '';
1770 $self->_result_class_methods({})
1771 if not defined $self->_result_class_methods;
1773 if (not exists $self->_result_class_methods->{$table_moniker}) {
1774 my (@methods, %methods);
1775 my $base = $self->result_base_class || 'DBIx::Class::Core';
1777 my @components = @{ $self->components || [] };
1779 push @components, @{ $self->result_components_map->{$table_moniker} }
1780 if exists $self->result_components_map->{$table_moniker};
1782 for my $c (@components) {
1783 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
1786 my @roles = @{ $self->result_roles || [] };
1788 push @roles, @{ $self->result_roles_map->{$table_moniker} }
1789 if exists $self->result_roles_map->{$table_moniker};
1791 for my $class ($base, @components,
1792 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
1793 $self->ensure_class_loaded($class);
1795 push @methods, @{ Class::Inspector->methods($class) || [] };
1798 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1800 @methods{@methods} = ();
1802 $self->_result_class_methods->{$table_moniker} = \%methods;
1804 my $result_methods = $self->_result_class_methods->{$table_moniker};
1806 return exists $result_methods->{$name};
1809 sub _resolve_col_accessor_collisions {
1810 my ($self, $table, $col_info) = @_;
1812 my $table_name = ref $table ? $$table : $table;
1814 while (my ($col, $info) = each %$col_info) {
1815 my $accessor = $info->{accessor} || $col;
1817 next if $accessor eq 'id'; # special case (very common column)
1819 if ($self->_is_result_class_method($accessor, $table_name)) {
1822 if (my $map = $self->col_collision_map) {
1823 for my $re (keys %$map) {
1824 if (my @matches = $col =~ /$re/) {
1825 $info->{accessor} = sprintf $map->{$re}, @matches;
1833 Column '$col' in table '$table_name' collides with an inherited method.
1834 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1836 $info->{accessor} = undef;
1842 # use the same logic to run moniker_map, col_accessor_map, and
1843 # relationship_name_map
1845 my ( $self, $map, $default_code, $ident, @extra ) = @_;
1847 my $default_ident = $default_code->( $ident, @extra );
1849 if( $map && ref $map eq 'HASH' ) {
1850 $new_ident = $map->{ $ident };
1852 elsif( $map && ref $map eq 'CODE' ) {
1853 $new_ident = $map->( $ident, $default_ident, @extra );
1856 $new_ident ||= $default_ident;
1861 sub _default_column_accessor_name {
1862 my ( $self, $column_name ) = @_;
1864 my $accessor_name = $column_name;
1865 $accessor_name =~ s/\W+/_/g;
1867 if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
1868 # older naming just lc'd the col accessor and that's all.
1869 return lc $accessor_name;
1871 elsif (($self->naming->{column_accessors}||'') eq 'preserve') {
1872 return $accessor_name;
1875 return join '_', map lc, split_name $column_name;
1878 sub _make_column_accessor_name {
1879 my ($self, $column_name, $column_context_info ) = @_;
1881 my $accessor = $self->_run_user_map(
1882 $self->col_accessor_map,
1883 sub { $self->_default_column_accessor_name( shift ) },
1885 $column_context_info,
1892 my ($self, $identifier) = @_;
1894 my $qt = $self->schema->storage->sql_maker->quote_char || '';
1897 return $qt->[0] . $identifier . $qt->[1];
1900 return "${qt}${identifier}${qt}";
1903 # Set up metadata (cols, pks, etc)
1904 sub _setup_src_meta {
1905 my ($self, $table) = @_;
1907 my $schema = $self->schema;
1908 my $schema_class = $self->schema_class;
1910 my $table_class = $self->classes->{$table};
1911 my $table_moniker = $self->monikers->{$table};
1913 my $table_name = $table;
1915 my $sql_maker = $self->schema->storage->sql_maker;
1916 my $name_sep = $sql_maker->name_sep;
1918 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1919 $table_name = \ $self->_quote($table_name);
1922 my $full_table_name = ($self->qualify_objects ?
1923 ($self->_quote($self->db_schema) . '.') : '')
1924 . (ref $table_name ? $$table_name : $table_name);
1926 # be careful to not create refs Data::Dump can "optimize"
1927 $full_table_name = \do {"".$full_table_name} if ref $table_name;
1929 $self->_dbic_stmt($table_class, 'table', $full_table_name);
1931 my $cols = $self->_table_columns($table);
1932 my $col_info = $self->__columns_info_for($table);
1934 ### generate all the column accessor names
1935 while (my ($col, $info) = each %$col_info) {
1936 # hashref of other info that could be used by
1937 # user-defined accessor map functions
1939 table_class => $table_class,
1940 table_moniker => $table_moniker,
1941 table_name => $table_name,
1942 full_table_name => $full_table_name,
1943 schema_class => $schema_class,
1944 column_info => $info,
1947 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
1950 $self->_resolve_col_accessor_collisions($table, $col_info);
1952 # prune any redundant accessor names
1953 while (my ($col, $info) = each %$col_info) {
1954 no warnings 'uninitialized';
1955 delete $info->{accessor} if $info->{accessor} eq $col;
1958 my $fks = $self->_table_fk_info($table);
1960 foreach my $fkdef (@$fks) {
1961 for my $col (@{ $fkdef->{local_columns} }) {
1962 $col_info->{$col}{is_foreign_key} = 1;
1966 my $pks = $self->_table_pk_info($table) || [];
1968 my %uniq_tag; # used to eliminate duplicate uniqs
1970 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1972 my $uniqs = $self->_table_uniq_info($table) || [];
1975 foreach my $uniq (@$uniqs) {
1976 my ($name, $cols) = @$uniq;
1977 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1978 push @uniqs, [$name, $cols];
1981 my @non_nullable_uniqs = grep {
1982 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
1985 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
1986 my @by_colnum = sort { $b->[0] <=> $a->[0] }
1987 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
1989 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
1990 my @keys = map $_->[1], @by_colnum;
1994 # remove the uniq from list
1995 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2001 foreach my $pkcol (@$pks) {
2002 $col_info->{$pkcol}{is_nullable} = 0;
2008 map { $_, ($col_info->{$_}||{}) } @$cols
2011 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2014 foreach my $uniq (@uniqs) {
2015 my ($name, $cols) = @$uniq;
2016 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2020 sub __columns_info_for {
2021 my ($self, $table) = @_;
2023 my $result = $self->_columns_info_for($table);
2025 while (my ($col, $info) = each %$result) {
2026 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
2027 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2029 $result->{$col} = $info;
2037 Returns a sorted list of loaded tables, using the original database table
2045 return keys %{$self->_tables};
2048 # Make a moniker from a table
2049 sub _default_table2moniker {
2050 no warnings 'uninitialized';
2051 my ($self, $table) = @_;
2053 if ($self->naming->{monikers} eq 'v4') {
2054 return join '', map ucfirst, split /[\W_]+/, lc $table;
2056 elsif ($self->naming->{monikers} eq 'v5') {
2057 return join '', map ucfirst, split /[\W_]+/,
2058 Lingua::EN::Inflect::Number::to_S(lc $table);
2060 elsif ($self->naming->{monikers} eq 'v6') {
2061 (my $as_phrase = lc $table) =~ s/_+/ /g;
2062 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2064 return join '', map ucfirst, split /\W+/, $inflected;
2067 my @words = map lc, split_name $table;
2068 my $as_phrase = join ' ', @words;
2070 my $inflected = $self->naming->{monikers} eq 'plural' ?
2071 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2073 $self->naming->{monikers} eq 'preserve' ?
2076 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2078 return join '', map ucfirst, split /\W+/, $inflected;
2081 sub _table2moniker {
2082 my ( $self, $table ) = @_;
2084 $self->_run_user_map(
2086 sub { $self->_default_table2moniker( shift ) },
2091 sub _load_relationships {
2092 my ($self, $tables) = @_;
2096 foreach my $table (@$tables) {
2097 my $tbl_fk_info = $self->_table_fk_info($table);
2098 foreach my $fkdef (@$tbl_fk_info) {
2099 $fkdef->{remote_source} =
2100 $self->monikers->{delete $fkdef->{remote_table}};
2102 my $tbl_uniq_info = $self->_table_uniq_info($table);
2104 my $local_moniker = $self->monikers->{$table};
2106 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2109 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2111 foreach my $src_class (sort keys %$rel_stmts) {
2112 my $src_stmts = $rel_stmts->{$src_class};
2113 foreach my $stmt (@$src_stmts) {
2114 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
2120 my ($self, $table) = @_;
2122 my $table_moniker = $self->monikers->{$table};
2123 my $table_class = $self->classes->{$table};
2125 my @roles = @{ $self->result_roles || [] };
2126 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2127 if exists $self->result_roles_map->{$table_moniker};
2130 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2132 $self->_with($table_class, @roles);
2136 # Overload these in driver class:
2138 # Returns an arrayref of column names
2139 sub _table_columns { croak "ABSTRACT METHOD" }
2141 # Returns arrayref of pk col names
2142 sub _table_pk_info { croak "ABSTRACT METHOD" }
2144 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2145 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2147 # Returns an arrayref of foreign key constraints, each
2148 # being a hashref with 3 keys:
2149 # local_columns (arrayref), remote_columns (arrayref), remote_table
2150 sub _table_fk_info { croak "ABSTRACT METHOD" }
2152 # Returns an array of lower case table names
2153 sub _tables_list { croak "ABSTRACT METHOD" }
2155 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2161 # generate the pod for this statement, storing it with $self->_pod
2162 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2164 my $args = dump(@_);
2165 $args = '(' . $args . ')' if @_ < 2;
2166 my $stmt = $method . $args . q{;};
2168 warn qq|$class\->$stmt\n| if $self->debug;
2169 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2173 sub _make_pod_heading {
2174 my ($self, $class) = @_;
2176 return '' if not $self->generate_pod;
2178 my $table = $self->class_to_table->{$class};
2181 my $pcm = $self->pod_comment_mode;
2182 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2183 $comment = $self->__table_comment($table);
2184 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2185 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2186 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2188 $pod .= "=head1 NAME\n\n";
2190 my $table_descr = $class;
2191 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2193 $pod .= "$table_descr\n\n";
2195 if ($comment and $comment_in_desc) {
2196 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2203 # generates the accompanying pod for a DBIC class method statement,
2204 # storing it with $self->_pod
2210 if ($method eq 'table') {
2212 $self->_pod($class, "=head1 TABLE: C<$table>");
2213 $self->_pod_cut($class);
2215 elsif ( $method eq 'add_columns' ) {
2216 $self->_pod( $class, "=head1 ACCESSORS" );
2217 my $col_counter = 0;
2219 while( my ($name,$attrs) = splice @cols,0,2 ) {
2221 $self->_pod( $class, '=head2 ' . $name );
2222 $self->_pod( $class,
2224 my $s = $attrs->{$_};
2225 $s = !defined $s ? 'undef' :
2226 length($s) == 0 ? '(empty string)' :
2227 ref($s) eq 'SCALAR' ? $$s :
2228 ref($s) ? dumper_squashed $s :
2229 looks_like_number($s) ? $s : qq{'$s'};
2232 } sort keys %$attrs,
2234 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2235 $self->_pod( $class, $comment );
2238 $self->_pod_cut( $class );
2239 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2240 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2241 my ( $accessor, $rel_class ) = @_;
2242 $self->_pod( $class, "=head2 $accessor" );
2243 $self->_pod( $class, 'Type: ' . $method );
2244 $self->_pod( $class, "Related object: L<$rel_class>" );
2245 $self->_pod_cut( $class );
2246 $self->{_relations_started} { $class } = 1;
2248 elsif ($method eq 'add_unique_constraint') {
2249 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2250 unless $self->{_uniqs_started}{$class};
2252 my ($name, $cols) = @_;
2254 $self->_pod($class, "=head2 C<$name>");
2255 $self->_pod($class, '=over 4');
2257 foreach my $col (@$cols) {
2258 $self->_pod($class, "=item \* L</$col>");
2261 $self->_pod($class, '=back');
2262 $self->_pod_cut($class);
2264 $self->{_uniqs_started}{$class} = 1;
2266 elsif ($method eq 'set_primary_key') {
2267 $self->_pod($class, "=head1 PRIMARY KEY");
2268 $self->_pod($class, '=over 4');
2270 foreach my $col (@_) {
2271 $self->_pod($class, "=item \* L</$col>");
2274 $self->_pod($class, '=back');
2275 $self->_pod_cut($class);
2279 sub _pod_class_list {
2280 my ($self, $class, $title, @classes) = @_;
2282 return unless @classes && $self->generate_pod;
2284 $self->_pod($class, "=head1 $title");
2285 $self->_pod($class, '=over 4');
2287 foreach my $link (@classes) {
2288 $self->_pod($class, "=item * L<$link>");
2291 $self->_pod($class, '=back');
2292 $self->_pod_cut($class);
2295 sub _base_class_pod {
2296 my ($self, $base_class) = @_;
2298 return unless $self->generate_pod;
2301 =head1 BASE CLASS: L<$base_class>
2308 sub _filter_comment {
2309 my ($self, $txt) = @_;
2311 $txt = '' if not defined $txt;
2313 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2318 sub __table_comment {
2321 if (my $code = $self->can('_table_comment')) {
2322 return $self->_filter_comment($self->$code(@_));
2328 sub __column_comment {
2331 if (my $code = $self->can('_column_comment')) {
2332 return $self->_filter_comment($self->$code(@_));
2338 # Stores a POD documentation
2340 my ($self, $class, $stmt) = @_;
2341 $self->_raw_stmt( $class, "\n" . $stmt );
2345 my ($self, $class ) = @_;
2346 $self->_raw_stmt( $class, "\n=cut\n" );
2349 # Store a raw source line for a class (for dumping purposes)
2351 my ($self, $class, $stmt) = @_;
2352 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2355 # Like above, but separately for the externally loaded stuff
2357 my ($self, $class, $stmt) = @_;
2358 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2361 sub _custom_column_info {
2362 my ( $self, $table_name, $column_name, $column_info ) = @_;
2364 if (my $code = $self->custom_column_info) {
2365 return $code->($table_name, $column_name, $column_info) || {};
2370 sub _datetime_column_info {
2371 my ( $self, $table_name, $column_name, $column_info ) = @_;
2373 my $type = $column_info->{data_type} || '';
2374 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2375 or ($type =~ /date|timestamp/i)) {
2376 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2377 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2383 my ($self, $name) = @_;
2385 return $self->preserve_case ? $name : lc($name);
2389 my ($self, $name) = @_;
2391 return $self->preserve_case ? $name : uc($name);
2394 sub _unregister_source_for_table {
2395 my ($self, $table) = @_;
2399 my $schema = $self->schema;
2400 # in older DBIC it's a private method
2401 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2402 $schema->$unregister($self->_table2moniker($table));
2403 delete $self->monikers->{$table};
2404 delete $self->classes->{$table};
2405 delete $self->_upgrading_classes->{$table};
2406 delete $self->{_tables}{$table};
2410 # remove the dump dir from @INC on destruction
2414 @INC = grep $_ ne $self->dump_directory, @INC;
2419 Returns a hashref of loaded table to moniker mappings. There will
2420 be two entries for each table, the original name and the "normalized"
2421 name, in the case that the two are different (such as databases
2422 that like uppercase table names, or preserve your original mixed-case
2423 definitions, or what-have-you).
2427 Returns a hashref of table to class mappings. In some cases it will
2428 contain multiple entries per table for the original and normalized table
2429 names, as above in L</monikers>.
2431 =head1 COLUMN ACCESSOR COLLISIONS
2433 Occasionally you may have a column name that collides with a perl method, such
2434 as C<can>. In such cases, the default action is to set the C<accessor> of the
2435 column spec to C<undef>.
2437 You can then name the accessor yourself by placing code such as the following
2440 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2442 Another option is to use the L</col_collision_map> option.
2444 =head1 RELATIONSHIP NAME COLLISIONS
2446 In very rare cases, you may get a collision between a generated relationship
2447 name and a method in your Result class, for example if you have a foreign key
2448 called C<belongs_to>.
2450 This is a problem because relationship names are also relationship accessor
2451 methods in L<DBIx::Class>.
2453 The default behavior is to append C<_rel> to the relationship name and print
2454 out a warning that refers to this text.
2456 You can also control the renaming with the L</rel_collision_map> option.
2460 L<DBIx::Class::Schema::Loader>
2464 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2468 This library is free software; you can redistribute it and/or modify it under
2469 the same terms as Perl itself.
2474 # vim:et sts=4 sw=4 tw=0: