0c52869fc1564adc10681afa0f8a14641dc81fb6
[gitmo/MooseX-AttributeHelpers.git] / lib / MooseX / AttributeHelpers / Base.pm
1
2 package MooseX::AttributeHelpers::Base;
3 use Moose;
4
5 our $VERSION   = '0.01';
6 our $AUTHORITY = 'cpan:STEVAN';
7
8 extends 'Moose::Meta::Attribute';
9
10 has 'method_constructors' => (
11     is      => 'ro',
12     isa     => 'HashRef',
13     default => sub { {} }
14 );
15
16 has 'provides' => (
17     is       => 'ro',
18     isa      => 'HashRef',
19     required => 1,
20 );
21
22 # extend the parents stuff to make sure 
23 # certain bits are now required ...
24 has '+$!default'       => (required => 1);
25 has '+type_constraint' => (required => 1);
26
27 # this confirms that provides has 
28 # all valid possibilities in it
29 sub _check_provides {
30     my ($self, $provides) = @_;
31     my $method_constructors = $self->method_constructors;
32     foreach my $key (keys %$provides) {
33         (exists $method_constructors->{$key})
34             || confess "$key is an unsupported method type";
35     }
36 }
37
38 # this provides an opportunity to 
39 # manipulate the %options to handle
40 # some of the provides features 
41 # correctly.
42 sub _process_options_for_provides {
43     my ($self, $options) = @_;
44     # ...
45 }
46
47 before '_process_options' => sub {
48     my ($self, %options) = @_;
49     if (exists $options{provides}) {
50         $self->_check_provides($options{provides});
51         $self->_process_options_for_provides(\%options);
52     }
53 };
54
55 after 'install_accessors' => sub {
56     my $attr  = shift;
57     my $class = $attr->associated_class;
58
59     my $method_constructors = $attr->method_constructors;
60     
61     foreach my $key (keys %{$attr->provides}) {
62         $class->add_method(
63             $attr->provides->{$key}, 
64             $method_constructors->{$key}->($attr)
65         );
66     }
67 };
68
69 no Moose;
70
71 1;
72
73 __END__
74
75 =pod
76
77 =head1 NAME
78
79 MooseX::AttributeHelpers::Base
80
81 =head1 SYNOPSIS
82   
83 =head1 DESCRIPTION
84
85 =head1 METHODS
86
87 =head1 BUGS
88
89 All complex software has bugs lurking in it, and this module is no 
90 exception. If you find a bug please either email me, or add the bug
91 to cpan-RT.
92
93 =head1 AUTHOR
94
95 Stevan Little E<lt>stevan@iinteractive.comE<gt>
96
97 =head1 COPYRIGHT AND LICENSE
98
99 Copyright 2007 by Infinity Interactive, Inc.
100
101 L<http://www.iinteractive.com>
102
103 This library is free software; you can redistribute it and/or modify
104 it under the same terms as Perl itself.
105
106 =cut