#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };

{   package Element;
    use Moo;

    has name => (is => 'ro');
    has active_container => (is => 'rw');
}


{   package Container;
    use Moo;

    has elements => (is => 'ro', default => sub { [] });

    sub add_elem {
        my ($self, $element) = @_;
        push @{ $self->elements }, $element
            unless grep $_ == $element, @{ $self->elements };
    }

    sub get_elem {
        my ($self, $name) = @_;
        my $elem = (grep $_->name eq $name, @{ $self->elements })[0];
        $elem->active_container($self);
        return $elem
    }
}


my $elem1 = 'Element'->new(name => 'one');
my ($cont1, $cont2) = map 'Container'->new, 1, 2;
$cont1->add_elem($elem1);
$cont2->add_elem($elem1);
$cont1 == $cont1->get_elem('one')->active_container and say 'ok';
$cont2 == $cont2->get_elem('one')->active_container and say 'ok';
[download]

You should probably make some of the slots weak.

Update: Oh, I know see what the problem is. It works for chained methods *exclusively*, i.e. it doesn't work for non-chained methods.

my $e1 = $cont1->get_elem('one');
my $e2 = $cont2->get_elem('one');
$e1->active_container ne $e2->active_container or die;
[download]

For that, you need a wrapper. Maybe it's possible to overload it so it returns the wrapped element's ref when compared numerically, so $e1 == $e2 still holds?

Thanks a lot

> You should probably make some of the slots weak.

of course, but ...

I hope this makes it clearer now:

#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };

{   package Element;
    use Moo;

    has name => (is => 'ro');
    has active_container => (is => 'rw');
}


{   package Container;
    use Moo;

    has elements => (is => 'ro', default => sub { [] });

    sub add_elem {
        my ($self, $element) = @_;
        push @{ $self->elements }, $element
            unless grep $_ == $element, @{ $self->elements };
    }

    sub get_elem {
        my ($self, $name) = @_;
        my $elem = (grep $_->name eq $name, @{ $self->elements })[0];
        $elem->active_container($self);
        return $elem
    }
}


my $elem0 = 'Element'->new(name => 'one');
my ($cont1, $cont2) = map 'Container'->new, 1, 2;
$cont1->add_elem($elem0);
$cont2->add_elem($elem0);

my $elem1 = $cont1->get_elem('one');
say "OK" if $elem1->active_container == $cont1;
my $elem2 = $cont2->get_elem('one');
say "OK" if $elem2->active_container == $cont2;

print "Not OK" if $elem1->active_container != $cont1;
[download]

C:/Strawberry/perl/bin\perl.exe -w d:/tmp/pm/container_elem.pl 
OK
OK
Not OK
Compilation finished at Fri Oct  8 17:48:07
[download]

Cheers Rolf
_{(addicted to the Perl Programming Language :)
Wikisyntax for the Monastery}

Yes, a wrapper with overloaded numeric comparison seems to work:

#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };

{   package Element;
    use Moo;

    has name => (is => 'ro');
}

{   package Element::Wrapped;
    use Moo;

    use overload
        '==' => sub { $_[0]->element == $_[1]->element },
        fallback => 1;

    has element => (is => 'ro',
                    required => 1,
                    handles => [qw[ name ]]);  # <- and any other Elem
+ent methods.
    has active_container => (is => 'rw');
}


{   package Container;
    use Moo;

    has elements => (is => 'ro', default => sub { [] });

    sub add_elem {
        my ($self, $element) = @_;
        push @{ $self->elements }, $element
            unless grep $_ == $element, @{ $self->elements };
    }

    sub get_elem {
        my ($self, $name) = @_;
        my $elem = (grep $_->name eq $name, @{ $self->elements })[0];
        my $wrap = 'Element::Wrapped'->new(element => $elem);
        $wrap->active_container($self);
        return $wrap
    }
}

use Test2::V0;
plan 6;

my $elem1 = 'Element'->new(name => 'one');
my ($cont1, $cont2) = map 'Container'->new, 1, 2;
$cont1->add_elem($elem1);
$cont2->add_elem($elem1);

is $cont1->get_elem('one')->active_container, $cont1;
is $cont2->get_elem('one')->active_container, $cont2;

my $e1 = $cont1->get_elem('one');
my $e2 = $cont2->get_elem('one');
ok $e1->active_container != $e2->active_container;

ok $e1 == $e2;
is $e1->name, 'one';
is $e1->name, $e2->name;
[download]

map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]

1. Elements need to belong to multiple Containers

2. can't be member_of two different containers

Elements used to be member of ad most one Container

we coded a lot of method chaining

$cont->get_elem('name')->do_something()

Now Elements can belong to multiple Containers.

we need the old code with method chaining to keep working.

Clearer now? :)

update

I should have said that ->do_something() needs to do know $cont.

Cheers Rolf
_{(addicted to the Perl Programming Language :)
Wikisyntax for the Monastery}

# method chaining
$cont1->get_elem('name')->do_something();

# identical to
$elem1 = $cont1->get_elem('name');
$elem1->do_something();
[download]

These are in fact identical, other than the temporary variable $elem1. Nothing about method chaining requires that the element know that it's contained by the container.

Sorry, I forgot to make clear that ->do_something() needs to know the actual Container $cont.

I wanted to keep it short for clarity.

update

It could be solved with a special Method Cascading.

Cheers Rolf
_{(addicted to the Perl Programming Language :)
Wikisyntax for the Monastery}

Ok, but in that case, neither form - with or without the temporary variable - will achieve that. Nothing special gets communicated through method chaining. At least not in POP.

Container      = SharedHouse
Element        = Person
->do_something = ->pay_rent
[download]

this used to work as long as one Person could only live in ONE house at a time.

my $cont = SharedHouse->new('Prag');
my $elem = Person->new('Egon');
$cont->add_elem($elem);

# method chaining
$cont->get_elem('Egon')->pay_rent();
[download]

Now the requirement changed to manage multiple houses in the same program with overlapping sets of inhabitants.

my best guess is that get_elem should now return an object of a new class Inhabitant pointing to one SharedHouse and one Person

• handles methods involving the Container directly
• delegates other methods to an object Person

$elem1 = $cont1->get_elem('Egon');
$elem2 = $cont2->get_elem('Egon');
[download]

but both are internally pointing to the same Person 'Egon'

$elem1->{person} == $elem2->{person}

such that

$elem1->pay_rent() pays the rent for the SharedHouse object in $cont1

but

$elem1->comb_hair() delegates to $elem1->{person}->comb_hair()

I hope it's clearer now. :)

(the real model is even more complicated, since the container is actually a matrix of two types of elements and values in the cell. Think of objects of type Room like $kitchen, and $Egon->owns("Kitchen", "Table"); )

In 25 years of programming I have never actually run into a case where an element needed to know its container and also belong to multiple containers. *shrug*

In most cases I’ve had where the element knew about its container, it was created and owned by the container, so there was no way to create it independent from the container, and the container was free to choose whether the element would be persistent using weak references, or temporary and only held by the strong reference given to the caller when they retrieve the object.

If you have a sub X that needs to know about 2 objects, A and B, and A seems like a logical “container” and B seems like a thing that ought to be contained, then I would make A’s “get_B” return a temporary object C which holds strong references to A and B and has X as one of its methods.

package A;
use Moo;
has ‘b_set’, is => ‘rw’;
sub get_b($self, $name) {
  return C->new(a => $self, b => $self->b_set->{$name});
}

package B;
use Moo;
sub do_thing_with_a($self, $a) {
  …
}

package C;
use Moo;
has ‘a’, is => ‘ro’;
has ‘b’, is => ‘ro’, handles => [qw( … )]; # all of b’s methods
sub do_thing($self) {
  $self->b->do_thing_with_a($self->a);
}
[download]

> In 25 years of programming

Well I just dug up a book on OO modeling I bought about the same time ago, and it explicitly lists several object "associations" like this.

If interested check on "aggregation", "composition", etc

Cheers Rolf
_{(addicted to the Perl Programming Language :)
Wikisyntax for the Monastery}

as I said, there is legacy code which is using Method Chaining (I didn't design it)

$house->get_member("Willy)->clean_house();

Now the model changed and Person "Willy" can be member of different households

> I have never actually run into a case where an element needed to know its container

I have no idea how method chaining would be implemented else, since ->clean_house() is referring to $house

In the new model case ->get_member() can't return a Person object anymore

One possibility discussed here is to return a Wrapper-Object Inhabitant ° which wraps the relation

'Person ->belongs_ to-> House'

and delegates accordingly.

Cheers Rolf
_{(addicted to the Perl Programming Language :)
Wikisyntax for the Monastery}

°) update s/Member/Inhabitant/ for consistency to previous posts

UPDATE

regarding your suggestion, see Re^3: OO Pattern Container x Elements and Method Chaining

«…the real model is even more complicated…»

Sure, yes as always in real life. But how does it really look? The «real model» I mean. It is just because I think sometimes oversimplification isn’t such a good idea. Regards, Karl

«The Crux of the Biscuit is the Apostrophe»

Too complicated!

(The Container holds Hierarchies and so called Attributes. A Hierarchy is a multi-tree of Elements. Elements and Attributes form a matrix (table) of Values.)

> oversimplification isn’t such a good idea.

SSCCE are

But the problem I described is generic and isn't inherent to above model.

Method Chaining with member objects becomes troublesome if the model evolves and member objects start to belong to multiple containers.

Cheers Rolf
_{(addicted to the Perl Programming Language :)
Wikisyntax for the Monastery}