lib/DBIx/Class/Relationship/ManyToMany.pm

   1 package # hide from PAUSE
   2     DBIx::Class::Relationship::ManyToMany;
   3
   4 use strict;
   5 use warnings;
   6
   7 use DBIx::Class::Carp;
   8 use DBIx::Class::_Util qw( quote_sub perlstring );
   9
  10 # FIXME - this should go away
  11 # instead Carp::Skip should export usable keywords or something like that
  12 my $unique_carper;
  13 BEGIN { $unique_carper = \&carp_unique }
  14
  15 use namespace::clean;
  16
  17 our %_pod_inherit_config =
  18   (
  19    class_map => { 'DBIx::Class::Relationship::ManyToMany' => 'DBIx::Class::Relationship' }
  20   );
  21
  22 sub many_to_many {
  23   my ($class, $meth, $rel, $f_rel, $rel_attrs) = @_;
  24
  25   $class->throw_exception(
  26     "missing relation in many-to-many"
  27   ) unless $rel;
  28
  29   $class->throw_exception(
  30     "missing foreign relation in many-to-many"
  31   ) unless $f_rel;
  32
  33     my $add_meth = "add_to_${meth}";
  34     my $remove_meth = "remove_from_${meth}";
  35     my $set_meth = "set_${meth}";
  36     my $rs_meth = "${meth}_rs";
  37
  38     for ($add_meth, $remove_meth, $set_meth, $rs_meth) {
  39       if ( $class->can ($_) ) {
  40         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     my @main_meth_qsub_args = (
  61       {},
  62       { attributes => [
  63         'DBIC_method_is_indirect_sugar',
  64         ( keys( %{$rel_attrs||{}} )
  65           ? 'DBIC_method_is_m2m_sugar_with_attrs'
  66           : 'DBIC_method_is_m2m_sugar'
  67         ),
  68       ] },
  69     );
  70
  71
  72     quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth ), @main_meth_qsub_args;
  73
  74       DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
  75       DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray;
  76
  77       my $rs = shift->%s( @_ );
  78
  79       wantarray ? $rs->all : $rs;
  80 EOC
  81
  82
  83     my @extra_meth_qsub_args = (
  84       {
  85         '$rel_attrs' => \{ alias => $f_rel, %{ $rel_attrs||{} } },
  86         '$carp_unique' => \$unique_carper,
  87       },
  88       { attributes => [
  89         'DBIC_method_is_indirect_sugar',
  90         ( keys( %{$rel_attrs||{}} )
  91           ? 'DBIC_method_is_m2m_extra_sugar_with_attrs'
  92           : 'DBIC_method_is_m2m_extra_sugar'
  93         ),
  94       ] },
  95     );
  96
  97
  98     quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', map { perlstring $_ } ( "${class}::${meth}", $rel, $f_rel ) ), @extra_meth_qsub_args;
  99
 100       DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
 101         and
 102       # allow nested calls from our ->many_to_many, see comment below
 103       ( (CORE::caller(1))[3] ne %s )
 104         and
 105       DBIx::Class::_Util::fail_on_internal_call;
 106
 107       # this little horror is there replicating a deprecation from
 108       # within search_rs() itself
 109       shift->related_resultset( %s )
 110             ->related_resultset( %s )
 111              ->search_rs (
 112                undef,
 113                ( @_ > 1 and ref $_[-1] eq 'HASH' )
 114                  ? { %%$rel_attrs, %%{ pop @_ } }
 115                  : $rel_attrs
 116              )->search_rs(@_)
 117       ;
 118 EOC
 119
 120     # the above is the only indirect method, the 3 below have too much logic
 121     shift @{$extra_meth_qsub_args[1]{attributes}};
 122
 123
 124     quote_sub "${class}::${add_meth}", sprintf( <<'EOC', $add_meth, $rel, $f_rel ), @extra_meth_qsub_args;
 125
 126       ( @_ >= 2 and @_ <= 3 ) or $_[0]->throw_exception(
 127         "'%1$s' expects an object or hashref to link to, and an optional hashref of link data"
 128       );
 129
 130       $_[0]->throw_exception(
 131         "The optional link data supplied to '%1$s' is not a hashref (it was previously ignored)"
 132       ) if $_[2] and ref $_[2] ne 'HASH';
 133
 134       my( $self, $far_obj ) = @_;
 135
 136       my $guard;
 137
 138       # the API is always expected to return the far object, possibly
 139       # creating it in the process
 140       if( not defined Scalar::Util::blessed( $far_obj ) ) {
 141
 142         $guard = $self->result_source->schema->storage->txn_scope_guard;
 143
 144         # reify the hash into an actual object
 145         $far_obj = $self->result_source
 146                          ->related_source( q{%2$s} )
 147                           ->related_source( q{%3$s} )
 148                            ->resultset
 149                             ->search_rs( undef, $rel_attrs )
 150                              ->find_or_create( $far_obj );
 151       }
 152
 153       my $link = $self->new_related(
 154         q{%2$s},
 155         $_[2] || {},
 156       );
 157
 158       $link->set_from_related( q{%3$s}, $far_obj );
 159
 160       $link->insert();
 161
 162       $guard->commit if $guard;
 163
 164       $far_obj;
 165 EOC
 166
 167
 168     quote_sub "${class}::${set_meth}", sprintf( <<'EOC', $set_meth, $add_meth, $rel, $f_rel ), @extra_meth_qsub_args;
 169
 170       my $self = shift;
 171
 172       my $set_to = ( ref $_[0] eq 'ARRAY' )
 173         ? ( shift @_ )
 174         : do {
 175           $carp_unique->(
 176             "Calling '%1$s' with a list of items to link to is deprecated, use an arrayref instead"
 177           );
 178
 179           # gobble up everything from @_ into a new arrayref
 180           [ splice @_ ]
 181         }
 182       ;
 183
 184       # make sure folks are not invoking a bizarre mix of deprecated and curent syntax
 185       $self->throw_exception(
 186         "'%1$s' expects an arrayref of objects or hashrefs to link to, and an optional hashref of link data"
 187       ) if (
 188         @_ > 1
 189           or
 190         ( defined $_[0] and ref $_[0] ne 'HASH' )
 191       );
 192
 193       my $guard;
 194
 195       # there will only be a single delete() op, unless we have what to set to
 196       $guard = $self->result_source->schema->storage->txn_scope_guard
 197         if @$set_to;
 198
 199       # if there is a where clause in the attributes, ensure we only delete
 200       # rows that are within the where restriction
 201       $self->related_resultset( q{%3$s} )
 202             ->search_rs(
 203               ( $rel_attrs->{where}
 204                 ? ( $rel_attrs->{where}, { join => q{%4$s} } )
 205                 : ()
 206               )
 207             )->delete;
 208
 209       # add in the set rel objects
 210       $self->%2$s(
 211         $_,
 212         @_, # at this point @_ is either empty or contains a lone link-data hash
 213       ) for @$set_to;
 214
 215       $guard->commit if $guard;
 216 EOC
 217
 218
 219     # the last method needs no captures - just kill it all with fire
 220     $extra_meth_qsub_args[0] = {};
 221
 222
 223     quote_sub "${class}::${remove_meth}", sprintf( <<'EOC', $remove_meth, $rel, $f_rel ), @extra_meth_qsub_args;
 224
 225       $_[0]->throw_exception("'%1$s' expects an object")
 226         unless defined Scalar::Util::blessed( $_[1] );
 227
 228       $_[0]->related_resultset( q{%2$s} )
 229             ->search_rs( $_[1]->ident_condition( q{%3$s} ), { join => q{%3$s} } )
 230              ->delete;
 231 EOC
 232
 233 }
 234
 235 1;