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