examples/ClassEncapsulatedAttributes.pod

   1
   2 package # hide the package from PAUSE
   3     ClassEncapsulatedAttributes;
   4
   5 use strict;
   6 use warnings;
   7
   8 use Class::MOP 'meta';
   9
  10 our $VERSION = '0.02';
  11
  12 use base 'Class::MOP::Class';
  13
  14 sub initialize {
  15     (shift)->SUPER::initialize(@_,
  16         # use the custom attribute metaclass here
  17         ':attribute_metaclass' => 'ClassEncapsulatedAttributes::Attribute'
  18     );
  19 }
  20
  21 sub construct_instance {
  22     my ($class, %params) = @_;
  23     my $instance = {};
  24     foreach my $current_class ($class->class_precedence_list()) {
  25         $instance->{$current_class} = {}
  26             unless exists $instance->{$current_class};
  27         my $meta = $class->initialize($current_class);
  28         foreach my $attr_name ($meta->get_attribute_list()) {
  29             my $attr = $meta->get_attribute($attr_name);
  30             # if the attr has an init_arg, use that, otherwise,
  31             # use the attributes name itself as the init_arg
  32             my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name;
  33             # try to fetch the init arg from the %params ...
  34             my $val;
  35             $val = $params{$current_class}->{$init_arg}
  36                 if exists $params{$current_class} &&
  37                    exists ${$params{$current_class}}{$init_arg};
  38             # if nothing was in the %params, we can use the
  39             # attribute's default value (if it has one)
  40             $val ||= $attr->default($instance) if $attr->has_default();
  41             # now add this to the instance structure
  42             $instance->{$current_class}->{$attr_name} = $val;
  43         }
  44     }
  45     return $instance;
  46 }
  47
  48 package # hide the package from PAUSE
  49     ClassEncapsulatedAttributes::Attribute;
  50
  51 use strict;
  52 use warnings;
  53
  54 use Class::MOP 'meta';
  55
  56 our $VERSION = '0.01';
  57
  58 use base 'Class::MOP::Attribute';
  59
  60 sub generate_accessor_method {
  61     my ($self, $attr_name) = @_;
  62     my $class_name = $self->associated_class->name;
  63     eval qq{sub {
  64         \$_[0]->{'$class_name'}->{'$attr_name'} = \$_[1] if scalar(\@_) == 2;
  65         \$_[0]->{'$class_name'}->{'$attr_name'};
  66     }};
  67 }
  68
  69 sub generate_reader_method {
  70     my ($self, $attr_name) = @_;
  71     my $class_name = $self->associated_class->name;
  72     eval qq{sub {
  73         \$_[0]->{'$class_name'}->{'$attr_name'};
  74     }};
  75 }
  76
  77 sub generate_writer_method {
  78     my ($self, $attr_name) = @_;
  79     my $class_name = $self->associated_class->name;
  80     eval qq{sub {
  81         \$_[0]->{'$class_name'}->{'$attr_name'} = \$_[1];
  82     }};
  83 }
  84
  85 sub generate_predicate_method {
  86     my ($self, $attr_name) = @_;
  87     my $class_name = $self->associated_class->name;
  88     eval qq{sub {
  89         defined \$_[0]->{'$class_name'}->{'$attr_name'} ? 1 : 0;
  90     }};
  91 }
  92
  93 ## &remove_attribute is left as an exercise for the reader :)
  94
  95 1;
  96
  97 __END__
  98
  99 =pod
 100
 101 =head1 NAME
 102
 103 ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulated attributes
 104
 105 =head1 SYNOPSIS
 106
 107   package Foo;
 108
 109   sub meta { ClassEncapsulatedAttributes->initialize($_[0]) }
 110
 111   Foo->meta->add_attribute('foo' => (
 112       accessor  => 'Foo_foo',
 113       default   => 'init in FOO'
 114   ));
 115
 116   sub new  {
 117       my $class = shift;
 118       bless $class->meta->construct_instance(@_) => $class;
 119   }
 120
 121   package Bar;
 122   our @ISA = ('Foo');
 123
 124   # duplicate the attribute name here
 125   Bar->meta->add_attribute('foo' => (
 126       accessor  => 'Bar_foo',
 127       default   => 'init in BAR'
 128   ));
 129
 130   # ... later in other code ...
 131
 132   my $bar = Bar->new();
 133   prints $bar->Bar_foo(); # init in BAR
 134   prints $bar->Foo_foo(); # init in FOO
 135
 136   # and ...
 137
 138   my $bar = Bar->new(
 139       'Foo' => { 'foo' => 'Foo::foo' },
 140       'Bar' => { 'foo' => 'Bar::foo' }
 141   );
 142
 143   prints $bar->Bar_foo(); # Foo::foo
 144   prints $bar->Foo_foo(); # Bar::foo
 145
 146 =head1 DESCRIPTION
 147
 148 This is an example metaclass which encapsulates a class's
 149 attributes on a per-class basis. This means that there is no
 150 possibility of name clashes with inherited attributes. This
 151 is similar to how C++ handles its data members.
 152
 153 =head1 ACKNOWLEDGEMENTS
 154
 155 Thanks to Yuval "nothingmuch" Kogman for the idea for this example.
 156
 157 =head1 AUTHOR
 158
 159 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 160
 161 =head1 COPYRIGHT AND LICENSE
 162
 163 Copyright 2006 by Infinity Interactive, Inc.
 164
 165 L<http://www.iinteractive.com>
 166
 167 This library is free software; you can redistribute it and/or modify
 168 it under the same terms as Perl itself.
 169
 170 =cut