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';
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 {
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;
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 {
}
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;
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:
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 {
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;
}
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 {
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 {
}
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
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 {
=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<examples/ArrayBasedStorage.pod> 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<examples/ArrayBasedStorage.pod> and
F<examples/InsideOutClass.pod> for details).
=head1 METHODS
=item B<new ($meta, @attrs)>
-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<meta>
-This will return a B<Class::MOP::Class> instance which is related
+This will return a B<Class::MOP::Class> instance which is related
to this class.
=back
=item B<create_instance>
-This creates the appropriate structure needed for the instance and
+This creates the appropriate structure needed for the instance and
then calls C<bless_instance_structure> to bless it into the class.
=item B<bless_instance_structure ($instance_structure)>
=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
=item B<get_all_slots>
-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<new>.
=item B<is_valid_slot ($slot_name)>
=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
=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<is_inlinable>
-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<inline_create_instance>
L<http://www.iinteractive.com>
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
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;
}
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 $@;
}
## 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]);
}
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])
};
}
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;
}
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;
}
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;
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 $@;
}
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;
=pod
-=head1 NAME
+=head1 NAME
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<Class::MOP::Method> subclass which is used interally
-by C<Class::MOP::Attribute> to generate accessor code. It can
-handle generation of readers, writers, predicate and clearer
+This is a C<Class::MOP::Method> subclass which is used interally
+by C<Class::MOP::Attribute> 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
=item B<new (%options)>
-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<attribute>
-This must be an instance of C<Class::MOP::Attribute> which this
+This must be an instance of C<Class::MOP::Attribute> which this
accessor is being generated for. This paramter is B<required>.
=item I<accessor_type>
-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<is_inline>
=item B<initialize_body>
-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<Class::MOP::Attribute>. The names pretty much explain it all.
=over 4
L<http://www.iinteractive.com>
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
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 ]
}
sub initialize_body {
my $self = shift;
my $method_name = 'generate_constructor_method';
-
+
$method_name .= '_inline' if $self->is_inline;
-
+
$self->{'&!body'} = $self->$method_name;
}
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 $@;
}
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.
$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;
=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<Class::MOP::Method> which deals with
-class constructors.
+This is a subclass of C<Class::MOP::Method> which deals with
+class constructors.
=head1 METHODS
=item B<attributes>
-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<new>.
=item B<meta_instance>
-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<new>.
=item B<is_inline>
-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<initialize_body>
-This creates the code reference for the constructor itself.
+This creates the code reference for the constructor itself.
=back
L<http://www.iinteractive.com>
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
use Test::Exception;
BEGIN {
- use_ok('Class::MOP::Instance');
+ use_ok('Class::MOP::Instance');
}
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');
+
+
use Test::More tests => 70;
use Test::Exception;
-BEGIN {
- use_ok('Class::MOP');
+BEGIN {
+ use_ok('Class::MOP');
}
use lib catdir($FindBin::Bin, 'lib');
{
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');
{
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
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');
}
# 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');
}
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');
}
)
);
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');
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);
->setLeft(
BinaryTree->new(2)
->setLeft(
- BinaryTree->new(1)
+ BinaryTree->new(1)
)
->setRight(
BinaryTree->new(3)
->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) ],
->setLeft(
BinaryTree->new(1)
->setRight(
- BinaryTree->new(10)
+ BinaryTree->new(10)
->setLeft(
- BinaryTree->new(5)
- )
+ BinaryTree->new(5)
+ )
)
)
->setRight(
->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) ],
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();
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');
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');
use strict;
use warnings;
+use Carp qw/confess/;
use metaclass;
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;
}
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;
projects / gitmo/Class-MOP.git / commitdiff