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 ($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   use metaclass 'InsideOutClass' => (
  94      # tell our metaclass to use the
  95      # InsideOut attribute metclass
  96      # to construct all it's attributes
  97     ':attribute_metaclass' => 'InsideOutClass::Attribute'
  98   );
  99
 100   __PACKAGE__->meta->add_attribute('foo' => (
 101       reader => 'get_foo',
 102       writer => 'set_foo'
 103   ));
 104
 105   sub new  {
 106       my $class = shift;
 107       bless $class->meta->construct_instance(@_) => $class;
 108   }
 109
 110   # now you can just use the class as normal
 111
 112 =head1 DESCRIPTION
 113
 114 This is a set of example metaclasses which implement the Inside-Out
 115 class technique. What follows is a brief explaination of the code
 116 found in this module.
 117
 118 First step is to subclass B<Class::MOP::Class> and override the
 119 C<construct_instance> method. The default C<construct_instance>
 120 will create a HASH reference using the parameters and attribute
 121 default values. Since inside-out objects don't use HASH refs, and
 122 use package variables instead, we need to write code to handle
 123 this difference.
 124
 125 The next step is to create the subclass of B<Class::MOP::Attribute>
 126 and override the method generation code. This requires overloading
 127 C<generate_accessor_method>, C<generate_reader_method>,
 128 C<generate_writer_method> and C<generate_predicate_method>. All
 129 other aspects are taken care of with the existing B<Class::MOP::Attribute>
 130 infastructure.
 131
 132 And that is pretty much all. Of course I am ignoring need for
 133 inside-out objects to be C<DESTROY>-ed, and some other details as
 134 well, but this is an example. A real implementation is left as an
 135 exercise to the reader.
 136
 137 =head1 AUTHOR
 138
 139 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 140
 141 =head1 COPYRIGHT AND LICENSE
 142
 143 Copyright 2006 by Infinity Interactive, Inc.
 144
 145 L<http://www.iinteractive.com>
 146
 147 This library is free software; you can redistribute it and/or modify
 148 it under the same terms as Perl itself.
 149
 150 =cut