use warnings;
use Carp 'confess';
-use Scalar::Util 'blessed';
+use Scalar::Util 'blessed', 'reftype';
use Class::MOP::Class;
use Class::MOP::Method;
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) = @_;
|| 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 {
|| 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;
=item B<writer>
+=item B<predicate>
+
=item B<init_arg>
=item B<default>
Returns true if this attribute has a writer, and false otherwise
+=item B<has_predicate>
+
+Returns true if this attribute has a predicate, and false otherwise
+
=item B<has_init_arg>
Returns true if this attribute has a class intialization argument, and
$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;
}
--- /dev/null
+#!/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');
+}
+
--- /dev/null
+
+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);
+}
+
projects / gitmo/Class-MOP.git / commitdiff