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