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