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