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 Carp         'confess';
   8 use Scalar::Util 'blessed';
   9
  10 our $VERSION   = '0.02';
  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         $class = Moose::Meta::Class->create_anon_class(
  33             superclasses => [ blessed($object) ]
  34         );
  35         $ANON_CLASSES{$anon_role_key} = $class;
  36         $self->SUPER::apply($role, $class);
  37     }
  38
  39     $class->rebless_instance($object, %{$self->rebless_params});
  40 }
  41
  42 1;
  43
  44 __END__
  45
  46 =pod
  47
  48 =head1 NAME
  49
  50 Moose::Meta::Role::Application::ToInstance - Compose a role into an instance
  51
  52 =head1 DESCRIPTION
  53
  54 =head2 METHODS
  55
  56 =over 4
  57
  58 =item B<new>
  59
  60 =item B<meta>
  61
  62 =item B<apply>
  63
  64 =item B<rebless_params>
  65
  66 =back
  67
  68 =head1 BUGS
  69
  70 All complex software has bugs lurking in it, and this module is no
  71 exception. If you find a bug please either email me, or add the bug
  72 to cpan-RT.
  73
  74 =head1 AUTHOR
  75
  76 Stevan Little E<lt>stevan@iinteractive.comE<gt>
  77
  78 =head1 COPYRIGHT AND LICENSE
  79
  80 Copyright 2006-2008 by Infinity Interactive, Inc.
  81
  82 L<http://www.iinteractive.com>
  83
  84 This library is free software; you can redistribute it and/or modify
  85 it under the same terms as Perl itself.
  86
  87 =cut
  88