Store the role which first defines an attribute, and pass that along when cloning.
[gitmo/Moose.git] / examples / AttributesWithHistory.pod
1
2 package # hide the package from PAUSE
3     AttributesWithHistory;
4
5 use strict;
6 use warnings;
7
8 our $VERSION = '0.05';
9
10 use base 'Class::MOP::Attribute';
11
12 # this is for an extra attribute constructor 
13 # option, which is to be able to create a 
14 # way for the class to access the history
15 AttributesWithHistory->meta->add_attribute('history_accessor' => (
16     reader    => 'history_accessor',
17     init_arg  => 'history_accessor',
18     predicate => 'has_history_accessor',
19 ));
20
21 # this is a place to store the actual 
22 # history of the attribute
23 AttributesWithHistory->meta->add_attribute('_history' => (
24     accessor => '_history',
25     default  => sub { {} },
26 ));
27
28 sub accessor_metaclass { 'AttributesWithHistory::Method::Accessor' }
29
30 AttributesWithHistory->meta->add_after_method_modifier('install_accessors' => sub {
31     my ($self) = @_;
32     # and now add the history accessor
33     $self->associated_class->add_method(
34         $self->_process_accessors('history_accessor' => $self->history_accessor())
35     ) if $self->has_history_accessor();
36 });
37
38 package # hide the package from PAUSE
39     AttributesWithHistory::Method::Accessor;
40
41 use strict;
42 use warnings;
43
44 our $VERSION = '0.01';
45
46 use base 'Class::MOP::Method::Accessor';
47
48 # generate the methods
49
50 sub _generate_history_accessor_method {
51     my $attr_name = (shift)->associated_attribute->name;
52     eval qq{sub {
53         unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
54             \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = [];    
55         \}
56         \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\};        
57     }};    
58 }
59
60 sub _generate_accessor_method {
61     my $attr_name = (shift)->associated_attribute->name;
62     eval qq{sub {
63         if (scalar(\@_) == 2) {
64             unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
65                 \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = [];    
66             \}            
67             push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1];
68             \$_[0]->{'$attr_name'} = \$_[1];
69         }
70         \$_[0]->{'$attr_name'};
71     }};
72 }
73
74 sub _generate_writer_method {
75     my $attr_name = (shift)->associated_attribute->name;
76     eval qq{sub {
77         unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
78             \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = [];    
79         \}        
80         push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1];        
81         \$_[0]->{'$attr_name'} = \$_[1];
82     }};
83 }    
84
85 1;
86
87 =pod
88
89 =head1 NAME
90
91 AttributesWithHistory - An example attribute metaclass which keeps a history of changes
92
93 =head1 SYSNOPSIS
94   
95   package Foo;
96   
97   Foo->meta->add_attribute(AttributesWithHistory->new('foo' => (
98       accessor         => 'foo',
99       history_accessor => 'get_foo_history',
100   )));    
101   
102   Foo->meta->add_attribute(AttributesWithHistory->new('bar' => (
103       reader           => 'get_bar',
104       writer           => 'set_bar',
105       history_accessor => 'get_bar_history',
106   )));    
107   
108   sub new  {
109       my $class = shift;
110       $class->meta->new_object(@_);
111   }
112   
113 =head1 DESCRIPTION
114
115 This is an example of an attribute metaclass which keeps a 
116 record of all the values it has been assigned. It stores the 
117 history as a field in the attribute meta-object, and will 
118 autogenerate a means of accessing that history for the class 
119 which these attributes are added too.
120
121 =head1 AUTHORS
122
123 Stevan Little E<lt>stevan@iinteractive.comE<gt>
124
125 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
126
127 =head1 COPYRIGHT AND LICENSE
128
129 Copyright 2006-2008 by Infinity Interactive, Inc.
130
131 L<http://www.iinteractive.com>
132
133 This library is free software; you can redistribute it and/or modify
134 it under the same terms as Perl itself.
135
136 =cut