examples/InsideOutClass.pod

   1
   2 package # hide the package from PAUSE
   3     InsideOutClass::Attribute;
   4
   5 use strict;
   6 use warnings;
   7
   8 use Carp 'confess';
   9
  10 our $VERSION = '0.01';
  11
  12 use base 'Class::MOP::Attribute';
  13
  14 sub generate_accessor_method {
  15     my $self = shift;
  16     my $attr_name = $self->name;
  17     return sub {
  18         my $meta_instance = $_[0]->meta->get_meta_instance;
  19         $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2;
  20         $meta_instance->get_slot_value($_[0], $attr_name);
  21     };
  22 }
  23
  24 sub generate_reader_method {
  25     my $self = shift;
  26     my $attr_name = $self->name;
  27     return sub {
  28         confess "Cannot assign a value to a read-only accessor" if @_ > 1;
  29         $_[0]->meta
  30              ->get_meta_instance
  31              ->get_slot_value($_[0], $attr_name);
  32     };
  33 }
  34
  35 sub generate_writer_method {
  36     my $self = shift;
  37     my $attr_name = $self->name;
  38     return sub {
  39         $_[0]->meta
  40              ->get_meta_instance
  41              ->set_slot_value($_[0], $attr_name, $_[1]);
  42     };
  43 }
  44
  45 sub generate_predicate_method {
  46     my $self = shift;
  47     my $attr_name = $self->name;
  48     return sub {
  49         defined $_[0]->meta
  50                      ->get_meta_instance
  51                      ->get_slot_value($_[0], $attr_name) ? 1 : 0;
  52     };
  53 }
  54
  55 package # hide the package from PAUSE
  56     InsideOutClass::Instance;
  57
  58 use strict;
  59 use warnings;
  60
  61 our $VERSION = '0.06';
  62
  63 use Carp         'confess';
  64 use Scalar::Util 'refaddr';
  65
  66 use base 'Class::MOP::Instance';
  67
  68 sub create_instance {
  69         my ($self, $class) = @_;
  70     $self->bless_instance_structure(\(my $instance));
  71 }
  72
  73 sub get_slot_value {
  74         my ($self, $instance, $slot_name) = @_;
  75         $self->{meta}->get_package_variable('%' . $slot_name)->{refaddr $instance};
  76 }
  77
  78 sub set_slot_value {
  79         my ($self, $instance, $slot_name, $value) = @_;
  80         $self->{meta}->get_package_variable('%' . $slot_name)->{refaddr $instance} = $value;
  81 }
  82
  83 sub initialize_slot {
  84     my ($self, $instance, $slot_name) = @_;
  85     $self->{meta}->add_package_variable(('%' . $slot_name) => {})
  86         unless $self->{meta}->has_package_variable('%' . $slot_name);
  87     $self->{meta}->get_package_variable('%' . $slot_name)->{refaddr $instance} = undef;
  88 }
  89
  90 sub is_slot_initialized {
  91         my ($self, $instance, $slot_name) = @_;
  92         return 0 unless $self->{meta}->has_package_variable('%' . $slot_name);
  93         return exists $self->{meta}->get_package_variable('%' . $slot_name)->{refaddr $instance} ? 1 : 0;
  94 }
  95
  96 1;
  97
  98 __END__
  99
 100 =pod
 101
 102 =head1 NAME
 103
 104 InsideOutClass - A set of example metaclasses which implement the Inside-Out technique
 105
 106 =head1 SYNOPSIS
 107
 108   package Foo;
 109
 110   use metaclass 'Class::MOP::Class' => (
 111      # tell our metaclass to use the
 112      # InsideOut attribute metclass
 113      # to construct all it's attributes
 114     ':instance_metaclass' => 'InsideOutClass::Instance'
 115   );
 116
 117   __PACKAGE__->meta->add_attribute('foo' => (
 118       reader => 'get_foo',
 119       writer => 'set_foo'
 120   ));
 121
 122   sub new  {
 123       my $class = shift;
 124       $class->meta->new_object(@_);
 125   }
 126
 127   # now you can just use the class as normal
 128
 129 =head1 DESCRIPTION
 130
 131 This is a set of example metaclasses which implement the Inside-Out
 132 class technique. What follows is a brief explaination of the code
 133 found in this module.
 134
 135 We must create a subclass of B<Class::MOP::Instance> and override
 136 the slot operations. This requires
 137 overloading C<get_slot_value>, C<set_slot_value>, C<slot_initialized>, and
 138 C<initialize_slot>, as well as their inline counterparts. Additionally we
 139 overload C<add_slot> in order to initialize the global hash containing the
 140 actual slot values.
 141
 142 And that is pretty much all. Of course I am ignoring need for
 143 inside-out objects to be C<DESTROY>-ed, and some other details as
 144 well (threading, etc), but this is an example. A real implementation is left as
 145 an exercise to the reader.
 146
 147 =head1 AUTHOR
 148
 149 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 150
 151 =head1 SEE ALSO
 152
 153 L<Tie::RefHash::Weak>
 154
 155 =head1 COPYRIGHT AND LICENSE
 156
 157 Copyright 2006 by Infinity Interactive, Inc.
 158
 159 L<http://www.iinteractive.com>
 160
 161 This library is free software; you can redistribute it and/or modify
 162 it under the same terms as Perl itself.
 163
 164 =cut