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