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