From: Stevan Little Date: Fri, 3 Feb 2006 19:08:15 +0000 (+0000) Subject: adding in another example X-Git-Tag: 0_04~3 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=343203eec945553800bc17abc3e650e40e363a8d;p=gitmo%2FClass-MOP.git adding in another example --- diff --git a/Changes b/Changes index 5b7d686..2148063 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,8 @@ Revision history for Perl extension Class-MOP. +0.04 + - some documentation suggestions from #perl6 + 0.03 Fri Feb. 3, 2006 - converted to Module::Build instead of EU::MM diff --git a/examples/AttributesWithHistory.pod b/examples/AttributesWithHistory.pod new file mode 100644 index 0000000..0061171 --- /dev/null +++ b/examples/AttributesWithHistory.pod @@ -0,0 +1,125 @@ + +package # hide the package from PAUSE + AttributesWithHistory; + +use strict; +use warnings; + +use Class::MOP 'meta'; + +our $VERSION = '0.01'; + +use base 'Class::MOP::Attribute'; + +# this is for an extra attribute constructor +# option, which is to be able to create a +# way for the class to access the history +__PACKAGE__->meta->add_attribute( + Class::MOP::Attribute->new('history_accessor' => ( + reader => 'history_accessor', + init_arg => 'history_accessor', + predicate => 'has_history_accessor', + )) +); + +# this is a place to store the actual +# history of the attribute +__PACKAGE__->meta->add_attribute( + Class::MOP::Attribute->new('_history' => ( + accessor => '_history', + default => sub { [] }, + )) +); + +# generate the methods + +sub generate_history_accessor_method { + my ($self, $attr_name) = @_; + eval qq{sub { + \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()\}; + }}; +} + +sub generate_accessor_method { + my ($self, $attr_name) = @_; + eval qq{sub { + if (scalar(\@_) == 2) { + push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()\} => \$_[1]; + \$_[0]->{'$attr_name'} = \$_[1]; + } + \$_[0]->{'$attr_name'}; + }}; +} + +sub generate_writer_method { + my ($self, $attr_name) = @_; + eval qq{sub { + push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()\} => \$_[1]; + \$_[0]->{'$attr_name'} = \$_[1]; + }}; +} + +sub install_accessors { + my $self = shift; + # do as we normall do ... + $self->SUPER::install_accessors(); + # and now add the history accessor + $self->associated_class->add_method( + $self->process_accessors('history_accessor' => $self->history_accessor()) + ) if $self->has_history_accessor(); + return; +} + +1; + +=pod + +=head1 NAME + +AttributesWithHistory - An example attribute metaclass which keeps a history of changes + +=head1 SYSNOPSIS + + package Foo; + + use Class::MOP 'meta'; + + Foo->meta->add_attribute(AttributesWithHistory->new('foo' => ( + accessor => 'foo', + history_accessor => 'get_foo_history', + ))); + + Foo->meta->add_attribute(AttributesWithHistory->new('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + history_accessor => 'get_bar_history', + ))); + + sub new { + my $class = shift; + bless $class->meta->construct_instance() => $class; + } + +=head1 DESCRIPTION + +This is an example of an attribute metaclass which keeps a +record of all the values it has been assigned. It stores the +history as a field in the attribute meta-object, and will +autogenerate a means of accessing that history for the class +which these attributes are added too. + +=head1 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 4d55f82..698ba6f 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -154,7 +154,7 @@ of method dispatch. =head2 What changes do I have to make to use this module? This module was designed to be as unintrusive as possible. Many of -it's features are accessible without B change to your existsing +its features are accessible without B change to your existsing code at all. It is meant to be a compliment to your existing code and not an intrusion on your code base. Unlike many other B modules, this module B require you subclass it, or even that diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index e968bae..2a47ecc 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -135,7 +135,7 @@ sub process_accessors { if (my $method = $self->$generator($self->name)) { return ($accessor => Class::MOP::Attribute::Accessor->wrap($method)); } - confess "Could not create the methods for " . $self->name . " because : $@"; + confess "Could not create the '$type' method for " . $self->name . " because : $@"; } } diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 7e9832f..ecf8f5d 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -539,6 +539,13 @@ This is a read-write attribute which represents the superclass relationships of the class the B instance is associated with. Basically, it can get and set the C<@ISA> for you. +B +Perl will occasionally perform some C<@ISA> and method caching, if +you decide to change your superclass relationship at runtime (which +is quite insane and very much not recommened), then you should be +aware of this and the fact that this module does not make any +attempt to address this issue. + =item B This computes the a list of all the class's ancestors in the same order diff --git a/t/104_AttributesWithHistory_test.t b/t/104_AttributesWithHistory_test.t new file mode 100644 index 0000000..702162e --- /dev/null +++ b/t/104_AttributesWithHistory_test.t @@ -0,0 +1,93 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 19; +use File::Spec; + +BEGIN { + use_ok('Class::MOP'); + require_ok(File::Spec->catdir('examples', 'AttributesWithHistory.pod')); +} + +{ + package Foo; + + use Class::MOP 'meta'; + + Foo->meta->add_attribute(AttributesWithHistory->new('foo' => ( + accessor => 'foo', + history_accessor => 'get_foo_history', + ))); + + Foo->meta->add_attribute(AttributesWithHistory->new('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + history_accessor => 'get_bar_history', + ))); + + sub new { + my $class = shift; + bless $class->meta->construct_instance() => $class; + } +} + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +can_ok($foo, 'foo'); +can_ok($foo, 'get_foo_history'); +can_ok($foo, 'set_bar'); +can_ok($foo, 'get_bar'); +can_ok($foo, 'get_bar_history'); + +is($foo->foo, undef, '... foo is not yet defined'); +is_deeply( + [ $foo->get_foo_history() ], + [ ], + '... got correct empty history for foo'); + +$foo->foo(42); +is($foo->foo, 42, '... foo == 42'); +is_deeply( + [ $foo->get_foo_history() ], + [ 42 ], + '... got correct history for foo'); + +$foo->foo(43); +$foo->foo(44); +$foo->foo(45); +$foo->foo(46); + +is_deeply( + [ $foo->get_foo_history() ], + [ 42, 43, 44, 45, 46 ], + '... got correct history for foo'); + +is($foo->get_bar, undef, '... bar is not yet defined'); +is_deeply( + [ $foo->get_bar_history() ], + [ ], + '... got correct empty history for foo'); + + +$foo->set_bar("FOO"); +is($foo->get_bar, "FOO", '... bar == "FOO"'); +is_deeply( + [ $foo->get_bar_history() ], + [ "FOO" ], + '... got correct history for foo'); + +$foo->set_bar("BAR"); +$foo->set_bar("BAZ"); + +is_deeply( + [ $foo->get_bar_history() ], + [ qw/FOO BAR BAZ/ ], + '... got correct history for bar'); + +is_deeply( + [ $foo->get_foo_history() ], + [ 42, 43, 44, 45, 46 ], + '... still have the correct history for foo');