my $set_meth = "set_${meth}";
my $rs_meth = "${meth}_rs";
+ #record many-to-many metadata
+ $class->register_m2m( $meth, {
+ rel => $rel,
+ frel => $f_rel,
+ ( defined $rel_attrs ? (attrs => $rel_attrs) : ()),
+ });
+
for ($add_meth, $remove_meth, $set_meth, $rs_meth) {
if ( $class->can ($_) ) {
carp (<<"EOW") unless $ENV{DBIC_OVERWRITE_HELPER_METHODS_OK};
__PACKAGE__->mk_group_accessors(simple => qw/
source_name name source_info
_ordered_columns _columns _primaries _unique_constraints
- _relationships resultset_attributes
+ _relationships _many_to_many resultset_attributes
column_info_from_storage
/);
$new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
$new->{_columns} = { %{$new->{_columns}||{}} };
$new->{_relationships} = { %{$new->{_relationships}||{}} };
+ $new->{_many_to_many} = { %{$new->{_many_to_many}||{}} };
$new->{name} ||= "!!NAME NOT SET!!";
$new->{_columns_info_loaded} ||= 0;
return $new;
}
}
+=head2 m2ms
+
+=over 4
+
+=item Arguments: None
+
+=item Return value: List of many_to_many relationship names
+
+=back
+
+ my @m2m_names = $source->m2ms();
+
+Returns all many_to_many names for this source.
+b
+=cut
+
+sub m2ms {
+ my ( $self ) = @_;
+ return keys %{ $self->_many_to_many };
+}
+
+=head2 m2m_info
+
+=over 4
+
+=item Arguments: $m2m_name
+
+=item Return value: Hashref of relation data,
+
+=back
+
+Returns a hashref of information for the specified many_to_many relationship
+name. The keys/values are:
+
+ { rel => $local_relname,
+ frel => $foreign_relname,
+ attrs => { ... },
+ }
+
+=cut
+
+sub m2m_info {
+ my ( $self, $m ) = @_;
+ return $self->_many_to_many->{ $m };
+}
+sub register_m2m {
+ my ( $self, $m, $info ) = @_;
+ $self->_many_to_many->{$m} = $info;
+}
+
+=head2 has_m2m
+
+=over 4
+
+=item Arguments: $m2m_name
+
+=item Return value: 1/0 (true/false)
+
+=back
+
+Returns true if the source has a many_to_many of this name, false otherwise.
+
+=cut
+
+sub has_m2m {
+ my ( $self, $m ) = @_;
+ return exists $self->_many_to_many->{ $m };
+}
+
+
sub pk_depends_on {
carp 'pk_depends_on is a private method, stop calling it';
my $self = shift;
$class->register_relationship($rel => $source->relationship_info($rel));
}
+sub register_m2m {
+ my ($class, $rel, @rest) = @_;
+ my $source = $class->result_source_instance;
+ $source->register_m2m( $rel => @rest );
+}
# legacy resultset_class accessor, seems to be used by cdbi only
sub iterator_class { shift->result_source_instance->resultset_class(@_) }
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+my $cd = $schema->source('CD');
+ok( $cd->has_m2m('producers'), 'CD has a producers m2m' );
+
+is_deeply( [ sort $cd->m2ms ],
+ [ 'producers', 'producers_sorted' ],
+ 'got right list of m2ms' );
+
+is_deeply( $cd->m2m_info('producers'),
+ { rel => 'cd_to_producer',
+ frel => 'producer',
+ },
+ 'm2m_info for CD producers is right',
+ );
+
+done_testing;