From: Guillermo Roditi Date: Tue, 6 Nov 2007 22:13:50 +0000 (+0000) Subject: predicate fixes X-Git-Tag: 0_44~3^2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8d2d4c6705a3781606464d003a3641d835a35815;p=gitmo%2FClass-MOP.git predicate fixes --- diff --git a/examples/ArrayBasedStorage.pod b/examples/ArrayBasedStorage.pod index cd4dc1e..daf2eed 100644 --- a/examples/ArrayBasedStorage.pod +++ b/examples/ArrayBasedStorage.pod @@ -4,10 +4,12 @@ package # hide the package from PAUSE use strict; use warnings; +use Scalar::Util qw/refaddr/; use Carp 'confess'; our $VERSION = '0.01'; +my $unbound = \'empty-slot-value'; use base 'Class::MOP::Instance'; @@ -21,7 +23,9 @@ sub new { sub create_instance { my $self = shift; - $self->bless_instance_structure([]); + my $instance = $self->bless_instance_structure([]); + $self->initialize_all_slots($instance); + return $instance; } sub clone_instance { @@ -33,6 +37,16 @@ sub clone_instance { sub get_slot_index_map { (shift)->{'%!slot_index_map'} } +sub initialize_slot { + my ($self, $instance, $slot_name) = @_; + $self->set_slot_value($instance, $slot_name, $unbound); +} + +sub deinitialize_slot { + my ( $self, $instance, $slot_name ) = @_; + $self->set_slot_value($instance, $slot_name, $unbound); +} + sub get_all_slots { my $self = shift; return sort $self->SUPER::get_all_slots; @@ -40,7 +54,9 @@ sub get_all_slots { sub get_slot_value { my ($self, $instance, $slot_name) = @_; - return $instance->[ $self->{'%!slot_index_map'}->{$slot_name} ]; + my $value = $instance->[ $self->{'%!slot_index_map'}->{$slot_name} ]; + return $value unless ref $value; + refaddr $value eq refaddr $unbound ? undef : $value; } sub set_slot_value { @@ -49,10 +65,11 @@ sub set_slot_value { } sub is_slot_initialized { - # NOTE: - # maybe use CLOS's *special-unbound-value* - # for this ? - confess "Cannot really tell this for sure"; + my ($self, $instance, $slot_name) = @_; + # NOTE: maybe use CLOS's *special-unbound-value* for this? + my $value = $instance->[ $self->{'%!slot_index_map'}->{$slot_name} ]; + return 1 unless ref $value; + refaddr $value eq refaddr $unbound ? 0 : 1; } 1; diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index a91473f..559d282 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -85,20 +85,20 @@ sub initialize_instance_slot { my ($self, $meta_instance, $instance, $params) = @_; my $init_arg = $self->{'$!init_arg'}; # try to fetch the init arg from the %params ... - my $val; - $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) - if (!defined $val && defined $self->{'$!default'}) { - $val = $self->default($instance); - } elsif (!defined $val && defined( my $builder = $self->{'$!builder'})) { + if(exists $params->{$init_arg}){ + $meta_instance->set_slot_value($instance, $self->name, $params->{$init_arg}); + } elsif (defined $self->{'$!default'}) { + $meta_instance->set_slot_value($instance, $self->name, $self->default($instance)); + } elsif (defined( my $builder = $self->{'$!builder'})) { if($builder = $instance->can($builder) ){ - $val = $instance->$builder; + $meta_instance->set_slot_value($instance, $self->name, $instance->$builder); } else { confess(blessed($instance)." does not support builder method '$builder' for attribute '" . $self->name . "'"); } } - $meta_instance->set_slot_value($instance, $self->name, $val); } # NOTE: @@ -195,9 +195,9 @@ sub get_value { sub has_value { my ($self, $instance) = @_; - defined Class::MOP::Class->initialize(blessed($instance)) - ->get_meta_instance - ->get_slot_value($instance, $self->name) ? 1 : 0; + Class::MOP::Class->initialize(blessed($instance)) + ->get_meta_instance + ->is_slot_initialized($instance, $self->name); } sub clear_value { diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm index 5af57b3..008815e 100644 --- a/lib/Class/MOP/Instance.pm +++ b/lib/Class/MOP/Instance.pm @@ -9,31 +9,31 @@ use Scalar::Util 'weaken', 'blessed'; our $VERSION = '0.03'; our $AUTHORITY = 'cpan:STEVAN'; -sub meta { +sub meta { require Class::MOP::Class; Class::MOP::Class->initialize(blessed($_[0]) || $_[0]); } -sub new { +sub new { my ($class, $meta, @attrs) = @_; my @slots = map { $_->slots } @attrs; my $instance = bless { # NOTE: # I am not sure that it makes # sense to pass in the meta - # The ideal would be to just - # pass in the class name, but - # that is placing too much of - # an assumption on bless(), + # The ideal would be to just + # pass in the class name, but + # that is placing too much of + # an assumption on bless(), # which is *probably* a safe - # assumption,.. but you can + # assumption,.. but you can # never tell <:) '$!meta' => $meta, '@!slots' => { map { $_ => undef } @slots }, - } => $class; - + } => $class; + weaken($instance->{'$!meta'}); - + return $instance; } @@ -70,7 +70,7 @@ sub is_valid_slot { sub get_slot_value { my ($self, $instance, $slot_name) = @_; - return $instance->{$slot_name}; + $self->is_slot_initialized($instance, $slot_name) ? $instance->{$slot_name} : undef; } sub set_slot_value { @@ -80,7 +80,7 @@ sub set_slot_value { sub initialize_slot { my ($self, $instance, $slot_name) = @_; - $self->set_slot_value($instance, $slot_name, undef); + #$self->set_slot_value($instance, $slot_name, undef); } sub deinitialize_slot { @@ -108,13 +108,13 @@ sub is_slot_initialized { } sub weaken_slot_value { - my ($self, $instance, $slot_name) = @_; - weaken $instance->{$slot_name}; + my ($self, $instance, $slot_name) = @_; + weaken $instance->{$slot_name}; } sub strengthen_slot_value { - my ($self, $instance, $slot_name) = @_; - $self->set_slot_value($instance, $slot_name, $self->get_slot_value($instance, $slot_name)); + my ($self, $instance, $slot_name) = @_; + $self->set_slot_value($instance, $slot_name, $self->get_slot_value($instance, $slot_name)); } # inlinable operation snippets @@ -133,12 +133,13 @@ sub inline_slot_access { sub inline_get_slot_value { my ($self, $instance, $slot_name) = @_; - $self->inline_slot_access($instance, $slot_name); + 'exists ' . $self->inline_slot_access($instance, $slot_name) . + ' ? ' . $self->inline_slot_access($instance, $slot_name) . ' : undef' } sub inline_set_slot_value { my ($self, $instance, $slot_name, $value) = @_; - $self->inline_slot_access($instance, $slot_name) . " = $value", + $self->inline_slot_access($instance, $slot_name) . " = $value", } sub inline_initialize_slot { @@ -171,37 +172,37 @@ __END__ =pod -=head1 NAME +=head1 NAME Class::MOP::Instance - Instance Meta Object =head1 SYNOPSIS - # for the most part, this protocol is internal - # and not for public usage, but this how one + # for the most part, this protocol is internal + # and not for public usage, but this how one # might use it - + package Foo; - + use strict; use warnings; use metaclass ( ':instance_metaclass' => 'ArrayBasedStorage::Instance', ); - + # now Foo->new produces blessed ARRAY ref based objects =head1 DESCRIPTION -This is a sub-protocol which governs instance creation +This is a sub-protocol which governs instance creation and access to the slots of the instance structure. -This may seem like over-abstraction, but by abstracting -this process into a sub-protocol we make it possible to -easily switch the details of how an object's instance is -stored with minimal impact. In most cases just subclassing -this class will be all you need to do (see the examples; -F and +This may seem like over-abstraction, but by abstracting +this process into a sub-protocol we make it possible to +easily switch the details of how an object's instance is +stored with minimal impact. In most cases just subclassing +this class will be all you need to do (see the examples; +F and F for details). =head1 METHODS @@ -210,12 +211,12 @@ F for details). =item B -Creates a new instance meta-object and gathers all the slots from +Creates a new instance meta-object and gathers all the slots from the list of C<@attrs> given. =item B -This will return a B instance which is related +This will return a B instance which is related to this class. =back @@ -226,7 +227,7 @@ to this class. =item B -This creates the appropriate structure needed for the instance and +This creates the appropriate structure needed for the instance and then calls C to bless it into the class. =item B @@ -239,7 +240,7 @@ This does just exactly what it says it does. =head2 Instrospection -NOTE: There might be more methods added to this part of the API, +NOTE: There might be more methods added to this part of the API, we will add then when we need them basically. =over 4 @@ -248,7 +249,7 @@ we will add then when we need them basically. =item B -This will return the current list of slots based on what was +This will return the current list of slots based on what was given to this object in C. =item B @@ -257,9 +258,9 @@ given to this object in C. =head2 Operations on Instance Structures -An important distinction of this sub-protocol is that the -instance meta-object is a different entity from the actual -instance it creates. For this reason, any actions on slots +An important distinction of this sub-protocol is that the +instance meta-object is a different entity from the actual +instance it creates. For this reason, any actions on slots require that the C<$instance_structure> is passed into them. =over 4 @@ -286,18 +287,18 @@ require that the C<$instance_structure> is passed into them. =head2 Inlineable Instance Operations -This part of the API is currently un-used. It is there for use -in future experiments in class finailization mostly. Best to +This part of the API is currently un-used. It is there for use +in future experiments in class finailization mostly. Best to ignore this for now. =over 4 =item B -Each meta-instance should override this method to tell Class::MOP if it's -possible to inline the slot access. +Each meta-instance should override this method to tell Class::MOP if it's +possible to inline the slot access. -This is currently only used by Class::MOP::Class::Immutable when performing +This is currently only used by Class::MOP::Class::Immutable when performing optimizations. =item B @@ -333,7 +334,7 @@ Copyright 2006, 2007 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. +it under the same terms as Perl itself. =cut diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm index 73d907a..6d4f5d5 100644 --- a/lib/Class/MOP/Method/Accessor.pm +++ b/lib/Class/MOP/Method/Accessor.pm @@ -15,32 +15,32 @@ use base 'Class::MOP::Method::Generated'; sub new { my $class = shift; my %options = @_; - + (exists $options{attribute}) || confess "You must supply an attribute to construct with"; - + (exists $options{accessor_type}) - || confess "You must supply an accessor_type to construct with"; - + || confess "You must supply an accessor_type to construct with"; + (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute')) - || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance"; - + || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance"; + my $self = bless { # from our superclass '&!body' => undef, # specific to this subclass '$!attribute' => $options{attribute}, '$!is_inline' => ($options{is_inline} || 0), - '$!accessor_type' => $options{accessor_type}, + '$!accessor_type' => $options{accessor_type}, } => $class; - - # we don't want this creating - # a cycle in the code, if not + + # we don't want this creating + # a cycle in the code, if not # needed weaken($self->{'$!attribute'}); - + $self->initialize_body; - + return $self; } @@ -49,18 +49,18 @@ sub new { sub associated_attribute { (shift)->{'$!attribute'} } sub accessor_type { (shift)->{'$!accessor_type'} } -## factory +## factory sub initialize_body { my $self = shift; - + my $method_name = join "_" => ( - 'generate', - $self->accessor_type, + 'generate', + $self->accessor_type, 'method', ($self->is_inline ? 'inline' : ()) ); - + eval { $self->{'&!body'} = $self->$method_name() }; die $@ if $@; } @@ -68,7 +68,7 @@ sub initialize_body { ## generators sub generate_accessor_method { - my $attr = (shift)->associated_attribute; + my $attr = (shift)->associated_attribute; return sub { $attr->set_value($_[0], $_[1]) if scalar(@_) == 2; $attr->get_value($_[0]); @@ -76,30 +76,30 @@ sub generate_accessor_method { } sub generate_reader_method { - my $attr = (shift)->associated_attribute; - return sub { + my $attr = (shift)->associated_attribute; + return sub { confess "Cannot assign a value to a read-only accessor" if @_ > 1; $attr->get_value($_[0]); - }; + }; } sub generate_writer_method { - my $attr = (shift)->associated_attribute; + my $attr = (shift)->associated_attribute; return sub { $attr->set_value($_[0], $_[1]); }; } sub generate_predicate_method { - my $attr = (shift)->associated_attribute; - return sub { + my $attr = (shift)->associated_attribute; + return sub { $attr->has_value($_[0]) }; } sub generate_clearer_method { - my $attr = (shift)->associated_attribute; - return sub { + my $attr = (shift)->associated_attribute; + return sub { $attr->clear_value($_[0]) }; } @@ -108,7 +108,7 @@ sub generate_clearer_method { sub generate_accessor_method_inline { - my $attr = (shift)->associated_attribute; + my $attr = (shift)->associated_attribute; my $attr_name = $attr->name; my $meta_instance = $attr->associated_class->instance_metaclass; @@ -122,7 +122,7 @@ sub generate_accessor_method_inline { } sub generate_reader_method_inline { - my $attr = (shift)->associated_attribute; + my $attr = (shift)->associated_attribute; my $attr_name = $attr->name; my $meta_instance = $attr->associated_class->instance_metaclass; @@ -136,7 +136,7 @@ sub generate_reader_method_inline { } sub generate_writer_method_inline { - my $attr = (shift)->associated_attribute; + my $attr = (shift)->associated_attribute; my $attr_name = $attr->name; my $meta_instance = $attr->associated_class->instance_metaclass; @@ -150,12 +150,12 @@ sub generate_writer_method_inline { sub generate_predicate_method_inline { - my $attr = (shift)->associated_attribute; + my $attr = (shift)->associated_attribute; my $attr_name = $attr->name; my $meta_instance = $attr->associated_class->instance_metaclass; - my $code = eval 'sub {' - . 'defined ' . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'") . ' ? 1 : 0' + my $code = eval 'sub {' . + $meta_instance->inline_is_slot_initialized('$_[0]', "'$attr_name'") . '}'; confess "Could not generate inline predicate because : $@" if $@; @@ -163,7 +163,7 @@ sub generate_predicate_method_inline { } sub generate_clearer_method_inline { - my $attr = (shift)->associated_attribute; + my $attr = (shift)->associated_attribute; my $attr_name = $attr->name; my $meta_instance = $attr->associated_class->instance_metaclass; @@ -181,7 +181,7 @@ __END__ =pod -=head1 NAME +=head1 NAME Class::MOP::Method::Accessor - Method Meta Object for accessors @@ -194,14 +194,14 @@ Class::MOP::Method::Accessor - Method Meta Object for accessors is_inline => 1, accessor_type => 'reader', ); - + $reader->body->($instance); # call the reader method =head1 DESCRIPTION -This is a C subclass which is used interally -by C to generate accessor code. It can -handle generation of readers, writers, predicate and clearer +This is a C subclass which is used interally +by C to generate accessor code. It can +handle generation of readers, writers, predicate and clearer methods, both as closures and as more optimized inline methods. =head1 METHODS @@ -210,20 +210,20 @@ methods, both as closures and as more optimized inline methods. =item B -This creates the method based on the criteria in C<%options>, +This creates the method based on the criteria in C<%options>, these options are: =over 4 =item I -This must be an instance of C which this +This must be an instance of C which this accessor is being generated for. This paramter is B. =item I -This is a string from the following set; reader, writer, accessor, -predicate or clearer. This is used to determine which type of +This is a string from the following set; reader, writer, accessor, +predicate or clearer. This is used to determine which type of method is to be generated. =item I @@ -247,15 +247,15 @@ This returns the attribute instance which was passed into C. =item B -This will actually generate the method based on the specified +This will actually generate the method based on the specified criteria passed to the constructor. =back =head2 Method Generators -These methods will generate appropriate code references for -the various types of accessors which are supported by +These methods will generate appropriate code references for +the various types of accessors which are supported by C. The names pretty much explain it all. =over 4 @@ -293,7 +293,7 @@ Copyright 2006, 2007 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. +it under the same terms as Perl itself. =cut diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm index 75e3ec2..1f5cae0 100644 --- a/lib/Class/MOP/Method/Constructor.pm +++ b/lib/Class/MOP/Method/Constructor.pm @@ -15,43 +15,43 @@ use base 'Class::MOP::Method::Generated'; sub new { my $class = shift; my %options = @_; - + (blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class')) || confess "You must pass a metaclass instance if you want to inline" - if $options{is_inline}; - + if $options{is_inline}; + my $self = bless { # from our superclass '&!body' => undef, # specific to this subclass '%!options' => $options{options} || {}, '$!associated_metaclass' => $options{metaclass}, - '$!is_inline' => ($options{is_inline} || 0), + '$!is_inline' => ($options{is_inline} || 0), } => $class; - # we don't want this creating - # a cycle in the code, if not + # we don't want this creating + # a cycle in the code, if not # needed - weaken($self->{'$!associated_metaclass'}); + weaken($self->{'$!associated_metaclass'}); $self->initialize_body; - return $self; + return $self; } -## accessors +## accessors sub options { (shift)->{'%!options'} } sub associated_metaclass { (shift)->{'$!associated_metaclass'} } ## cached values ... -sub meta_instance { +sub meta_instance { my $self = shift; $self->{'$!meta_instance'} ||= $self->associated_metaclass->get_meta_instance; } -sub attributes { +sub attributes { my $self = shift; $self->{'@!attributes'} ||= [ $self->associated_metaclass->compute_all_applicable_attributes ] } @@ -61,9 +61,9 @@ sub attributes { sub initialize_body { my $self = shift; my $method_name = 'generate_constructor_method'; - + $method_name .= '_inline' if $self->is_inline; - + $self->{'&!body'} = $self->$method_name; } @@ -76,25 +76,25 @@ sub generate_constructor_method_inline { my $source = 'sub {'; $source .= "\n" . 'my ($class, %params) = @_;'; - + $source .= "\n" . 'return $class->meta->new_object(%params)'; - $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';'; - + $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';'; + $source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class'); - $source .= ";\n" . (join ";\n" => map { - $self->_generate_slot_initializer($_) + $source .= ";\n" . (join ";\n" => map { + $self->_generate_slot_initializer($_) } 0 .. (@{$self->attributes} - 1)); $source .= ";\n" . 'return $instance'; - $source .= ";\n" . '}'; - warn $source if $self->options->{debug}; - + $source .= ";\n" . '}'; + warn $source if $self->options->{debug}; + my $code; { # NOTE: # create the nessecary lexicals - # to be picked up in the eval + # to be picked up in the eval my $attrs = $self->attributes; - + $code = eval $source; confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@; } @@ -104,14 +104,14 @@ sub generate_constructor_method_inline { sub _generate_slot_initializer { my $self = shift; my $index = shift; - + my $attr = $self->attributes->[$index]; - + my $default; if ($attr->has_default) { # NOTE: # default values can either be CODE refs - # in which case we need to call them. Or + # in which case we need to call them. Or # they can be scalars (strings/numbers) # in which case we can just deal with them # in the code we eval. @@ -125,12 +125,21 @@ sub _generate_slot_initializer { $default = "'$default'"; } } + } elsif( $attr->has_builder ) { + $default = '$instance->'.$attr->builder; } - $self->meta_instance->inline_set_slot_value( - '$instance', - ("'" . $attr->name . "'"), - ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : '')) - ); + + 'if(exists $params{\'' . $attr->init_arg . '\'}){' . "\n" . + $self->meta_instance->inline_set_slot_value( + '$instance', + ("'" . $attr->name . "'"), + '$params{\'' . $attr->init_arg . '\'}' ) . "\n" . + '} ' . (!defined $default ? '' : 'else {' . "\n" . + $self->meta_instance->inline_set_slot_value( + '$instance', + ("'" . $attr->name . "'"), + $default ) . "\n" . + '}'); } 1; @@ -141,28 +150,28 @@ __END__ =pod -=head1 NAME +=head1 NAME Class::MOP::Method::Constructor - Method Meta Object for constructors =head1 SYNOPSIS use Class::MOP::Method::Constructor; - + my $constructor = Class::MOP::Method::Constructor->new( - metaclass => $metaclass, + metaclass => $metaclass, options => { debug => 1, # this is all for now - }, + }, ); - + # calling the constructor ... $constructor->body->($metaclass->name, %params); - + =head1 DESCRIPTION -This is a subclass of C which deals with -class constructors. +This is a subclass of C which deals with +class constructors. =head1 METHODS @@ -180,22 +189,22 @@ This returns the metaclass which is passed into C. =item B -This returns the list of attributes which are associated with the +This returns the list of attributes which are associated with the metaclass which is passed into C. =item B -This returns the meta instance which is associated with the +This returns the meta instance which is associated with the metaclass which is passed into C. =item B -This returns a boolean, but since constructors are very rarely +This returns a boolean, but since constructors are very rarely not inlined, this always returns true for now. =item B -This creates the code reference for the constructor itself. +This creates the code reference for the constructor itself. =back @@ -220,7 +229,7 @@ Copyright 2006, 2007 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. +it under the same terms as Perl itself. =cut diff --git a/t/061_instance_inline.t b/t/061_instance_inline.t index 3e8c89f..ec35302 100644 --- a/t/061_instance_inline.t +++ b/t/061_instance_inline.t @@ -7,7 +7,7 @@ use Test::More tests => 16; use Test::Exception; BEGIN { - use_ok('Class::MOP::Instance'); + use_ok('Class::MOP::Instance'); } my $C = 'Class::MOP::Instance'; @@ -17,92 +17,92 @@ my $C = 'Class::MOP::Instance'; my $slot_name = '"foo"'; my $value = '$value'; - is($C->inline_get_slot_value($instance, $slot_name), - '$self->{"foo"}', + is($C->inline_get_slot_value($instance, $slot_name), + 'exists $self->{"foo"} ? $self->{"foo"} : undef', '... got the right code for get_slot_value'); - - is($C->inline_set_slot_value($instance, $slot_name, $value), + + is($C->inline_set_slot_value($instance, $slot_name, $value), '$self->{"foo"} = $value', - '... got the right code for set_slot_value'); + '... got the right code for set_slot_value'); - is($C->inline_initialize_slot($instance, $slot_name), + is($C->inline_initialize_slot($instance, $slot_name), '$self->{"foo"} = undef', '... got the right code for initialize_slot'); - - is($C->inline_is_slot_initialized($instance, $slot_name), + + is($C->inline_is_slot_initialized($instance, $slot_name), 'exists $self->{"foo"} ? 1 : 0', - '... got the right code for get_slot_value'); - - is($C->inline_weaken_slot_value($instance, $slot_name), + '... got the right code for get_slot_value'); + + is($C->inline_weaken_slot_value($instance, $slot_name), 'Scalar::Util::weaken( $self->{"foo"} )', - '... got the right code for weaken_slot_value'); - - is($C->inline_strengthen_slot_value($instance, $slot_name), + '... got the right code for weaken_slot_value'); + + is($C->inline_strengthen_slot_value($instance, $slot_name), '$self->{"foo"} = $self->{"foo"}', - '... got the right code for strengthen_slot_value'); -} - + '... got the right code for strengthen_slot_value'); +} + { my $instance = '$_[0]'; my $slot_name = '$attr_name'; my $value = '[]'; - is($C->inline_get_slot_value($instance, $slot_name), - '$_[0]->{$attr_name}', + is($C->inline_get_slot_value($instance, $slot_name), + 'exists $_[0]->{$attr_name} ? $_[0]->{$attr_name} : undef', '... got the right code for get_slot_value'); - - is($C->inline_set_slot_value($instance, $slot_name, $value), + + is($C->inline_set_slot_value($instance, $slot_name, $value), '$_[0]->{$attr_name} = []', - '... got the right code for set_slot_value'); - - is($C->inline_initialize_slot($instance, $slot_name), + '... got the right code for set_slot_value'); + + is($C->inline_initialize_slot($instance, $slot_name), '$_[0]->{$attr_name} = undef', - '... got the right code for initialize_slot'); - - is($C->inline_is_slot_initialized($instance, $slot_name), + '... got the right code for initialize_slot'); + + is($C->inline_is_slot_initialized($instance, $slot_name), 'exists $_[0]->{$attr_name} ? 1 : 0', - '... got the right code for get_slot_value'); - - is($C->inline_weaken_slot_value($instance, $slot_name), + '... got the right code for get_slot_value'); + + is($C->inline_weaken_slot_value($instance, $slot_name), 'Scalar::Util::weaken( $_[0]->{$attr_name} )', - '... got the right code for weaken_slot_value'); - - is($C->inline_strengthen_slot_value($instance, $slot_name), + '... got the right code for weaken_slot_value'); + + is($C->inline_strengthen_slot_value($instance, $slot_name), '$_[0]->{$attr_name} = $_[0]->{$attr_name}', - '... got the right code for strengthen_slot_value'); -} - + '... got the right code for strengthen_slot_value'); +} + my $accessor_string = "sub {\n" . $C->inline_set_slot_value('$_[0]', '$attr_name', '$_[1]') . " if scalar \@_ == 2;\n" . $C->inline_get_slot_value('$_[0]', '$attr_name') . ";\n}"; -is($accessor_string, +is($accessor_string, q|sub { $_[0]->{$attr_name} = $_[1] if scalar @_ == 2; -$_[0]->{$attr_name}; -}|, +exists $_[0]->{$attr_name} ? $_[0]->{$attr_name} : undef; +}|, '... got the right code string for accessor'); my $reader_string = "sub {\n" . $C->inline_get_slot_value('$_[0]', '$attr_name') . ";\n}"; -is($reader_string, +is($reader_string, q|sub { -$_[0]->{$attr_name}; -}|, +exists $_[0]->{$attr_name} ? $_[0]->{$attr_name} : undef; +}|, '... got the right code string for reader'); - + my $writer_string = "sub {\n" . $C->inline_set_slot_value('$_[0]', '$attr_name', '$_[1]') . ";\n}"; -is($writer_string, +is($writer_string, q|sub { $_[0]->{$attr_name} = $_[1]; -}|, - '... got the right code string for writer'); - - \ No newline at end of file +}|, + '... got the right code string for writer'); + + diff --git a/t/100_BinaryTree_test.t b/t/100_BinaryTree_test.t index 704fd4d..0e84509 100644 --- a/t/100_BinaryTree_test.t +++ b/t/100_BinaryTree_test.t @@ -9,8 +9,8 @@ use File::Spec::Functions; use Test::More tests => 70; use Test::Exception; -BEGIN { - use_ok('Class::MOP'); +BEGIN { + use_ok('Class::MOP'); } use lib catdir($FindBin::Bin, 'lib'); @@ -76,7 +76,7 @@ can_ok($btree, 'getUID'); { my $UID = $btree->getUID(); - is(("$btree" =~ /\((.*?)\)$/), $UID, '... our UID is derived from the stringified object'); + is(("$btree" =~ /\((.*?)\)$/)[0], $UID, '... our UID is derived from the stringified object'); } can_ok($btree, 'getNodeValue'); @@ -85,33 +85,33 @@ 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'); - + + can_ok($left, 'getParent'); + my $parent = $left->getParent(); isa_ok($parent, 'BinaryTree'); - - is($parent, $btree, '.. got what we expected'); + + 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'); + + is($parent, $btree, '.. got what we expected'); } ## mutators @@ -131,13 +131,13 @@ 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'); + + ok($btree->hasLeft(), '... we have our left node again'); is($btree->getLeft(), $left, '... and it is what we told it to be'); } @@ -145,14 +145,14 @@ is($btree->getNodeValue(), '*', '... got what we expected'); # 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'); + + 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'); } @@ -160,28 +160,28 @@ is($btree->getNodeValue(), '*', '... got what we expected'); 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'); - + 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') + + 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'); + + 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'); } @@ -226,10 +226,10 @@ is($btree->getNodeValue(), '*', '... got what we expected'); ) ); 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'); @@ -243,8 +243,8 @@ sub inOrderTraverse { 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->getLeft(), $traversal_function) if $tree->hasLeft(); + push @results => $tree->getNodeValue(); $traversal_function->($tree->getRight(), $traversal_function) if $tree->hasRight(); }; $_inOrderTraverse->($tree, $_inOrderTraverse); @@ -257,7 +257,7 @@ sub inOrderTraverse { ->setLeft( BinaryTree->new(2) ->setLeft( - BinaryTree->new(1) + BinaryTree->new(1) ) ->setRight( BinaryTree->new(3) @@ -266,22 +266,22 @@ sub inOrderTraverse { ->setRight( BinaryTree->new(6) ->setLeft( - BinaryTree->new(5) + 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) ], @@ -296,10 +296,10 @@ sub inOrderTraverse { ->setLeft( BinaryTree->new(1) ->setRight( - BinaryTree->new(10) + BinaryTree->new(10) ->setLeft( - BinaryTree->new(5) - ) + BinaryTree->new(5) + ) ) ) ->setRight( @@ -309,24 +309,24 @@ sub inOrderTraverse { ->setRight( BinaryTree->new(6) ->setLeft( - BinaryTree->new(5) + 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) ], diff --git a/t/108_ArrayBasedStorage_test.t b/t/108_ArrayBasedStorage_test.t index 0757a61..43e079f 100644 --- a/t/108_ArrayBasedStorage_test.t +++ b/t/108_ArrayBasedStorage_test.t @@ -3,71 +3,72 @@ use strict; use warnings; -use Test::More tests => 69; +use Test::More tests => 72; use File::Spec; use Scalar::Util 'reftype'; -BEGIN { - use_ok('Class::MOP'); +BEGIN { + use_ok('Class::MOP'); require_ok(File::Spec->catdir('examples', 'ArrayBasedStorage.pod')); } { package Foo; - + use strict; - use warnings; + use warnings; use metaclass ( 'instance_metaclass' => 'ArrayBasedStorage::Instance', ); - + Foo->meta->add_attribute('foo' => ( accessor => 'foo', + clearer => 'clear_foo', predicate => 'has_foo', )); - + Foo->meta->add_attribute('bar' => ( reader => 'get_bar', writer => 'set_bar', - default => 'FOO is BAR' + default => 'FOO is BAR' )); - + sub new { my $class = shift; $class->meta->new_object(@_); } - + package Bar; - + use strict; use warnings; - + use base 'Foo'; - + Bar->meta->add_attribute('baz' => ( accessor => 'baz', predicate => 'has_baz', - )); - + )); + package Baz; - + use strict; use warnings; - use metaclass ( + use metaclass ( 'instance_metaclass' => 'ArrayBasedStorage::Instance', ); - + Baz->meta->add_attribute('bling' => ( accessor => 'bling', default => 'Baz::bling' - )); - + )); + package Bar::Baz; - + use strict; use warnings; - - use base 'Bar', 'Baz'; + + use base 'Bar', 'Baz'; } my $foo = Foo->new(); @@ -79,6 +80,7 @@ can_ok($foo, 'foo'); can_ok($foo, 'has_foo'); can_ok($foo, 'get_bar'); can_ok($foo, 'set_bar'); +can_ok($foo, 'clear_foo'); ok(!$foo->has_foo, '... Foo::foo is not defined yet'); is($foo->foo(), undef, '... Foo::foo is not defined yet'); @@ -89,6 +91,11 @@ $foo->foo('This is Foo'); ok($foo->has_foo, '... Foo::foo is defined now'); is($foo->foo(), 'This is Foo', '... Foo::foo == "This is Foo"'); +$foo->clear_foo; + +ok(!$foo->has_foo, '... Foo::foo is not defined anymore'); +is($foo->foo(), undef, '... Foo::foo is not defined anymore'); + $foo->set_bar(42); is($foo->get_bar(), 42, '... Foo::bar == 42'); diff --git a/t/lib/BinaryTree.pm b/t/lib/BinaryTree.pm index 4fb45bd..23f5863 100644 --- a/t/lib/BinaryTree.pm +++ b/t/lib/BinaryTree.pm @@ -3,6 +3,7 @@ package BinaryTree; use strict; use warnings; +use Carp qw/confess/; use metaclass; @@ -11,105 +12,123 @@ our $VERSION = '0.02'; BinaryTree->meta->add_attribute('$:uid' => ( reader => 'getUID', writer => 'setUID', - default => sub { + default => sub { my $instance = shift; - ("$instance" =~ /\((.*?)\)$/); + ("$instance" =~ /\((.*?)\)$/)[0]; } )); BinaryTree->meta->add_attribute('$:node' => ( reader => 'getNodeValue', writer => 'setNodeValue', + clearer => 'clearNodeValue', init_arg => ':node' )); BinaryTree->meta->add_attribute('$:parent' => ( predicate => 'hasParent', reader => 'getParent', - writer => 'setParent' + writer => 'setParent', + clearer => 'clearParent', )); BinaryTree->meta->add_attribute('$:left' => ( - predicate => 'hasLeft', + predicate => 'hasLeft', + clearer => 'clearLeft', reader => 'getLeft', - writer => { + writer => { 'setLeft' => sub { my ($self, $tree) = @_; - $tree->setParent($self) if defined $tree; - $self->{'$:left'} = $tree; - $self; + confess "undef left" unless defined $tree; + $tree->setParent($self) if defined $tree; + $self->{'$:left'} = $tree; + $self; } }, )); BinaryTree->meta->add_attribute('$:right' => ( - predicate => 'hasRight', + predicate => 'hasRight', + clearer => 'clearRight', reader => 'getRight', writer => { 'setRight' => sub { - my ($self, $tree) = @_; - $tree->setParent($self) if defined $tree; - $self->{'$:right'} = $tree; - $self; + my ($self, $tree) = @_; + confess "undef right" unless defined $tree; + $tree->setParent($self) if defined $tree; + $self->{'$:right'} = $tree; + $self; } } )); sub new { my $class = shift; - $class->meta->new_object(':node' => shift); -} - + $class->meta->new_object(':node' => shift); +} + sub removeLeft { my ($self) = @_; my $left = $self->getLeft(); - $left->setParent(undef); - $self->setLeft(undef); + $left->clearParent; + $self->clearLeft; return $left; } sub removeRight { my ($self) = @_; my $right = $self->getRight; - $right->setParent(undef); - $self->setRight(undef); + $right->clearParent; + $self->clearRight; return $right; } - + sub isLeaf { - my ($self) = @_; - return (!$self->hasLeft && !$self->hasRight); + my ($self) = @_; + return (!$self->hasLeft && !$self->hasRight); } sub isRoot { - my ($self) = @_; - return !$self->hasParent; + my ($self) = @_; + return !$self->hasParent; } - + sub traverse { - my ($self, $func) = @_; + my ($self, $func) = @_; $func->($self); - $self->getLeft->traverse($func) if $self->hasLeft; + $self->getLeft->traverse($func) if $self->hasLeft; $self->getRight->traverse($func) if $self->hasRight; } sub mirror { my ($self) = @_; # swap left for right - my $left = $self->getLeft; - $self->setLeft($self->getRight()); - $self->setRight($left); + if( $self->hasLeft && $self->hasRight) { + my $left = $self->getLeft; + my $right = $self->getRight; + $self->setLeft($right); + $self->setRight($left); + } elsif( $self->hasLeft && !$self->hasRight){ + my $left = $self->getLeft; + $self->clearLeft; + $self->setRight($left); + } elsif( !$self->hasLeft && $self->hasRight){ + my $right = $self->getRight; + $self->clearRight; + $self->setLeft($right); + } + # and recurse - $self->getLeft->mirror() if $self->hasLeft(); - $self->getRight->mirror() if $self->hasRight(); + $self->getLeft->mirror if $self->hasLeft; + $self->getRight->mirror if $self->hasRight; $self; } sub size { my ($self) = @_; my $size = 1; - $size += $self->getLeft->size() if $self->hasLeft(); - $size += $self->getRight->size() if $self->hasRight(); + $size += $self->getLeft->size if $self->hasLeft; + $size += $self->getRight->size if $self->hasRight; return $size; } @@ -117,8 +136,8 @@ sub height { my ($self) = @_; my ($left_height, $right_height) = (0, 0); $left_height = $self->getLeft->height() if $self->hasLeft(); - $right_height = $self->getRight->height() if $self->hasRight(); + $right_height = $self->getRight->height() if $self->hasRight(); return 1 + (($left_height > $right_height) ? $left_height : $right_height); -} +} -1; \ No newline at end of file +1;