From: Stevan Little Date: Mon, 30 Jan 2006 23:37:43 +0000 (+0000) Subject: Class::MOP - fleshing out the attributes a bit more X-Git-Tag: 0_02~14 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c50c603e0b03ecf8d9ce888b94809240366c1bc0;p=gitmo%2FClass-MOP.git Class::MOP - fleshing out the attributes a bit more --- diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 8f3a80d..c4bdd5b 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -5,7 +5,7 @@ use strict; use warnings; use Carp 'confess'; -use Scalar::Util 'blessed'; +use Scalar::Util 'blessed', 'reftype'; use Class::MOP::Class; use Class::MOP::Method; @@ -26,31 +26,38 @@ sub new { if exists $options{accessor}; bless { - name => $name, - accessor => $options{accessor}, - reader => $options{reader}, - writer => $options{writer}, - init_arg => $options{init_arg}, - default => $options{default} + name => $name, + accessor => $options{accessor}, + reader => $options{reader}, + writer => $options{writer}, + predicate => $options{predicate}, + init_arg => $options{init_arg}, + default => $options{default} } => $class; } -sub name { (shift)->{name} } - -sub has_accessor { (shift)->{accessor} ? 1 : 0 } -sub accessor { (shift)->{accessor} } - -sub has_reader { (shift)->{reader} ? 1 : 0 } -sub reader { (shift)->{reader} } - -sub has_writer { (shift)->{writer} ? 1 : 0 } -sub writer { (shift)->{writer} } - -sub has_init_arg { (shift)->{init_arg} ? 1 : 0 } -sub init_arg { (shift)->{init_arg} } - -sub has_default { (shift)->{default} ? 1 : 0 } -sub default { (shift)->{default} } +sub name { $_[0]->{name} } + +sub has_accessor { defined($_[0]->{accessor}) ? 1 : 0 } +sub has_reader { defined($_[0]->{reader}) ? 1 : 0 } +sub has_writer { defined($_[0]->{writer}) ? 1 : 0 } +sub has_predicate { defined($_[0]->{predicate}) ? 1 : 0 } +sub has_init_arg { defined($_[0]->{init_arg}) ? 1 : 0 } +sub has_default { defined($_[0]->{default}) ? 1 : 0 } + +sub accessor { $_[0]->{accessor} } +sub reader { $_[0]->{reader} } +sub writer { $_[0]->{writer} } +sub predicate { $_[0]->{predicate} } +sub init_arg { $_[0]->{init_arg} } + +sub default { + my $self = shift; + if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') { + return $self->{default}->(shift); + } + $self->{default}; +} sub install_accessors { my ($self, $class) = @_; @@ -58,24 +65,58 @@ sub install_accessors { || confess "You must pass a Class::MOP::Class instance (or a subclass)"; if ($self->has_accessor()) { - $class->add_method($self->accessor() => Class::MOP::Attribute::Accessor->wrap(sub { - $_[0]->{$self->name} = $_[1] if scalar(@_) == 2; - $_[0]->{$self->name}; - })); + my $accessor = $self->accessor(); + if (reftype($accessor) && reftype($accessor) eq 'HASH') { + my ($name, $method) = each %{$accessor}; + $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method)); + } + else { + $class->add_method($accessor => Class::MOP::Attribute::Accessor->wrap(sub { + $_[0]->{$self->name} = $_[1] if scalar(@_) == 2; + $_[0]->{$self->name}; + })); + } } else { - if ($self->has_reader()) { - $class->add_method($self->reader() => Class::MOP::Attribute::Accessor->wrap(sub { - $_[0]->{$self->name}; - })); + if ($self->has_reader()) { + my $reader = $self->reader(); + if (reftype($reader) && reftype($reader) eq 'HASH') { + my ($name, $method) = each %{$reader}; + $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method)); + } + else { + $class->add_method($reader => Class::MOP::Attribute::Accessor->wrap(sub { + $_[0]->{$self->name}; + })); + } } if ($self->has_writer()) { - $class->add_method($self->writer() => Class::MOP::Attribute::Accessor->wrap(sub { - $_[0]->{$self->name} = $_[1]; - return; - })); + my $writer = $self->writer(); + if (reftype($writer) && reftype($writer) eq 'HASH') { + my ($name, $method) = each %{$writer}; + $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method)); + } + else { + $class->add_method($writer => Class::MOP::Attribute::Accessor->wrap(sub { + $_[0]->{$self->name} = $_[1]; + return; + })); + } } } + + if ($self->has_predicate()) { + my $predicate = $self->predicate(); + if (reftype($predicate) && reftype($predicate) eq 'HASH') { + my ($name, $method) = each %{$predicate}; + $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method)); + } + else { + $class->add_method($predicate => Class::MOP::Attribute::Accessor->wrap(sub { + defined $_[0]->{$self->name} ? 1 : 0; + })); + } + } } sub remove_accessors { @@ -84,22 +125,44 @@ sub remove_accessors { || confess "You must pass a Class::MOP::Class instance (or a subclass)"; if ($self->has_accessor()) { - my $method = $class->get_method($self->accessor); - $class->remove_method($self->accessor) + my $accessor = $self->accessor(); + if (reftype($accessor) && reftype($accessor) eq 'HASH') { + ($accessor) = keys %{$accessor}; + } + my $method = $class->get_method($accessor); + $class->remove_method($accessor) if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor')); } else { if ($self->has_reader()) { - my $method = $class->get_method($self->reader); - $class->remove_method($self->reader) + my $reader = $self->reader(); + if (reftype($reader) && reftype($reader) eq 'HASH') { + ($reader) = keys %{$reader}; + } + my $method = $class->get_method($reader); + $class->remove_method($reader) if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor')); } if ($self->has_writer()) { - my $method = $class->get_method($self->writer); - $class->remove_method($self->writer) + my $writer = $self->writer(); + if (reftype($writer) && reftype($writer) eq 'HASH') { + ($writer) = keys %{$writer}; + } + my $method = $class->get_method($writer); + $class->remove_method($writer) if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor')); } - } + } + + if ($self->has_predicate()) { + my $predicate = $self->predicate(); + if (reftype($predicate) && reftype($predicate) eq 'HASH') { + ($predicate) = keys %{$predicate}; + } + my $method = $class->get_method($predicate); + $class->remove_method($predicate) + if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor')); + } } package Class::MOP::Attribute::Accessor; @@ -168,6 +231,8 @@ chaos, by introducing a more consistent approach. =item B +=item B + =item B =item B @@ -191,6 +256,10 @@ Returns true if this attribute has a reader, and false otherwise Returns true if this attribute has a writer, and false otherwise +=item B + +Returns true if this attribute has a predicate, and false otherwise + =item B Returns true if this attribute has a class intialization argument, and diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 82b4744..988c735 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -78,7 +78,7 @@ sub construct_instance { $val = $params{$init_arg} if exists $params{$init_arg}; # if nothing was in the %params, we can use the # attribute's default value (if it has one) - $val ||= $attr->default() if $attr->has_default(); + $val ||= $attr->default($instance) if $attr->has_default(); # now add this to the instance structure $instance->{$attr->name} = $val; } diff --git a/t/100_BinaryTree_test.t b/t/100_BinaryTree_test.t new file mode 100644 index 0000000..a7684eb --- /dev/null +++ b/t/100_BinaryTree_test.t @@ -0,0 +1,321 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 67; + +BEGIN { + use_ok('t::lib::BinaryTree'); +} + +## ---------------------------------------------------------------------------- +## These are all tests which are derived from the Tree::Binary test suite +## ---------------------------------------------------------------------------- + +## ---------------------------------------------------------------------------- +## t/10_Tree_Binary_test.t + +can_ok("BinaryTree", 'new'); +can_ok("BinaryTree", 'setLeft'); +can_ok("BinaryTree", 'setRight'); + +my $btree = BinaryTree->new("/") + ->setLeft( + BinaryTree->new("+") + ->setLeft( + BinaryTree->new("2") + ) + ->setRight( + BinaryTree->new("2") + ) + ) + ->setRight( + BinaryTree->new("*") + ->setLeft( + BinaryTree->new("4") + ) + ->setRight( + BinaryTree->new("5") + ) + ); +isa_ok($btree, 'BinaryTree'); + +## informational methods + +can_ok($btree, 'isRoot'); +ok($btree->isRoot(), '... this is the root'); + +can_ok($btree, 'isLeaf'); +ok(!$btree->isLeaf(), '... this is not a leaf node'); +ok($btree->getLeft()->getLeft()->isLeaf(), '... this is a leaf node'); + +can_ok($btree, 'hasLeft'); +ok($btree->hasLeft(), '... this has a left node'); + +can_ok($btree, 'hasRight'); +ok($btree->hasRight(), '... this has a right node'); + +## accessors + +can_ok($btree, 'getUID'); + +{ + my $UID = $btree->getUID(); + is(("$btree" =~ /\((.*?)\)$/), $UID, '... our UID is derived from the stringified object'); +} + +can_ok($btree, 'getNodeValue'); +is($btree->getNodeValue(), '/', '... got what we expected'); + +{ + can_ok($btree, 'getLeft'); + my $left = $btree->getLeft(); + + isa_ok($left, 'BinaryTree'); + + is($left->getNodeValue(), '+', '... got what we expected'); + + can_ok($left, 'getParent'); + + my $parent = $left->getParent(); + isa_ok($parent, 'BinaryTree'); + + is($parent, $btree, '.. got what we expected'); +} + +{ + can_ok($btree, 'getRight'); + my $right = $btree->getRight(); + + isa_ok($right, 'BinaryTree'); + + is($right->getNodeValue(), '*', '... got what we expected'); + + can_ok($right, 'getParent'); + + my $parent = $right->getParent(); + isa_ok($parent, 'BinaryTree'); + + is($parent, $btree, '.. got what we expected'); +} + +## mutators + +can_ok($btree, 'setUID'); +$btree->setUID("Our UID for this tree"); + +is($btree->getUID(), 'Our UID for this tree', '... our UID is not what we expected'); + +can_ok($btree, 'setNodeValue'); +$btree->setNodeValue('*'); + +is($btree->getNodeValue(), '*', '... got what we expected'); + + +{ + can_ok($btree, 'removeLeft'); + my $left = $btree->removeLeft(); + isa_ok($left, 'BinaryTree'); + + ok(!$btree->hasLeft(), '... we dont have a left node anymore'); + ok(!$btree->isLeaf(), '... and we are not a leaf node'); + + $btree->setLeft($left); + + ok($btree->hasLeft(), '... we have our left node again'); + is($btree->getLeft(), $left, '... and it is what we told it to be'); +} + +{ + # remove left leaf + my $left_leaf = $btree->getLeft()->removeLeft(); + isa_ok($left_leaf, 'BinaryTree'); + + ok($left_leaf->isLeaf(), '... our left leaf is a leaf'); + + ok(!$btree->getLeft()->hasLeft(), '... we dont have a left leaf node anymore'); + + $btree->getLeft()->setLeft($left_leaf); + + ok($btree->getLeft()->hasLeft(), '... we have our left leaf node again'); + is($btree->getLeft()->getLeft(), $left_leaf, '... and it is what we told it to be'); +} + +{ + can_ok($btree, 'removeRight'); + my $right = $btree->removeRight(); + isa_ok($right, 'BinaryTree'); + + ok(!$btree->hasRight(), '... we dont have a right node anymore'); + ok(!$btree->isLeaf(), '... and we are not a leaf node'); + + $btree->setRight($right); + + ok($btree->hasRight(), '... we have our right node again'); + is($btree->getRight(), $right, '... and it is what we told it to be') +} + +{ + # remove right leaf + my $right_leaf = $btree->getRight()->removeRight(); + isa_ok($right_leaf, 'BinaryTree'); + + ok($right_leaf->isLeaf(), '... our right leaf is a leaf'); + + ok(!$btree->getRight()->hasRight(), '... we dont have a right leaf node anymore'); + + $btree->getRight()->setRight($right_leaf); + + ok($btree->getRight()->hasRight(), '... we have our right leaf node again'); + is($btree->getRight()->getRight(), $right_leaf, '... and it is what we told it to be'); +} + +# some of the recursive informational methods + +{ + + my $btree = BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ) + ->setRight( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ->setRight(BinaryTree->new("o")) + ) + ) + ) + ) + ->setRight( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ->setRight( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ) + ->setRight( + BinaryTree->new("o") + ) + ) + ) + ->setRight( + BinaryTree->new("o") + ->setRight(BinaryTree->new("o")) + ) + ); + isa_ok($btree, 'BinaryTree'); + + can_ok($btree, 'size'); + cmp_ok($btree->size(), '==', 14, '... we have 14 nodes in the tree'); + + can_ok($btree, 'height'); + cmp_ok($btree->height(), '==', 6, '... the tree is 6 nodes tall'); + +} + +## ---------------------------------------------------------------------------- +## t/13_Tree_Binary_mirror_test.t + +sub inOrderTraverse { + my $tree = shift; + my @results; + my $_inOrderTraverse = sub { + my ($tree, $traversal_function) = @_; + $traversal_function->($tree->getLeft(), $traversal_function) if $tree->hasLeft(); + push @results => $tree->getNodeValue(); + $traversal_function->($tree->getRight(), $traversal_function) if $tree->hasRight(); + }; + $_inOrderTraverse->($tree, $_inOrderTraverse); + @results; +} + +# test it on a simple well balanaced tree +{ + my $btree = BinaryTree->new(4) + ->setLeft( + BinaryTree->new(2) + ->setLeft( + BinaryTree->new(1) + ) + ->setRight( + BinaryTree->new(3) + ) + ) + ->setRight( + BinaryTree->new(6) + ->setLeft( + BinaryTree->new(5) + ) + ->setRight( + BinaryTree->new(7) + ) + ); + isa_ok($btree, 'BinaryTree'); + + is_deeply( + [ inOrderTraverse($btree) ], + [ 1 .. 7 ], + '... check that our tree starts out correctly'); + + can_ok($btree, 'mirror'); + $btree->mirror(); + + is_deeply( + [ inOrderTraverse($btree) ], + [ reverse(1 .. 7) ], + '... check that our tree ends up correctly'); +} + +# test is on a more chaotic tree +{ + my $btree = BinaryTree->new(4) + ->setLeft( + BinaryTree->new(20) + ->setLeft( + BinaryTree->new(1) + ->setRight( + BinaryTree->new(10) + ->setLeft( + BinaryTree->new(5) + ) + ) + ) + ->setRight( + BinaryTree->new(3) + ) + ) + ->setRight( + BinaryTree->new(6) + ->setLeft( + BinaryTree->new(5) + ->setRight( + BinaryTree->new(7) + ->setLeft( + BinaryTree->new(90) + ) + ->setRight( + BinaryTree->new(91) + ) + ) + ) + ); + isa_ok($btree, 'BinaryTree'); + + my @results = inOrderTraverse($btree); + + $btree->mirror(); + + is_deeply( + [ inOrderTraverse($btree) ], + [ reverse(@results) ], + '... this should be the reverse of the original'); +} + diff --git a/t/lib/BinaryTree.pm b/t/lib/BinaryTree.pm new file mode 100644 index 0000000..c73bfaf --- /dev/null +++ b/t/lib/BinaryTree.pm @@ -0,0 +1,171 @@ + +package BinaryTree; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use Class::MOP ':universal'; + +__PACKAGE__->meta->add_attribute( + Class::MOP::Attribute->new('_uid' => ( + reader => 'getUID', + writer => 'setUID', + default => sub { + my $instance = shift; + ("$instance" =~ /\((.*?)\)$/); + } + )) +); + +__PACKAGE__->meta->add_attribute( + Class::MOP::Attribute->new('_node' => ( + reader => 'getNodeValue', + writer => 'setNodeValue', + init_arg => ':node' + )) +); + +__PACKAGE__->meta->add_attribute( + Class::MOP::Attribute->new('_parent' => ( + reader => 'getParent', + writer => 'setParent', + predicate => { + 'isRoot' => sub { + my ($self) = @_; + return not defined $self->{_parent}; + } + } + )) +); + +__PACKAGE__->meta->add_attribute( + Class::MOP::Attribute->new('_left' => ( + predicate => 'hasLeft', + reader => 'getLeft', + writer => { + 'setLeft' => sub { + my ($self, $tree) = @_; + $tree->setParent($self); + $self->{_left} = $tree; + $tree->setDepth($self->getDepth() + 1); + $self; + } + }, + )) +); + +__PACKAGE__->meta->add_attribute( + Class::MOP::Attribute->new('_right' => ( + predicate => 'hasRight', + reader => 'getRight', + writer => { + 'setRight' => sub { + my ($self, $tree) = @_; + $tree->setParent($self); + $self->{_right} = $tree; + $tree->setDepth($self->getDepth() + 1); + $self; + } + } + )) +); + +__PACKAGE__->meta->add_attribute( + Class::MOP::Attribute->new('_depth' => ( + default => 0, + reader => 'getDepth', + writer => { + 'setDepth' => sub { + my ($self, $depth) = @_; + unless ($self->isLeaf()) { + $self->fixDepth(); + } + else { + $self->{_depth} = $depth; + } + } + } + )) +); + +sub new { + my $class = shift; + bless $class->meta->construct_instance(':node' => shift) => $class; +} + +sub removeLeft { + my ($self) = @_; + my $left = $self->{_left}; + $left->setParent(undef); + $left->setDepth(0); + $self->{_left} = undef; + return $left; +} + +sub removeRight { + my ($self) = @_; + my $right = $self->{_right}; + $right->setParent(undef); + $right->setDepth(0); + $self->{_right} = undef; + return $right; +} + +sub isLeaf { + my ($self) = @_; + return (!$self->hasLeft && !$self->hasRight); +} + +sub fixDepth { + my ($self) = @_; + # make sure the tree's depth + # is up to date all the way down + $self->traverse(sub { + my ($tree) = @_; + unless ($tree->isRoot()) { + $tree->{_depth} = $tree->getParent()->getDepth() + 1; + } + else { + $tree->{_depth} = 0; + } + } + ); +} + +sub traverse { + my ($self, $func) = @_; + $func->($self); + $self->{_left}->traverse($func) if defined $self->{_left}; + $self->{_right}->traverse($func) if defined $self->{_right}; +} + +sub mirror { + my ($self) = @_; + # swap left for right + my $temp = $self->{_left}; + $self->{_left} = $self->{_right}; + $self->{_right} = $temp; + # and recurse + $self->{_left}->mirror() if $self->hasLeft(); + $self->{_right}->mirror() if $self->hasRight(); + $self; +} + +sub size { + my ($self) = @_; + my $size = 1; + $size += $self->{_left}->size() if $self->hasLeft(); + $size += $self->{_right}->size() if $self->hasRight(); + return $size; +} + +sub height { + my ($self) = @_; + my ($left_height, $right_height) = (0, 0); + $left_height = $self->{_left}->height() if $self->hasLeft(); + $right_height = $self->{_right}->height() if $self->hasRight(); + return 1 + (($left_height > $right_height) ? $left_height : $right_height); +} +