examples/InsideOutClass.pod

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