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