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