Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
PerlMonks  

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

by james2vegas (Chaplain)
on May 30, 2013 at 20:57 UTC ( #1036143=note: print w/ replies, xml ) Need Help??


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

To unapply (which doesn't seem to be supported in Moose nor Moo at the moment), presuming you have access to the original roles applied:

  • find the superclass of the object (this will be the original class of the object without the roles applied)
  • subtract the roles to unapply from the list of roles applied
  • re-bless the object into its original class (in Moo, this is only necessary if the roles list is empty, as you use the class name in the next step)
  • if the roles list isn't empty, create a new role application with the object's original class and new list of roles,
    bless the object into this new class (in Moose, apply roles)


Comment on Re^5: a State machine with Roles - possible? (class or instance)
Re^6: a State machine with Roles - possible? (class or instance)
by mascip (Pilgrim) on May 31, 2013 at 18:28 UTC
    Edit: Nothing, i wrote something wrong
Re^6: a State machine with Roles - possible? (class or instance)
by mascip (Pilgrim) on Jun 01, 2013 at 11:10 UTC

    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.

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://1036143]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others rifling through the Monastery: (10)
As of 2015-07-06 23:05 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (85 votes), past polls