examples/AttributesWithHistory.pod

   1
   2 package # hide the package from PAUSE
   3     AttributesWithHistory;
   4
   5 use strict;
   6 use warnings;
   7
   8 our $VERSION = '0.03';
   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         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]\}\};
  41     }};
  42 }
  43
  44 sub generate_accessor_method {
  45     my ($self, $attr_name) = @_;
  46     eval qq{sub {
  47         if (scalar(\@_) == 2) {
  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];
  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 {
  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];
  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
  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;
 105       $class->meta->new_object(@_);
 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