making the init_arg even more silly
[gitmo/Class-MOP.git] / examples / AttributesWithHistory.pod
CommitLineData
343203ee 1
2package # hide the package from PAUSE
3 AttributesWithHistory;
4
5use strict;
6use warnings;
7
a4258ffd 8our $VERSION = '0.04';
343203ee 9
10use 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
a4258ffd 15AttributesWithHistory->meta->add_attribute('history_accessor' => (
16 reader => 'history_accessor',
17 init_arg => 'history_accessor',
18 predicate => 'has_history_accessor',
19));
343203ee 20
21# this is a place to store the actual
22# history of the attribute
a4258ffd 23AttributesWithHistory->meta->add_attribute('_history' => (
24 accessor => '_history',
25 default => sub { {} },
26));
343203ee 27
28# generate the methods
29
30sub generate_history_accessor_method {
31 my ($self, $attr_name) = @_;
32 eval qq{sub {
0b8eb325 33 unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
34 \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = [];
35 \}
36 \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\};
343203ee 37 }};
38}
39
40sub generate_accessor_method {
41 my ($self, $attr_name) = @_;
42 eval qq{sub {
43 if (scalar(\@_) == 2) {
0b8eb325 44 unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
45 \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = [];
46 \}
47 push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1];
343203ee 48 \$_[0]->{'$attr_name'} = \$_[1];
49 }
50 \$_[0]->{'$attr_name'};
51 }};
52}
53
54sub generate_writer_method {
55 my ($self, $attr_name) = @_;
56 eval qq{sub {
0b8eb325 57 unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
58 \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = [];
59 \}
60 push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1];
343203ee 61 \$_[0]->{'$attr_name'} = \$_[1];
62 }};
63}
64
a4258ffd 65AttributesWithHistory->meta->add_after_method_modifier('install_accessors' => sub {
66 my ($self) = @_;
343203ee 67 # and now add the history accessor
68 $self->associated_class->add_method(
69 $self->process_accessors('history_accessor' => $self->history_accessor())
70 ) if $self->has_history_accessor();
a4258ffd 71});
343203ee 72
731;
74
75=pod
76
77=head1 NAME
78
79AttributesWithHistory - An example attribute metaclass which keeps a history of changes
80
81=head1 SYSNOPSIS
82
83 package Foo;
84
343203ee 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;
5659d76e 98 $class->meta->new_object(@_);
343203ee 99 }
100
101=head1 DESCRIPTION
102
103This is an example of an attribute metaclass which keeps a
104record of all the values it has been assigned. It stores the
105history as a field in the attribute meta-object, and will
106autogenerate a means of accessing that history for the class
107which these attributes are added too.
108
1a09d9cc 109=head1 AUTHORS
343203ee 110
111Stevan Little E<lt>stevan@iinteractive.comE<gt>
112
1a09d9cc 113Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
114
343203ee 115=head1 COPYRIGHT AND LICENSE
116
117Copyright 2006 by Infinity Interactive, Inc.
118
119L<http://www.iinteractive.com>
120
121This library is free software; you can redistribute it and/or modify
122it under the same terms as Perl itself.
123
124=cut