examples/ClassEncapsulatedAttributes.pod

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