examples/InsideOutClass.pod

   1
   2 package # hide the package from PAUSE
   3     InsideOutClass;
   4
   5 use strict;
   6 use warnings;
   7
   8 our $VERSION = '0.03';
   9
  10 use Scalar::Util 'refaddr';
  11
  12 use base 'Class::MOP::Class';
  13
  14 sub construct_instance {
  15     my ($class, %params) = @_;
  16     # create a scalar ref to use as
  17     # the inside-out instance
  18     my $instance = \(my $var);
  19     foreach my $attr (map { $_->{attribute} } $class->compute_all_applicable_attributes()) {
  20         # if the attr has an init_arg, use that, otherwise,
  21         # use the attributes name itself as the init_arg
  22         my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name;
  23         # try to fetch the init arg from the %params ...
  24         my $val;
  25         $val = $params{$init_arg} if exists $params{$init_arg};
  26         # if nothing was in the %params, we can use the
  27         # attribute's default value (if it has one)
  28         $val ||= $attr->default($instance) if $attr->has_default();
  29         # now add this to the instance structure
  30         $class->get_package_variable('%' . $attr->name)->{ refaddr($instance) } = $val;
  31     }
  32     return $instance;
  33 }
  34
  35 package # hide the package from PAUSE
  36     InsideOutClass::Attribute;
  37
  38 use strict;
  39 use warnings;
  40
  41 our $VERSION = '0.04';
  42
  43 use Scalar::Util 'refaddr';
  44
  45 use base 'Class::MOP::Attribute';
  46
  47 sub generate_accessor_method {
  48     my ($self, $attr_name) = @_;
  49     $attr_name = ($self->associated_class->name . '::' . $attr_name);
  50     eval 'sub {
  51         $' . $attr_name . '{ refaddr($_[0]) } = $_[1] if scalar(@_) == 2;
  52         $' . $attr_name . '{ refaddr($_[0]) };
  53     }';
  54 }
  55
  56 sub generate_reader_method {
  57     my ($self, $attr_name) = @_;
  58     eval 'sub {
  59         $' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) };
  60     }';
  61 }
  62
  63 sub generate_writer_method {
  64     my ($self, $attr_name) = @_;
  65     eval 'sub {
  66         $' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) } = $_[1];
  67     }';
  68 }
  69
  70 sub generate_predicate_method {
  71     my ($self, $attr_name) = @_;
  72     eval 'sub {
  73         defined($' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) }) ? 1 : 0;
  74     }';
  75 }
  76
  77 ## &remove_attribute is left as an exercise for the reader :)
  78
  79 1;
  80
  81 __END__
  82
  83 =pod
  84
  85 =head1 NAME
  86
  87 InsideOutClass - A set of example metaclasses which implement the Inside-Out technique
  88
  89 =head1 SYNOPSIS
  90
  91   package Foo;
  92
  93   sub meta {
  94       InsideOutClass->initialize($_[0] => (
  95          # tell our metaclass to use the
  96          # InsideOut attribute metclass
  97          # to construct all it's attributes
  98         ':attribute_metaclass' => 'InsideOutClass::Attribute'
  99       ))
 100   }
 101
 102   __PACKAGE__->meta->add_attribute('foo' => (
 103       reader => 'get_foo',
 104       writer => 'set_foo'
 105   ));
 106
 107   sub new  {
 108       my $class = shift;
 109       bless $class->meta->construct_instance(@_) => $class;
 110   }
 111
 112   # now you can just use the class as normal
 113
 114 =head1 DESCRIPTION
 115
 116 This is a set of example metaclasses which implement the Inside-Out
 117 class technique. What follows is a brief explaination of the code
 118 found in this module.
 119
 120 First step is to subclass B<Class::MOP::Class> and override the
 121 C<construct_instance> method. The default C<construct_instance>
 122 will create a HASH reference using the parameters and attribute
 123 default values. Since inside-out objects don't use HASH refs, and
 124 use package variables instead, we need to write code to handle
 125 this difference.
 126
 127 The next step is to create the subclass of B<Class::MOP::Attribute>
 128 and override the method generation code. This requires overloading
 129 C<generate_accessor_method>, C<generate_reader_method>,
 130 C<generate_writer_method> and C<generate_predicate_method>. All
 131 other aspects are taken care of with the existing B<Class::MOP::Attribute>
 132 infastructure.
 133
 134 And that is pretty much all. Of course I am ignoring need for
 135 inside-out objects to be C<DESTROY>-ed, and some other details as
 136 well, but this is an example. A real implementation is left as an
 137 exercise to the reader.
 138
 139 =head1 AUTHOR
 140
 141 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 142
 143 =head1 COPYRIGHT AND LICENSE
 144
 145 Copyright 2006 by Infinity Interactive, Inc.
 146
 147 L<http://www.iinteractive.com>
 148
 149 This library is free software; you can redistribute it and/or modify
 150 it under the same terms as Perl itself.
 151
 152 =cut