lib/Moose/Meta/Role/Application/ToInstance.pm

   1 package Moose::Meta::Role::Application::ToInstance;
   2
   3 use strict;
   4 use warnings;
   5 use metaclass;
   6
   7 use Scalar::Util 'blessed';
   8
   9 our $VERSION   = '1.19';
  10 $VERSION = eval $VERSION;
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use base 'Moose::Meta::Role::Application';
  14
  15 __PACKAGE__->meta->add_attribute('rebless_params' => (
  16     reader  => 'rebless_params',
  17     default => sub { {} }
  18 ));
  19
  20 sub apply {
  21     my ( $self, $role, $object, $args ) = @_;
  22
  23     my $obj_meta = Class::MOP::class_of($object) || 'Moose::Meta::Class';
  24
  25     # This is a special case to handle the case where the object's metaclass
  26     # is a Class::MOP::Class, but _not_ a Moose::Meta::Class (for example,
  27     # when applying a role to a Moose::Meta::Attribute object).
  28     $obj_meta = 'Moose::Meta::Class'
  29         unless $obj_meta->isa('Moose::Meta::Class');
  30
  31     my $class = $obj_meta->create_anon_class(
  32         superclasses => [ blessed($object) ],
  33         roles => [ $role, keys(%$args) ? ($args) : () ],
  34         cache => 1,
  35     );
  36
  37     $class->rebless_instance( $object, %{ $self->rebless_params } );
  38 }
  39
  40 1;
  41
  42 __END__
  43
  44 =pod
  45
  46 =head1 NAME
  47
  48 Moose::Meta::Role::Application::ToInstance - Compose a role into an instance
  49
  50 =head1 DESCRIPTION
  51
  52 =head2 METHODS
  53
  54 =over 4
  55
  56 =item B<new>
  57
  58 =item B<meta>
  59
  60 =item B<apply>
  61
  62 =item B<rebless_params>
  63
  64 =back
  65
  66 =head1 BUGS
  67
  68 See L<Moose/BUGS> for details on reporting bugs.
  69
  70 =head1 AUTHOR
  71
  72 Stevan Little E<lt>stevan@iinteractive.comE<gt>
  73
  74 =head1 COPYRIGHT AND LICENSE
  75
  76 Copyright 2006-2010 by Infinity Interactive, Inc.
  77
  78 L<http://www.iinteractive.com>
  79
  80 This library is free software; you can redistribute it and/or modify
  81 it under the same terms as Perl itself.
  82
  83 =cut
  84