Commit | Line | Data |
---|---|---|
677eb158 | 1 | |
2 | package metaclass; | |
3 | ||
4 | use strict; | |
5 | use warnings; | |
6 | ||
22286063 | 7 | use Carp 'confess'; |
8 | use Scalar::Util 'blessed'; | |
677eb158 | 9 | |
8861fab2 | 10 | our $VERSION = '0.05'; |
f0480c45 | 11 | our $AUTHORITY = 'cpan:STEVAN'; |
677eb158 | 12 | |
13 | use Class::MOP; | |
14 | ||
15 | sub import { | |
16 | shift; | |
1becdfcc | 17 | my $metaclass; |
c23184fc | 18 | if (!defined($_[0]) || $_[0] =~ /^(attribute|method|instance)_metaclass/) { |
1becdfcc | 19 | $metaclass = 'Class::MOP::Class'; |
20 | } | |
21 | else { | |
22 | $metaclass = shift; | |
f2266181 | 23 | #make sure the custom metaclass gets loaded |
95514cb4 | 24 | Class::MOP::load_class($metaclass); |
1becdfcc | 25 | ($metaclass->isa('Class::MOP::Class')) |
16e960bd | 26 | || confess "The metaclass ($metaclass) must be derived from Class::MOP::Class"; |
1becdfcc | 27 | } |
d82060fe | 28 | my %options = @_; |
8861fab2 | 29 | |
30 | # make sure the custom metaclasses get loaded | |
31 | foreach my $class (grep { | |
32 | /^(attribute|method|instance)_metaclass/ | |
33 | } keys %options) { | |
34 | Class::MOP::load_class($options{$class}) | |
35 | } | |
36 | ||
d82060fe | 37 | my $package = caller(); |
95514cb4 | 38 | |
677eb158 | 39 | # create a meta object so we can install &meta |
40 | my $meta = $metaclass->initialize($package => %options); | |
41 | $meta->add_method('meta' => sub { | |
95514cb4 | 42 | # we must re-initialize so that it |
43 | # works as expected in subclasses, | |
44 | # since metaclass instances are | |
45 | # singletons, this is not really a | |
677eb158 | 46 | # big deal anyway. |
22286063 | 47 | $metaclass->initialize((blessed($_[0]) || $_[0]) => %options) |
677eb158 | 48 | }); |
49 | } | |
50 | ||
51 | 1; | |
52 | ||
53 | __END__ | |
54 | ||
55 | =pod | |
56 | ||
57 | =head1 NAME | |
58 | ||
96ceced8 | 59 | metaclass - a pragma for installing and using Class::MOP metaclasses |
677eb158 | 60 | |
61 | =head1 SYNOPSIS | |
62 | ||
550d56db | 63 | package MyClass; |
64 | ||
65 | # use Class::MOP::Class | |
95514cb4 | 66 | use metaclass; |
550d56db | 67 | |
68 | # ... or use a custom metaclass | |
677eb158 | 69 | use metaclass 'MyMetaClass'; |
95514cb4 | 70 | |
71 | # ... or use a custom metaclass | |
550d56db | 72 | # and custom attribute and method |
73 | # metaclasses | |
677eb158 | 74 | use metaclass 'MyMetaClass' => ( |
c23184fc | 75 | 'attribute_metaclass' => 'MyAttributeMetaClass', |
95514cb4 | 76 | 'method_metaclass' => 'MyMethodMetaClass', |
677eb158 | 77 | ); |
78 | ||
1becdfcc | 79 | # ... or just specify custom attribute |
80 | # and method classes, and Class::MOP::Class | |
81 | # is the assumed metaclass | |
82 | use metaclass ( | |
c23184fc | 83 | 'attribute_metaclass' => 'MyAttributeMetaClass', |
95514cb4 | 84 | 'method_metaclass' => 'MyMethodMetaClass', |
1becdfcc | 85 | ); |
86 | ||
677eb158 | 87 | =head1 DESCRIPTION |
88 | ||
95514cb4 | 89 | This is a pragma to make it easier to use a specific metaclass |
90 | and a set of custom attribute and method metaclasses. It also | |
91 | installs a C<meta> method to your class as well. | |
c9e77dbb | 92 | |
1a09d9cc | 93 | =head1 AUTHORS |
677eb158 | 94 | |
95 | Stevan Little E<lt>stevan@iinteractive.comE<gt> | |
96 | ||
97 | =head1 COPYRIGHT AND LICENSE | |
98 | ||
69e3ab0a | 99 | Copyright 2006-2008 by Infinity Interactive, Inc. |
677eb158 | 100 | |
101 | L<http://www.iinteractive.com> | |
102 | ||
103 | This library is free software; you can redistribute it and/or modify | |
95514cb4 | 104 | it under the same terms as Perl itself. |
677eb158 | 105 | |
16e960bd | 106 | =cut |