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.04';
   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->init_arg();
  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         if (!defined $val && $attr->has_default) {
  29             $val = $attr->default($instance);
  30         }
  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 our $VERSION = '0.04';
  44
  45 use Carp         'confess';
  46 use Scalar::Util 'refaddr';
  47
  48 use base 'Class::MOP::Attribute';
  49
  50 sub generate_accessor_method {
  51     my ($self, $attr_name) = @_;
  52     $attr_name = ($self->associated_class->name . '::' . $attr_name);
  53     eval 'sub {
  54         $' . $attr_name . '{ refaddr($_[0]) } = $_[1] if scalar(@_) == 2;
  55         $' . $attr_name . '{ refaddr($_[0]) };
  56     }';
  57 }
  58
  59 sub generate_reader_method {
  60     my ($self, $attr_name) = @_;
  61     eval 'sub {
  62         confess "Cannot assign a value to a read-only accessor" if @_ > 1;
  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   use metaclass 'InsideOutClass' => (
  98      # tell our metaclass to use the
  99      # InsideOut attribute metclass
 100      # to construct all it's attributes
 101     ':attribute_metaclass' => 'InsideOutClass::Attribute'
 102   );
 103
 104   __PACKAGE__->meta->add_attribute('foo' => (
 105       reader => 'get_foo',
 106       writer => 'set_foo'
 107   ));
 108
 109   sub new  {
 110       my $class = shift;
 111       $class->meta->new_object(@_);
 112   }
 113
 114   # now you can just use the class as normal
 115
 116 =head1 DESCRIPTION
 117
 118 This is a set of example metaclasses which implement the Inside-Out
 119 class technique. What follows is a brief explaination of the code
 120 found in this module.
 121
 122 First step is to subclass B<Class::MOP::Class> and override the
 123 C<construct_instance> method. The default C<construct_instance>
 124 will create a HASH reference using the parameters and attribute
 125 default values. Since inside-out objects don't use HASH refs, and
 126 use package variables instead, we need to write code to handle
 127 this difference.
 128
 129 The next step is to create the subclass of B<Class::MOP::Attribute>
 130 and override the method generation code. This requires overloading
 131 C<generate_accessor_method>, C<generate_reader_method>,
 132 C<generate_writer_method> and C<generate_predicate_method>. All
 133 other aspects are taken care of with the existing B<Class::MOP::Attribute>
 134 infastructure.
 135
 136 And that is pretty much all. Of course I am ignoring need for
 137 inside-out objects to be C<DESTROY>-ed, and some other details as
 138 well, but this is an example. A real implementation is left as an
 139 exercise to the reader.
 140
 141 =head1 AUTHOR
 142
 143 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 144
 145 =head1 COPYRIGHT AND LICENSE
 146
 147 Copyright 2006 by Infinity Interactive, Inc.
 148
 149 L<http://www.iinteractive.com>
 150
 151 This library is free software; you can redistribute it and/or modify
 152 it under the same terms as Perl itself.
 153
 154 =cut