Like i said to Salva above, in most cases one can (and probably should) achieve most things with Role attributes. But still, i wanted to un-apply a Role, to see if it's possible.
And with your help james2vegas, I managed to do it, thank you!
Well, it's very dirty and i wouldn't use this code in a real project. I cheated because my object's class name is not 'Door' anymore: it's an anonymous class. And I don't know how to retrieve all the class names (if there were several). So, i passed the class name as an attribute to the unapply_role() function.
Well, i'm pretty sure that re-blessing a Moose object is a bad idea anyway... but it's nice to play with things and at least get a simple example working :-)
Here is the result:
package MASCIP::Utils::Roles;
use version; our $VERSION = qv('0.0.1');
use Perl6::Export::Attrs;
use Moose::Util qw( ensure_all_roles );
## List of Role names that an object (instance) composes
sub role_names_of :Export(:DEFAULT) {
return [ split('\|', $_[0]->meta->roles->[0]->name) ];
}
## Switches one Role for another
# @params: old Role name to un-apply, new Role name to apply
sub switch_role :Export(:DEFAULT) {
my ($object, $class_of_object, $old, $new) = @_;
# Un-apply old Role
unapply_role($object, $class_of_object, $old);
# Apply new Role
my @new_roles = @{ role_names_of($object) };
push @new_roles, $new;
_rebless_and_apply_new_roles($object, $class_of_object, @new_roles
+);
}
## Un-apply a Role from an object (instance)
sub unapply_role :Export(:DEFAULT) {
my ($object, $class_of_object, $role_name) = @_;
# the class is used to rebless
my @new_roles = grep { $_ ne $role_name }
@{ role_names_of($object) };
_rebless_and_apply_new_roles($object, $class_of_object, @new_roles
+);
}
## Gets rid of all old Roles, and apply a list of new ones
sub _rebless_and_apply_new_roles {
my ($object, $class_of_object, @new_roles) = @_;
bless $object, $class_of_object; # THIS IS BAD !!!
# But it works for this simple e
+xample
ensure_all_roles($object, @new_roles);
}
1;
It works/ To improve it one would need to retrieve the object class(es) from it's meta-object.
Here are my improved Doors:
Door.pm
use MooseX::Declare;
## Door behaviour:
# - you cannot lock an Open door
# - you cannot open a Locked door
class Door {
use MyApp::Bundle;
has name => ( is => 'ro', isa => 'Str', required => 1 );
# Default State at construction: Closed and Unlocked
method BUILD (@_) { apply_all_roles($self, 'Closed', 'Unlocked') }
# THESE WON'T WORK right now, because the Role must be un-applied!
+
method is_opened { $->DOES('Opened') }
method is_closed { $->DOES('Closed') }
method is_locked { $->DOES('Locked') }
method is_unlocked { $->DOES('Unlocked') }
method current_roles_names {
return [ split('\|', $->meta->roles->[0]->name) ];
}
method current_state {
my $openness = $->is_opened ? 'OPENED' : 'CLOSED';
my $lockness = $->is_locked ? 'LOCKED' : 'UNLOCKED';
warn 'DEFECT: a Door should never be opened and locked !!!'
if $->is_opened && $->is_locked;
return [ $openness, $lockness ];
}
method to_str {
return $->name . ': ' . join(', ', @{$->current_state})
}
} # END CLASS Door
role Opened {
use MyApp::Bundle;
method knock { say "don't knock: it's opened" }
method open { carp 'already opened' }
method close { switch_role($self, 'Door', 'Opened', 'Closed') }
} # END ROLE Opened
role Closed {
use MyApp::Bundle;
method close { carp 'already closed' }
method open {
# Cannot lock an open door
if ($->is_locked) {
say 'you cannot open a locked door';
return;
}
switch_role($self, 'Door', 'Closed', 'Opened');
}
} # END ROLE Opened
role Locked {
use MyApp::Bundle;
method lock { carp 'already locked' }
method unlock {
switch_role($self, 'Door', 'Locked', 'Unlocked')
}
} # END ROLE Locked
role Unlocked {
use MyApp::Bundle;
method lock {
if ($->is_opened) {
carp 'you cannot lock an open door';
return;
}
switch_role($self, 'Door', 'Unlocked', 'Locked')
}
method unlock { carp 'already unlocked' }
} # END ROLE Unlocked
As well as the module bundle that i use everywhere:
MyApp::Bundle
### Modules used in all other classes
package MyApp::Bundle;
use Syntax::Collector -collect => q/
use MASCIP::Utils::Roles 0.0.1;
use Method::Signatures::Modifiers 20130505;
use strictures 1.004004;
use feature 1.27 qw( :5.16 );
use Carp 1.26 qw( carp );
use Moose::Util 2.0802 qw( apply_all_roles );
use invoker 0.34;
/;
1;
And
the test:
use Door;
use MyApp::Bundle;
my $front = Door->new(name => 'Front');
my $back = Door->new(name => 'Back');
sub say_doors_state {
say ' ' . $front->to_str . ' | ' . $back->to_str;
say '';
}
say 'START in the house...';
say '...the doors are Closed and Unlocked (default)';
say_doors_state;
# Front: CLOSED, UNLOCKED | Back: CLOSED, UNLOCKED
say 'Lock the Front door';
$front->lock; say_doors_state;
# Front: CLOSED, LOCKED | Back: CLOSED, UNLOCKED
say 'Try to open the Front door (impossible)';
$front->open; say_doors_state;
# you cannot open a locked door
# Front: CLOSED, LOCKED | Back: CLOSED, UNLOCKED
say 'Open the Back door';
$back->open; say_doors_state;
# Front: CLOSED, LOCKED | Back: OPENED, UNLOCKED
say 'Try to lock the Back door (impossible)';
$back->lock; say_doors_state;
# you cannot lock an open door at test.pl line 26.
# Front: CLOSED, LOCKED | Back: OPENED, UNLOCKED
say 'Close the Back door';
$back->close; say_doors_state;
# Front: CLOSED, LOCKED | Back: CLOSED, UNLOCKED
say 'Lock the Back door';
$back->lock; say_doors_state;
# Front: CLOSED, LOCKED | Back: CLOSED, LOCKED
say "I'm safe!";
That's it. Suggestions welcome.
