From eb3cca312a267622cd9131d0f877a7fb6ee04d6c Mon Sep 17 00:00:00 2001
From: Dotan Dimet <dotan@corky.net>
Date: Wed, 9 Aug 2017 19:43:18 +0300
Subject: [PATCH] Mojo::Base::with_roles patch

Support extending Mojo::Base classes with roles, using Role::Tiny
(optional dependency)
---
 lib/Mojo/Base.pm                   | 27 ++++++++++++++
 lib/Mojolicious/Command/version.pm |  2 +
 t/mojo/roles.t                     | 60 ++++++++++++++++++++++++++++++
 3 files changed, 89 insertions(+)
 create mode 100644 t/mojo/roles.t

diff --git a/lib/Mojo/Base.pm b/lib/Mojo/Base.pm
index b1a1771eff..8c138b5522 100644
--- a/lib/Mojo/Base.pm
+++ b/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>.
diff --git a/lib/Mojolicious/Command/version.pm b/lib/Mojolicious/Command/version.pm
index 1ca304ee77..b03deec997 100644
--- a/lib/Mojolicious/Command/version.pm
+++ b/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
 
diff --git a/t/mojo/roles.t b/t/mojo/roles.t
new file mode 100644
index 0000000000..228d978c48
--- /dev/null
+++ b/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();
+