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