Mojo::Base::with_roles patch

Support extending Mojo::Base classes with roles, using Role::Tiny
(optional dependency)

lib/Mojo/Base.pm

@@ -15,6 +15,10 @@ use IO::Handle ();
 my $NAME
   = eval { require Sub::Util; Sub::Util->can('set_subname') } || sub { $_[1] };
 
+# Role support requires Role::Tiny 2.000001+
+use constant ROLES =>
+  !!(eval { require Role::Tiny; Role::Tiny->VERSION('2.000001'); 1 });
+
 # Protect subclasses using AUTOLOAD
 sub DESTROY { }
 
@@ -61,6 +65,8 @@ sub attr {
   }
 }
 
+sub can_roles {ROLES}
+
 sub import {
   my $class = shift;
   return unless my $flag = shift;
@@ -101,6 +107,11 @@ sub tap {
   return $self;
 }
 
+sub with_roles {
+  return Role::Tiny->create_class_with_roles(@_) if (ROLES);
+  Carp::croak "Role::Tiny 2.000001+ is required for with_roles method";
+}
+
 1;
 
 =encoding utf8
@@ -210,6 +221,13 @@ executed at accessor read time if there's no set value, and gets passed the
 current instance of the object as first argument. Accessors can be chained, that
 means they return their invocant when they are called with an argument.
 
+=head2 can_roles
+
+  my $bool = Mojo::Base->can_roles();
+
+True if L<Role::Tiny> 2.000001+ is installed, indicates that roles are supported in L<Mojo::Base>
+derived classes.
+
 =head2 new
 
   my $object = SubClass->new;
@@ -238,6 +256,15 @@ spliced or tapped into) a chained set of object method calls.
   # Inject side effects into a method chain
   $object->foo('A')->tap(sub { say $_->foo })->foo('B');
 
+=head2 with_roles
+
+  my $new_class = Class->with_roles('Foo::Role1', 'Bar::Role2');
+  my $object = $new_class->new();
+
+Create and return a new class that extends the given class with the
+list of roles composed in order, using L<Role::Tiny>'s method
+C<create_class_with_roles>.
+
 =head1 SEE ALSO
 
 L<Mojolicious>, L<Mojolicious::Guides>, L<http://mojolicious.org>.

lib/Mojolicious/Command/version.pm

@@ -16,6 +16,7 @@ sub run {
     = Mojo::IOLoop::Client->can_socks ? $IO::Socket::Socks::VERSION : 'n/a';
   my $tls = Mojo::IOLoop::TLS->can_tls    ? $IO::Socket::SSL::VERSION  : 'n/a';
   my $nnr = Mojo::IOLoop::Client->can_nnr ? $Net::DNS::Native::VERSION : 'n/a';
+  my $roles = Mojo::Base->can_roles       ? $Role::Tiny::VERSION       : 'n/a';
 
   print <<EOF;
 CORE
@@ -27,6 +28,7 @@ OPTIONAL
   IO::Socket::Socks 0.64+ ($socks)
   IO::Socket::SSL 1.94+   ($tls)
   Net::DNS::Native 0.15+  ($nnr)
+  Role::Tiny 2.000001+ ($roles)
 
 EOF
 

t/mojo/roles.t

@@ -0,0 +1,60 @@
+use Mojo::Base -strict;
+
+BEGIN {
+# bail in a BEGIN block, so we can use Role::Tiny in inline classes below
+  use Test::More;
+
+  plan skip_all => 'Role::Tiny 2.000001+ required for this test!'
+    unless Mojo::Base->can_roles;
+}
+
+package Mojo::RoleTest::LOUD;
+use Role::Tiny;
+
+sub yell {'HEY!'}
+
+requires 'name';
+
+sub hello {
+  my ($self) = @_;
+  return $self->yell . ' ' . uc($self->name) . '!!!';
+}
+
+package Mojo::RoleTest::quiet;
+use Role::Tiny;
+
+requires 'name';
+
+sub whisper {
+  my ($self) = @_;
+  return 'psst, ' . lc($self->name);
+}
+
+package Mojo::RoleTest::Base;
+use Mojo::Base -base;
+
+has name => 'bob';
+
+sub hello {
+  my ($self) = shift;
+  return 'hello ' . $self->name;
+}
+
+package main;
+
+my $obj = Mojo::RoleTest::Base->new(name => 'Ted');
+is($obj->name,  'Ted',       'attr works');
+is($obj->hello, 'hello Ted', 'class method');
+
+my $obj2 = Mojo::RoleTest::Base->with_roles('Mojo::RoleTest::LOUD')->new;
+is($obj2->hello, 'HEY! BOB!!!', 'method from role overrides base method');
+is($obj2->yell,  'HEY!',        'new method from role');
+
+my $obj3 = Mojo::RoleTest::Base->with_roles('Mojo::RoleTest::quiet',
+  'Mojo::RoleTest::LOUD')->new(name => 'Joel');
+is($obj3->name,    'Joel',         'attr from base class');
+is($obj3->whisper, 'psst, joel',   'method from role1');
+is($obj3->hello,   'HEY! JOEL!!!', 'method override from role2');
+
+done_testing();
+