X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=examples%2FInsideOutClass.pod;h=e99237ebe5bf0697261c4edaadaa2dc1ae081b2f;hb=ba38bf08d30369c19a2c25997a0243c0d30be3d5;hp=d82cd03dada33b44faf42dce070e8a2e1ba97861;hpb=651955fb509042e19195fe9c926a84c4e8b8bfe1;p=gitmo%2FClass-MOP.git diff --git a/examples/InsideOutClass.pod b/examples/InsideOutClass.pod index d82cd03..e99237e 100644 --- a/examples/InsideOutClass.pod +++ b/examples/InsideOutClass.pod @@ -1,80 +1,132 @@ package # hide the package from PAUSE - InsideOutClass; + InsideOutClass::Attribute; use strict; use warnings; -our $VERSION = '0.03'; +our $VERSION = '0.02'; +use Carp 'confess'; use Scalar::Util 'refaddr'; -use base 'Class::MOP::Class'; - -sub construct_instance { - my ($class, %params) = @_; - # create a scalar ref to use as - # the inside-out instance - my $instance = \(my $var); - foreach my $attr ($class->compute_all_applicable_attributes()) { - # if the attr has an init_arg, use that, otherwise, - # use the attributes name itself as the init_arg - my $init_arg = $attr->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) - $val ||= $attr->default($instance) if $attr->has_default(); - # now add this to the instance structure - $class->get_package_variable('%' . $attr->name)->{ refaddr($instance) } = $val; - } - return $instance; +use base 'Class::MOP::Attribute'; + +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); + } + my $_meta_instance = $self->associated_class->get_meta_instance; + $_meta_instance->initialize_slot($instance, $self->name); + $_meta_instance->set_slot_value($instance, $self->name, $val); } -package # hide the package from PAUSE - InsideOutClass::Attribute; +sub accessor_metaclass { 'InsideOutClass::Method::Accessor' } +package # hide the package from PAUSE + InsideOutClass::Method::Accessor; + use strict; use warnings; -our $VERSION = '0.04'; +our $VERSION = '0.01'; +use Carp 'confess'; use Scalar::Util 'refaddr'; -use base 'Class::MOP::Attribute'; +use base 'Class::MOP::Method::Accessor'; + +## Method generation helpers sub generate_accessor_method { - my ($self, $attr_name) = @_; - $attr_name = ($self->associated_class->name . '::' . $attr_name); - eval 'sub { - $' . $attr_name . '{ refaddr($_[0]) } = $_[1] if scalar(@_) == 2; - $' . $attr_name . '{ refaddr($_[0]) }; - }'; + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; + return sub { + my $meta_instance = $meta_class->get_meta_instance; + $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2; + $meta_instance->get_slot_value($_[0], $attr_name); + }; } sub generate_reader_method { - my ($self, $attr_name) = @_; - eval 'sub { - $' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) }; - }'; + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; + return sub { + confess "Cannot assign a value to a read-only accessor" if @_ > 1; + $meta_class->get_meta_instance + ->get_slot_value($_[0], $attr_name); + }; } sub generate_writer_method { - my ($self, $attr_name) = @_; - eval 'sub { - $' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) } = $_[1]; - }'; + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; + return sub { + $meta_class->get_meta_instance + ->set_slot_value($_[0], $attr_name, $_[1]); + }; } sub generate_predicate_method { - my ($self, $attr_name) = @_; - eval 'sub { - defined($' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) }) ? 1 : 0; - }'; + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; + return sub { + defined $meta_class->get_meta_instance + ->get_slot_value($_[0], $attr_name) ? 1 : 0; + }; +} + +package # hide the package from PAUSE + InsideOutClass::Instance; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use Carp 'confess'; +use Scalar::Util 'refaddr'; + +use base 'Class::MOP::Instance'; + +sub create_instance { + my ($self, $class) = @_; + $self->bless_instance_structure(\(my $instance)); +} + +sub get_slot_value { + my ($self, $instance, $slot_name) = @_; + $self->{meta}->get_package_symbol('%' . $slot_name)->{refaddr $instance}; } -## &remove_attribute is left as an exercise for the reader :) +sub set_slot_value { + my ($self, $instance, $slot_name, $value) = @_; + $self->{meta}->get_package_symbol('%' . $slot_name)->{refaddr $instance} = $value; +} + +sub initialize_slot { + my ($self, $instance, $slot_name) = @_; + $self->{meta}->add_package_symbol(('%' . $slot_name) => {}) + unless $self->{meta}->has_package_symbol('%' . $slot_name); + $self->{meta}->get_package_symbol('%' . $slot_name)->{refaddr $instance} = undef; +} + +sub is_slot_initialized { + my ($self, $instance, $slot_name) = @_; + return 0 unless $self->{meta}->has_package_symbol('%' . $slot_name); + return exists $self->{meta}->get_package_symbol('%' . $slot_name)->{refaddr $instance} ? 1 : 0; +} 1; @@ -90,11 +142,9 @@ InsideOutClass - A set of example metaclasses which implement the Inside-Out tec package Foo; - use metaclass 'InsideOutClass' => ( - # tell our metaclass to use the - # InsideOut attribute metclass - # to construct all it's attributes - ':attribute_metaclass' => 'InsideOutClass::Attribute' + use metaclass ( + ':attribute_metaclass' => 'InsideOutClass::Attribute', + ':instance_metaclass' => 'InsideOutClass::Instance' ); __PACKAGE__->meta->add_attribute('foo' => ( @@ -104,8 +154,8 @@ InsideOutClass - A set of example metaclasses which implement the Inside-Out tec sub new { my $class = shift; - bless $class->meta->construct_instance(@_) => $class; - } + $class->meta->new_object(@_); + } # now you can just use the class as normal @@ -115,29 +165,24 @@ This is a set of example metaclasses which implement the Inside-Out class technique. What follows is a brief explaination of the code found in this module. -First step is to subclass B and override the -C method. The default C -will create a HASH reference using the parameters and attribute -default values. Since inside-out objects don't use HASH refs, and -use package variables instead, we need to write code to handle -this difference. - -The next step is to create the subclass of B -and override the method generation code. This requires overloading -C, C, -C and C. All -other aspects are taken care of with the existing B -infastructure. +We must create a subclass of B and override +the slot operations. This requires +overloading C, C, C, and +C, as well as their inline counterparts. Additionally we +overload C in order to initialize the global hash containing the +actual slot values. And that is pretty much all. Of course I am ignoring need for inside-out objects to be C-ed, and some other details as -well, but this is an example. A real implementation is left as an -exercise to the reader. +well (threading, etc), but this is an example. A real implementation is left as +an exercise to the reader. -=head1 AUTHOR +=head1 AUTHORS Stevan Little Estevan@iinteractive.comE +Yuval Kogman Enothingmuch@woobling.comE + =head1 COPYRIGHT AND LICENSE Copyright 2006 by Infinity Interactive, Inc.