Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change

Re^6: a State machine with Roles - possible? (class or instance)

by mascip (Pilgrim)
on Jun 01, 2013 at 11:10 UTC ( #1036416=note: print w/replies, xml ) Need Help??

in reply to Re^5: a State machine with Roles - possible? (class or instance)
in thread a State machine with Roles - possible?

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:

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:
### 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 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.

Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://1036416]
[shmem]: Discipulus: well, a node with just one glaring truth on it is most easily upvoted ;-)
[Discipulus]: i'd like to be the vote fairy just one month.. ;=)
[choroba]: My average XP per node lowered in the last three months :(

How do I use this? | Other CB clients
Other Users?
Others surveying the Monastery: (10)
As of 2017-04-26 11:58 GMT
Find Nodes?
    Voting Booth?
    I'm a fool:

    Results (474 votes). Check out past polls.