How to extend Class::Multimethods::Pure to recognise Moose Roles? - perl

I need multemethod dispatch with Moose objects. I'm doing this with Class::Multimethods::Pure. I chose this instead of MooseX::MultiMethods because it depends on MooseX::Method::Signatures which can't install on my system because it fails its tests. I don't mind if you have an alternative approach to suggest.
The following works fine with types and subtypes:
package Foo::Type;
use Moose;
package Foo::SubType;
use Moose;
extends 'Foo::Type';
package main;
use Class::Multimethods::Pure;
multi hello => ('Foo::Type') => sub {
my ( $foo ) = #_;
print $foo;
};
hello( Foo::SubType->new );
But the scenario I now need to handle is where the declared type is actually a Moose Role:
package Foo::Role;
use Moose::Role;
package Foo::Type;
use Moose;
with 'Foo::Role';
package main;
use Class::Multimethods::Pure;
multi hello => ('Foo') => sub {
my ( $foo ) = #_;
print $foo;
};
hello( Foo::Type->new );
But this can't recognise the role:
No method found for args (Foo::Type=HASH(0x22ac854))
The documentation says it can be extended in various ways, including adding Perl 6-ish roles. But it's a little sketchy for me and I'm looking for a more detailed example. Has anyone tried this?

My solution was to convert the roles to abstract base classes using MooseX::ABC. In this way, they could be recognised as a class type.
On a side note, I managed to get MooseX::MultiMethods working on another system. It does work with roles, but it can't figure out which to use if we define a multimethod that takes the class and another multimethod that takes the role. Incidentally, MooseX::ABC resolved this issue also since it gave me a hierarchical structure which the roles did not really have.
package Foo::Role;
use Moose::Role;
package Foo::Type;
use Moose;
with 'Foo::Role';
package Merger;
use Moose;
use MooseX::MultiMethods;
multi method hello (Foo::Role $foo) {
print 'Foo::Role: '.$foo;
}
multi method hello (Foo::Type $foo) {
print 'Foo::Type: '.$foo;
}
package main;
my $merger = Merger->new;
my $f = Foo::Type->new;
$merger->hello( $f );
# Ambiguous match for multi method hello: (Foo::Role $foo), (Foo::Type $foo)
# with value [ Merger{ }, Foo::Type{ } ]

Related

Loading the needed packages on demand in perl

Reworded question - sorry, it is a bit long.
Have a simplyfied package for example
package My;
use Moose;
use namespace::sweep;
sub cmd1 {1}
sub smd2 {2}
__PACKAGE__->meta->make_immutable;
1;
I want allow to others extending the My with another methods, such
package My::Cmd3;
use Moose;
extends 'My';
sub cmd3 {3}
1;
This allows to use the methods from the "base" My and My::Cmd3 with the next:
use My::Cmd3;
my $obj = My::Cmd3->new();
say $obj->cmd1(); #from the base My
say $obj->cmd3(); #from the My::Cmd3;
But this isn't what I want. I don't want use My::Cmd3;, (here will be more extension packages), I want use My;.
Using roles is NICER, like:
package My;
use Moose;
with 'My::Cmd3';
sub cmd1 {1}
sub cmd2 {2}
__PACKAGE__->meta->make_immutable;
1;
package My::Cmd3;
use Moose::Role;
use namespace::autoclean;
sub cmd3 {3};
no Moose::Role;
1;
This allows me:
use My;
my $obj = My->new();
say $obj->cmd1();
say $obj->cmd3(); #from the role-package
But when someone make an My::Cmd4 will need change the base My package to add with My::Cmd4. ;(
I'm looking for a way, how to achieve the next:
use My;
#and load all needed packages on demand with the interface like the next
my $obj = My->new( commands => [qw(Cmd3 Cmd4)] );
#what should load the methods from the "base" My and from the wanted extensions too
say $obj->cmd1(); # from the base My package
say $obj->cmd3(); # from the "extension" package My::Cmd3
say $obj->cmd4(); # from the My::Cmd4
So, the what I have now:
package My;
use Moose;
has 'commands' => (
is => 'rw',
isa => 'ArrayRef[Str]|Undef', #??
default => sub { undef },
);
# WHAT HERE?
# need something here, what loads the packages My::Names... based on the supplied "commands"
# probably the BUILD { ... } ???
sub cmd1 {1}
sub smd2 {2}
__PACKAGE__->meta->make_immutable;
1;
Designing an right object hierarchy is my everlasting problem.. ;(
I'm absolutely sure than this isn't should be an big problem, only need some pointers what I should study; and therefore Would be nice to know some CPAN modules, what using such technique ...
So the questions:
What I need to put in place of the above "WHAT HERE?"
The "extension" packages should be roles? (probably it is the best for this, but asking for sure)
Should i move the "base" commands from the My to the e.g. My::Base and load the on-demand as other My::Something or should they remain in the My? And why?
Some other recommendations?
To allow get a list of methods (and loaded packages), in Moose I can use
my $obj = My->new(....);
my #methods = $obj->meta->get_all_methods();
This has only Moose and I couldn't use something smaller as Moo, right?
Ps: Sorry again for the extremelly long question.
Here is a solution that fills in your WHAT HERE? section, with the extensions remaining as roles.
package My;
use Moose;
use Class::Load 'load_class';
has commands => (
is => 'ro',
isa => 'ArrayRef',
default => sub { [ ] },
);
sub BUILD {
my ($self) = #_;
my $namespace = __PACKAGE__;
foreach ( #{ $self->commands } ) {
my $role = "$namespace::$_";
load_class $role; # load the module
$role->meta->apply($self); # apply the role to the object
}
return;
}
...
Notes:
You will need to load your role during runtime. This is akin to require My::Role but the module deals with some issues with loading modules at runtime. Here I have used Class::Load, but a number of alternatives exist including Module::Load.
Then you need to apply the role to your object (see also this Moose Cookbook entry as a reference).
I recommend keeping methods cmd1 and cmd2 in this base class unless you have a reason for separating them out and loading them on demand also.
I use the BUILD method which in Moose is invoked automatically after construction.
I don't allow commands to be undef so I don't need to check for it - If there are no commands, then it can be left as an empty arrayref.
You could also use a module that gives you the infrastructure for applying the roles without you having to write it yourself. Here I have used MooseX::Traits, but again there are a number of alternatives listed here: https://metacpan.org/pod/Task::Moose#Traits-Roles
package My;
use Moose;
with 'MooseX::Traits';
has '+_trait_namespace' => ( default => 'My' );
sub cmd1 {1}
sub cmd2 {2}
__PACKAGE__->meta->make_immutable;
1;
# your roles remain unchanged
Then to use the class:
use My;
my $obj = My->with_traits(qw[ Cmd3 Cmd4 ])->new;
# or my $obj = My->new_with_traits( traits => [qw( Cmd3 Cmd4 )] );
say $obj->cmd1;
say $obj->cmd3;
say $obj->cmd4;
It is still possible to do something like this with Moo if you don't want to use Moose:
use Moo::Role ();
my $class = Moo::Role->create_class_with_roles( 'My2', 'My::Cmd3', 'My::Cmd4' );
my $obj = $class->new;
say $obj->cmd1;
say $obj->cmd3;
say $obj->cmd4;
First: Inheritance
Using Moo or Moose is a super-easy task:
package My::Sub3;
use Moo;
extends 'My';
sub cmd3 {3}
1;
Second: Dynamic object build. Define a build function and load at runtime the proper module. There are several ways to do this, I like the Module::Load CPAN module:
use Module::Load;
sub my_factory_builder {
my $class_name = shift;
load $class_name;
return $class_name->new(#_);
}
And then, in your code:
my #new_params = ();
my $object = my_factory_builder('My::Sub3', #new_params);
As described, "My" itself should be implemented as a role. With few exceptions, classes represent nouns. If the consumers of your class genuinely need to add behavior without subclassing, then your class probably isn't finished yet. For example:
package Animal;
use Moose;
sub eat { ... }
sub excrete { ... }
If the consumers of your code need a "procreate" method, then they should modify the Animal class itself rather than create another module for dynamic loading. If you don't want them modifying Animal, then the right thing for them to do is to subclass it in a new class, say, "FruitfulAnimal".
If your consumers want "eat" and "excrete" behaviors when they happen to be implementing an Animal class, it would be better for them to consume a role that provides those behaviors.
Here is an implementation of My as a Role:
package My;
use Moose::Role;
sub cmd1 { 1 }
sub cmd2 { 2 }
1;
Cmd3
package Cmd3;
use Moose::Role;
with 'My'; # consumes the behaviors of the 'My' Role
sub cmd3 { 3 }
1;
Cmd4
package Cmd4;
use Moose::Role;
with 'My'; # consumes the behaviors of the 'My' Role
sub cmd4 { 4 }
1;
How the role is consumed
package AnyClassThatConsumesMy;
use Moose;
# Instead of My->new( commands => [qw(Cmd3 Cmd4)] );
with 'My', 'Cmd3', 'Cmd4';
1;
test
#!/usr/bin/perl
use Modern::Perl;
use AnyClassThatConsumesMy;
my $my = AnyClassThatConsumesMy->new();
say $my->cmd1();
say $my->cmd2();
say $my->cmd3();
say $my->cmd4();
Output
1
2
3
4
The reason I suggest this approach is that your example is deeply concerned with behaviors rather than modeling something specific. You want to start with a set of behaviors and have others contribute new behaviors. This may seem counter-intuitive because Roles aren't typically emphasized in OO design texts. This is because so many OO languages don't have robust support for Role-like behavior. It doesn't have to be instantiate-able to be usable.
I could tell from the question, you need to use methods heirs
General package
package My;
sub new ($$) {
my $caller = shift;
my $commands = shift;
# blank
my $self = {};
# commands for implements
foreach my $cmd (#{$commands}) {
# implement support extend commands
require "My/".ucfirst($cmd).".pm";
push #ISA, "My::".ucfirst($cmd);
}
return bless $self, $caller;;
}
sub cmd1 {1};
sub cmd2 {2};
1;
My::Cmd3
package My::Cmd3;
sub cmd3 {ref shift};
1;
My::Cmd4
package My::Cmd4;
sub cmd4 {ref shift};
sub isCMd4 {print "it is cmd4"};
1;
test
#!/usr/bin/perl
use strict;
use warnings;
use utf8;
use v5.10;
use My;
my $my = My->new([qw(cmd3 cmd4)]);
say $my->cmd1();
say $my->cmd2();
say $my->cmd3();
say $my->cmd4();
say $my->isCMd4();
1;
Output
1
2
My
My
it is cmd41
Get a list of methods
for(keys %My::) {
say $_ if My->can($_);
}

How to override a sub in a Moose::Role?

I'm trying to implement a Moose::Role class that behaves like an abstract class would in Java. I'd like to implement some methods in the Role, but then have the ability to override those methods in concrete classes. If I try this using the same style that works when I extend classes I get the error Cannot add an override method if a local method is already present. Here's an example:
My abstract class:
package AbstractClass;
use Moose::Role;
sub my_ac_sub {
my $self = shift;
print "In AbstractClass!\n";
return;
}
1;
My concrete class:
package Class;
use Moose;
with 'AbstractClass';
override 'my_ac_sub' => sub {
my $self = shift;
super;
print "In Class!\n";
return;
};
__PACKAGE__->meta->make_immutable;
1;
And then:
use Class;
my $class = Class->new;
$class->my_ac_sub;
Am I doing something wrong? Is what I'm trying to accomplish supposed to be done a different way? Is what I'm trying to do not supposed to be done at all?
Turns out I was using it incorrectly. I opened a ticket and was shown the correct way of doing this:
package Class;
use Moose;
with 'AbstractClass';
around 'my_ac_sub' => sub {
my $next = shift;
my $self = shift;
$self->$next();
print "In Class!\n";
return;
};
__PACKAGE__->meta->make_immutable;
1;
Making this change has the desired effect.
Some time ago, I did this by having a role that consists solely of requires statements. That forms the abstract base class. Then, you can put your default implementations in another class and inherit from that:
#!/usr/bin/env perl
use 5.014;
package AbstractClass;
use Moose::Role;
requires 'my_virtual_method_this';
requires 'my_virtual_method_that';
package DefaultImpl;
use Moose;
with 'AbstractClass';
sub my_virtual_method_this {
say 'this';
}
sub my_virtual_method_that {
say 'that'
}
package MyImpl;
use Moose;
extends 'DefaultImpl';
with 'AbstractClass';
override my_virtual_method_that => sub {
super;
say '... and the other';
};
package main;
my $x = MyImpl->new;
$x->my_virtual_method_this;
$x->my_virtual_method_that;
If you want to provide default implementations for only a few methods define in the role, remove the requires from DefaultImpl.
Output:
$ ./zpx.pl
this
that
... and the other

Composing Roles into a Moose class not working

Aloha!
I have a role that I'm busy defining in a Moose class called Authable that is essentially composed into any class that might potentially require some form of authentication in the future; it's a rather simple role, here's the entirety:
package Trello::API::Roles::Authable;
use Moose::Role;
#authentication information
has key => (
is => "rw",
isa => "Str",
);
has token => (
is => "rw",
isa => "Str",
);
1;
For whatever reason, when I attempt to compose it into a class using multiple different statements, i.e.,
with "Trello::API::Roles::Authable";
or
with "Roles::Authable";
I consistently get this same error message: You can only consume roles, Roles::Authable is not a Moose role.
Any idea why this might be happening?
Edit!
Just a side note, I checked the actual source for Moose::Role, and saw this bit:
unless ($meta && $meta->isa('Moose::Meta::Role') ) {
require Moose;
Moose->throw_error( "You can only consume roles, "
. $role->[0]
. " is not a Moose role" );
}
This seems to be where the error is occuring, so it almost seems that for some reason, the role I'm implementing isn't stating that it's a role in the metaclass. Though I could be mistaken! Any help would be appreciated.
Another convenient EDIT!
Bonus: Code context wherein the with routine is called.
package Trello::API::Resource;
use Moose;
use URI::Escape;
use LWP::UserAgent;
with 'Roles::Authable';
which when I do this, it intelligently knows to try and consume Roles/Authable.pm but for whatever reason, it just fails to function!
First of all, I have to agree with Piers that technically, you really should be calling it as with 'Trello::API::Roles::Authable'.
So, you're asking for something that I don't find to be implemented in basic Moose.
I have used the ideas of generic namespace pools before. They are sort of universal namespaces to which you can offer your
semi-anonymous services--without the lock-in of a fixed namespace. I refined my basic idea of the namespace pool with Moose (really MOP) support.
In the Wild West days of Perl, all you would have to do is assign one stash to the symbol for the other, like so:
{ no strict 'refs';
*{$short_pkg_name.'::'} = \*{$full_pkg_name.'::'};
};
And, those two packages were exactly the same things!
But now, we guard our data with lexicals a bit more. And because Class::MOP jealously guards its meta objects in a lexical hash, you have to add something else:
Class::MOP::store_metaclass_by_name(
$short_pkg_name
, Class::MOP::get_metaclass_by_name( $full_pkg_name )
);
Now they are the exact same thing to Perl and to MOP.
Thus you can create packages that are simply a namespace repository for other packages
-- Now with MOP support!
package Namespace::Pool;
use strict;
use warnings;
use Params::Util qw<_POSINT>;
sub import {
shift; # It's just me.
my $full_pkg_name = caller();
Carp::croak( "'$full_pkg_name' is short enough!" )
unless my $pool_name
= shift // [ split /::/, $full_pkg_name ]->[-2]
;
Carp::croak( "'::$pool_name\::' not found in '$full_pkg_name'" )
unless ( _POSINT( my $pos = rindex( $full_pkg_name, "::$pool_name\::" ))
or my $is_short = _POSINT( index( $pool_name, '::' ))
);
my $short_pkg_name
= $is_short ? $poll_name
: substr( $full_pkg_name, $pos + 2 )
;
{ no strict 'refs';
if ( %{$short_pkg_name.'::'} ) {
Carp::croak( "You have already defined $short_pkg_name!" );
}
*{$short_pkg_name.'::'} = \*{$full_pkg_name.'::'};
};
if ( my $meta = Class::MOP::get_metaclass_by_name( $full_pkg_name )) {
Class::MOP::store_metaclass_by_name( $short_pkg_name, $meta );
}
return;
}
Thus in your Role package you can do the following:
package Trello::API::Roles::Authable;
use strict;
use warnings;
use Moose::Role;
use Namespace::Pool 'Roles';
...
And know that it will be available from the namespace of 'Roles'.
In my case I'd simply accidentally named my role 'Test', but there was already an installed module on my system called 'Test' and so Moose thought I wanted to consume that module rather than the new Moose role I'd created. Once I renamed by role to 'Testable' it all worked fine.

Moose class attribute that acts like Class::Data::Inheritable

I've got a class attribute in a Moose class, but I'd like it to work like Class::Data::Inheritable in terms of a subclass overriding the parent's value. That is, the subclass inherits the parent's value until the setter is called on the subclass, at which point the values become distinct. e.g.
#!/usr/bin/perl
use warnings;
use strict;
{
package Foo;
use Moose;
use MooseX::ClassAttribute;
class_has Item => ( is => 'rw' );
}
{
package Bar;
use Moose;
extends 'Foo';
}
Foo->Item(4);
# This prints "4, 4" as expected
#
print join( ", ", Foo->Item(), Bar->Item() ) . "\n";
Bar->Item(5);
# Would like this to print "4, 5", but it prints "5, 5"
#
print join( ", ", Foo->Item(), Bar->Item() ) . "\n";
What's the best way to get this effect, with MooseX::ClassAttribute or otherwise? Seems like desirable behavior for any class w/class-data that expects to be inherited from.
I know you asked for inheritance but may be roles would help you to get your problem solved in a different way.
Try it with a simple example:
#!/usr/local/bin/perl
use strict;
use feature 'say';
{
package Bomb;
use Moose::Role;
sub fuse { say "Bomb explode" }
sub explode { say "Bomb fuse"}
}
{
package Spouse;
use Moose::Role;
sub fuse { say "Spouse explode"}
sub explode { say "Spouse fuse"}
}
{
package PracticalJoke;
use Moose;
with 'Bomb' => { excludes => 'explode' },
'Spouse' => { excludes => 'fuse' };
}
my $joke = PracticalJoke->new();
$joke->fuse();
$joke->explode();
And with the 'excludes' you can exactly control what should happen.
Have a look at why roles are awsome
and the slides from Ovid about inheritance versus roles.
I had the same problem and found this page when looking for a solution. It's almost a decade after the original post but, as I have now worked out a solution, it might help the next person.
The solution was to add MooseX::ClassAttribute to Bar and a cloned version of class_has Item ... (note the leading + on Item).
{
package Bar;
use Moose;
use MooseX::ClassAttribute;
extends 'Foo';
class_has '+Item' => ();
}
I can now change the subclass Item without it affecting the superclass Item.

Clean implementation of the strategy pattern in Perl

How do I write a clean implementation of the strategy pattern in Perl? I want to do it in a way that leverages Perl's features.
It really depends on what you mean by "clean implementation". As in any other language, you can use Perl's object system with polymorphism to do this for you. However, since Perl has first class functions, this pattern isn't normally coded explicitly. Leon Timmermans' example of
sort { lc($a) cmp lc($b) } #items
demonstrates this quite elegantly.
However, if you're looking for a "formal" implementation as you would do in C++, here's what it may look like using Perl+Moose. This is just a translation of the C++ code from Wikipedia -- Strategy pattern, except I'm using Moose's support for delegation.
package StrategyInterface;
use Moose::Role;
requires 'run';
package Context;
use Moose;
has 'strategy' => (
is => 'rw',
isa => 'StrategyInterface',
handles => [ 'run' ],
);
package SomeStrategy;
use Moose;
with 'StrategyInterface';
sub run { warn "applying SomeStrategy!\n"; }
package AnotherStrategy;
use Moose;
with 'StrategyInterface';
sub run { warn "applying AnotherStrategy!\n"; }
###############
package main;
my $contextOne = Context->new(
strategy => SomeStrategy->new()
);
my $contextTwo = Context->new(
strategy => AnotherStrategy->new()
);
$contextOne->run();
$contextTwo->run();
Use sub references, and closures. A good perlish example of this
sort { lc($a) cmp lc($b) } #items