examples/InsideOutClass.pm

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