File Coverage

blib/lib/DBIx/Class/Relationship/ManyToMany.pm
Criterion Covered Total %
statement 91 92 98.9
branch 30 36 83.3
condition 9 14 64.2
subroutine 29 31 93.5
pod 0 1 0.0
total 159 174 91.3


line stmt bran cond sub pod time code
1             package # hide from PAUSE
2             DBIx::Class::Relationship::ManyToMany;
3              
4 379     379   182323 use strict;
  379         2153  
  379         11409  
5 379     379   2182 use warnings;
  379         1137  
  379         9730  
6              
7 379     379   2129 use DBIx::Class::Carp;
  379         1098  
  379         2490  
8 379     379   2570 use Sub::Name 'subname';
  379         1139  
  379         21900  
9 379     379   2759 use Scalar::Util 'blessed';
  379         1257  
  379         22935  
10 379     379   2943 use DBIx::Class::_Util 'fail_on_internal_wantarray';
  379         1193  
  379         22448  
11 379     379   2841 use namespace::clean;
  379         1257  
  379         2830  
12              
13             our %_pod_inherit_config =
14             (
15             class_map => { 'DBIx::Class::Relationship::ManyToMany' => 'DBIx::Class::Relationship' }
16             );
17              
18             sub many_to_many {
19 4602     4602 0 49523 my ($class, $meth, $rel, $f_rel, $rel_attrs) = @_;
20              
21 4602 50       15006 $class->throw_exception(
22             "missing relation in many-to-many"
23             ) unless $rel;
24              
25 4602 50       11097 $class->throw_exception(
26             "missing foreign relation in many-to-many"
27             ) unless $f_rel;
28              
29             {
30 379     379   130771 no strict 'refs';
  379         1447  
  379         14762  
  4602         8175  
31 379     379   2592 no warnings 'redefine';
  379         1328  
  379         405396  
32              
33 4602         14168 my $add_meth = "add_to_${meth}";
34 4602         11643 my $remove_meth = "remove_from_${meth}";
35 4602         10859 my $set_meth = "set_${meth}";
36 4602         10840 my $rs_meth = "${meth}_rs";
37              
38 4602         11800 for ($add_meth, $remove_meth, $set_meth, $rs_meth) {
39 18408 100       197635 if ( $class->can ($_) ) {
40 2 100       14 carp (<<"EOW") unless $ENV{DBIC_OVERWRITE_HELPER_METHODS_OK};
41              
42             ***************************************************************************
43             The many-to-many relationship '$meth' is trying to create a utility method
44             called $_.
45             This will completely overwrite one such already existing method on class
46             $class.
47              
48             You almost certainly want to rename your method or the many-to-many
49             relationship, as the functionality of the original method will not be
50             accessible anymore.
51              
52             To disable this warning set to a true value the environment variable
53             DBIC_OVERWRITE_HELPER_METHODS_OK
54              
55             ***************************************************************************
56             EOW
57             }
58             }
59              
60 4602   33     30521 $rel_attrs->{alias} ||= $f_rel;
61              
62 4602         13087 my $rs_meth_name = join '::', $class, $rs_meth;
63             *$rs_meth_name = subname $rs_meth_name, sub {
64 40     40   101 my $self = shift;
        119      
        119      
        119      
        119      
        119      
        119      
        119      
        119      
        119      
        119      
        119      
        79      
        51      
        45      
65 40 100 66     226 my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {};
66             my $rs = $self->search_related($rel)->search_related(
67 40 100       316 $f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs }
  40 50       358  
68             );
69 40         208 return $rs;
70 4602         55145 };
71              
72 4602         15448 my $meth_name = join '::', $class, $meth;
73             *$meth_name = subname $meth_name, sub {
74 40     40   1467 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray;
        0      
        0      
75 40         103 my $self = shift;
76 40         478 my $rs = $self->$rs_meth( @_ );
77 40 100       403 return (wantarray ? $rs->all : $rs);
78 4602         48871 };
79              
80 4602         15420 my $add_meth_name = join '::', $class, $add_meth;
81             *$add_meth_name = subname $add_meth_name, sub {
82 28     68   1015 my $self = shift;
83 28 100       106 @_ > 0 or $self->throw_exception(
84             "${add_meth} needs an object or hashref"
85             );
86 27         126 my $source = $self->result_source;
87 27         107 my $schema = $source->schema;
88 27         108 my $rel_source_name = $source->relationship_info($rel)->{source};
89 27         113 my $rel_source = $schema->resultset($rel_source_name)->result_source;
90 27         117 my $f_rel_source_name = $rel_source->relationship_info($f_rel)->{source};
91 27   50     98 my $f_rel_rs = $schema->resultset($f_rel_source_name)->search({}, $rel_attrs||{});
92              
93 27         122 my $obj;
94 27 50       99 if (ref $_[0]) {
95 27 100       96 if (ref $_[0] eq 'HASH') {
96 6         46 $obj = $f_rel_rs->find_or_create($_[0]);
97             } else {
98 21         42 $obj = $_[0];
99             }
100             } else {
101 0         0 $obj = $f_rel_rs->find_or_create({@_});
102             }
103              
104 27 100 100     163 my $link_vals = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {};
105 27         150 my $link = $self->search_related($rel)->new_result($link_vals);
106 27         126 $link->set_from_related($f_rel, $obj);
107 27         155 $link->insert();
108 27         167 return $obj;
109 4602         59890 };
110              
111 4602         15444 my $set_meth_name = join '::', $class, $set_meth;
112             *$set_meth_name = subname $set_meth_name, sub {
113 6     74   28 my $self = shift;
114 6 50       24 @_ > 0 or $self->throw_exception(
115             "{$set_meth} needs a list of objects or hashrefs"
116             );
117 6 100       31 my @to_set = (ref($_[0]) eq 'ARRAY' ? @{ $_[0] } : @_);
  4         16  
118             # if there is a where clause in the attributes, ensure we only delete
119             # rows that are within the where restriction
120 6 100 66     46 if ($rel_attrs && $rel_attrs->{where}) {
121 1         8 $self->search_related( $rel, $rel_attrs->{where},{join => $f_rel})->delete;
122             } else {
123 5         28 $self->search_related( $rel, {} )->delete;
124             }
125             # add in the set rel objects
126 6 100       28 $self->$add_meth($_, ref($_[1]) ? $_[1] : {}) for (@to_set);
127 4602         44308 };
128              
129 4602         15021 my $remove_meth_name = join '::', $class, $remove_meth;
130             *$remove_meth_name = subname $remove_meth_name, sub {
131 5     79   682 my ($self, $obj) = @_;
132 5 100       69 $self->throw_exception("${remove_meth} needs an object")
133             unless blessed ($obj);
134 4         22 my $rel_source = $self->search_related($rel)->result_source;
135 4         19 my $cond = $rel_source->relationship_info($f_rel)->{cond};
136 4         22 my ($link_cond, $crosstable) = $rel_source->_resolve_condition(
137             $cond, $obj, $f_rel, $f_rel
138             );
139              
140 4 50       15 $self->throw_exception(
141             "Relationship '$rel' does not resolve to a join-free condition, "
142             ."unable to use with the ManyToMany helper '$f_rel'"
143             ) if $crosstable;
144              
145 4         22 $self->search_related($rel, $link_cond)->delete;
146 4602         59374 };
147              
148             }
149             }
150              
151             1;