Commit | Line | Data |
38bf2a25 |
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 |