allow roles to be applied to objects

mojolicious · Aug 17, 2017 · 350a293 · 350a293
1 parent 96a9fb1
commit 350a293
Show file tree

Hide file tree

Showing 7 changed files with 25 additions and 6 deletions.
diff --git a/Changes b/Changes
@@ -1,5 +1,6 @@
 
 7.43  2017-08-18
+  - Improve Mojo::Base role support with the ability to rebless objects.
 
 7.42  2017-08-17
   - Improved Mojo::Base role support with shorthands.

diff --git a/lib/Mojo/Base.pm b/lib/Mojo/Base.pm
@@ -6,7 +6,8 @@ use utf8;
 use feature ();
 
 # No imports because we get subclassed, a lot!
-use Carp ();
+use Carp         ();
+use Scalar::Util ();
 
 # Only Perl 5.14+ requires it on demand
 use IO::Handle ();
@@ -107,9 +108,14 @@ sub tap {
 
 sub with_roles {
   Carp::croak 'Role::Tiny 2.000001+ is required for roles' unless ROLES;
-  my $class = shift;
-  return Role::Tiny->create_class_with_roles($class,
-    map { /^\+(.+)$/ ? "${class}::Role::$1" : $_ } @_);
+  my ($self, @roles) = @_;
+
+  return Role::Tiny->create_class_with_roles($self,
+    map { /^\+(.+)$/ ? "${self}::Role::$1" : $_ } @roles)
+    unless my $class = Scalar::Util::blessed $self;
+
+  return Role::Tiny->apply_roles_to_object($self,
+    map { /^\+(.+)$/ ? "${class}::Role::$1" : $_ } @roles);
 }
 
 1;
@@ -251,9 +257,10 @@ spliced or tapped into) a chained set of object method calls.
 
   my $new_class = SubClass->with_roles('SubClass::Role::One');
   my $new_class = SubClass->with_roles('+One', '+Two');
+  $object       = $object->with_roles('+One', '+Two');
 
-Create and return a new class that extends the given class with one or more
-L<Role::Tiny> roles. For roles following the naming scheme
+Create a new class with one or more L<Role::Tiny> roles and return it, or
+rebless the given object into it. For roles following the naming scheme
 C<MyClass::Role::RoleName> you can use the shorthand C<+RoleName>. Note that
 role support depends on L<Role::Tiny> (2.000001+).
 

diff --git a/lib/Mojo/ByteStream.pm b/lib/Mojo/ByteStream.pm
@@ -334,6 +334,7 @@ L<Mojo::Util/"url_unescape">.
 
   my $new_class = Mojo::ByteStream->with_roles('Mojo::ByteStream::Role::One');
   my $new_class = Mojo::ByteStream->with_roles('+One', '+Two');
+  $stream       = $stream->with_roles('+One', '+Two');
 
 Alias for L<Mojo::Base/"with_roles">.
 

diff --git a/lib/Mojo/Collection.pm b/lib/Mojo/Collection.pm
@@ -373,6 +373,7 @@ callback/method.
 
   my $new_class = Mojo::Collection->with_roles('Mojo::Collection::Role::One');
   my $new_class = Mojo::Collection->with_roles('+One', '+Two');
+  $collection   = $collection->with_roles('+One', '+Two');
 
 Alias for L<Mojo::Base/"with_roles">.
 

diff --git a/lib/Mojo/DOM.pm b/lib/Mojo/DOM.pm
@@ -952,6 +952,7 @@ if none could be found.
 
   my $new_class = Mojo::DOM->with_roles('Mojo::DOM::Role::One');
   my $new_class = Mojo::DOM->with_roles('+One', '+Two');
+  $dom          = $dom->with_roles('+One', '+Two');
 
 Alias for L<Mojo::Base/"with_roles">.
 

diff --git a/lib/Mojo/File.pm b/lib/Mojo/File.pm
@@ -452,6 +452,7 @@ Stringify the path.
 
   my $new_class = Mojo::File->with_roles('Mojo::File::Role::One');
   my $new_class = Mojo::File->with_roles('+One', '+Two');
+  $path         = $path->with_roles('+One', '+Two');
 
 Alias for L<Mojo::Base/"with_roles">.
 

diff --git a/t/mojo/roles.t b/t/mojo/roles.t
@@ -86,6 +86,13 @@ is $obj6->name,    'Joel',         'base attribute';
 is $obj6->whisper, 'psst, joel',   'method from first role';
 is $obj6->hello,   'HEY! JOEL!!!', 'method from second role';
 
+# Multiple object roles (mixed)
+my $obj7 = Mojo::RoleTest->new(name => 'Joel')
+  ->with_roles('Mojo::RoleTest::Role::quiet', '+LOUD');
+is $obj7->name,    'Joel',         'base attribute';
+is $obj7->whisper, 'psst, joel',   'method from first role';
+is $obj7->hello,   'HEY! JOEL!!!', 'method from second role';
+
 # Classes that are not subclasses of Mojo::Base
 my $stream = Mojo::ByteStream->with_roles('Mojo::RoleTest::Hello')->new;
 is $stream->hello, 'hello mojo!', 'right result';