examples/InsideOutClass.pod

   1
   2 package # hide the package from PAUSE
   3     InsideOutClass::Attribute;
   4
   5 use strict;
   6 use warnings;
   7
   8 our $VERSION = '0.02';
   9
  10 use Carp         'confess';
  11 use Scalar::Util 'refaddr';
  12
  13 use base 'Class::MOP::Attribute';
  14
  15 sub initialize_instance_slot {
  16     my ($self, $meta_instance, $instance, $params) = @_;
  17     my $init_arg = $self->init_arg;
  18     # try to fetch the init arg from the %params ...
  19     my $val;
  20     $val = $params->{$init_arg} if exists $params->{$init_arg};
  21     # if nothing was in the %params, we can use the
  22     # attribute's default value (if it has one)
  23     if (!defined $val && defined $self->default) {
  24         $val = $self->default($instance);
  25     }
  26     my $_meta_instance = $self->associated_class->get_meta_instance;
  27     $_meta_instance->initialize_slot($instance, $self->name);
  28     $_meta_instance->set_slot_value($instance, $self->name, $val);
  29 }
  30
  31 sub accessor_metaclass { 'InsideOutClass::Method::Accessor' }
  32
  33 package # hide the package from PAUSE
  34     InsideOutClass::Method::Accessor;
  35
  36 use strict;
  37 use warnings;
  38
  39 our $VERSION = '0.01';
  40
  41 use Carp         'confess';
  42 use Scalar::Util 'refaddr';
  43
  44 use base 'Class::MOP::Method::Accessor';
  45
  46 sub is_inline{ 0 }
  47
  48 ## Method generation helpers
  49
  50 sub _generate_accessor_method {
  51     my $attr       = (shift)->associated_attribute;
  52     my $meta_class = $attr->associated_class;
  53     my $attr_name  = $attr->name;
  54     return sub {
  55         my $meta_instance = $meta_class->get_meta_instance;
  56         $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2;
  57         $meta_instance->get_slot_value($_[0], $attr_name);
  58     };
  59 }
  60
  61 sub _generate_reader_method {
  62     my $attr       = (shift)->associated_attribute;
  63     my $meta_class = $attr->associated_class;
  64     my $attr_name  = $attr->name;
  65     return sub {
  66         confess "Cannot assign a value to a read-only accessor" if @_ > 1;
  67         $meta_class->get_meta_instance
  68                    ->get_slot_value($_[0], $attr_name);
  69     };
  70 }
  71
  72 sub _generate_writer_method {
  73     my $attr       = (shift)->associated_attribute;
  74     my $meta_class = $attr->associated_class;
  75     my $attr_name  = $attr->name;
  76     return sub {
  77         $meta_class->get_meta_instance
  78                    ->set_slot_value($_[0], $attr_name, $_[1]);
  79     };
  80 }
  81
  82 sub _generate_predicate_method {
  83     my $attr       = (shift)->associated_attribute;
  84     my $meta_class = $attr->associated_class;
  85     my $attr_name  = $attr->name;
  86     return sub {
  87         defined $meta_class->get_meta_instance
  88                            ->get_slot_value($_[0], $attr_name) ? 1 : 0;
  89     };
  90 }
  91
  92 package # hide the package from PAUSE
  93     InsideOutClass::Instance;
  94
  95 use strict;
  96 use warnings;
  97
  98 our $VERSION = '0.01';
  99
 100 use Carp         'confess';
 101 use Scalar::Util 'refaddr';
 102
 103 use base 'Class::MOP::Instance';
 104
 105 sub create_instance {
 106         my ($self, $class) = @_;
 107         bless \(my $instance), $self->_class_name;
 108 }
 109
 110 sub get_slot_value {
 111         my ($self, $instance, $slot_name) = @_;
 112         $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance};
 113 }
 114
 115 sub set_slot_value {
 116         my ($self, $instance, $slot_name, $value) = @_;
 117         $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = $value;
 118 }
 119
 120 sub initialize_slot {
 121     my ($self, $instance, $slot_name) = @_;
 122     $self->associated_metaclass->add_package_symbol(('%' . $slot_name) => {})
 123         unless $self->associated_metaclass->has_package_symbol('%' . $slot_name);
 124     $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = undef;
 125 }
 126
 127 sub is_slot_initialized {
 128         my ($self, $instance, $slot_name) = @_;
 129         return 0 unless $self->associated_metaclass->has_package_symbol('%' . $slot_name);
 130         return exists $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} ? 1 : 0;
 131 }
 132
 133 1;
 134
 135 __END__
 136
 137 =pod
 138
 139 =head1 NAME
 140
 141 InsideOutClass - A set of example metaclasses which implement the Inside-Out technique
 142
 143 =head1 SYNOPSIS
 144
 145   package Foo;
 146
 147   use metaclass (
 148     ':attribute_metaclass' => 'InsideOutClass::Attribute',
 149     ':instance_metaclass'  => 'InsideOutClass::Instance'
 150   );
 151
 152   __PACKAGE__->meta->add_attribute('foo' => (
 153       reader => 'get_foo',
 154       writer => 'set_foo'
 155   ));
 156
 157   sub new  {
 158       my $class = shift;
 159       $class->meta->new_object(@_);
 160   }
 161
 162   # now you can just use the class as normal
 163
 164 =head1 DESCRIPTION
 165
 166 This is a set of example metaclasses which implement the Inside-Out
 167 class technique. What follows is a brief explaination of the code
 168 found in this module.
 169
 170 We must create a subclass of B<Class::MOP::Instance> and override
 171 the slot operations. This requires
 172 overloading C<get_slot_value>, C<set_slot_value>, C<slot_initialized>, and
 173 C<initialize_slot>, as well as their inline counterparts. Additionally we
 174 overload C<add_slot> in order to initialize the global hash containing the
 175 actual slot values.
 176
 177 And that is pretty much all. Of course I am ignoring need for
 178 inside-out objects to be C<DESTROY>-ed, and some other details as
 179 well (threading, etc), but this is an example. A real implementation is left as
 180 an exercise to the reader.
 181
 182 =head1 AUTHORS
 183
 184 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 185
 186 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 187
 188 =head1 COPYRIGHT AND LICENSE
 189
 190 Copyright 2006-2008 by Infinity Interactive, Inc.
 191
 192 L<http://www.iinteractive.com>
 193
 194 This library is free software; you can redistribute it and/or modify
 195 it under the same terms as Perl itself.
 196
 197 =cut