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.05';
   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.03';
  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($class->name)->{$self->name} = $val;
  61 }
  62
  63 sub generate_accessor_method {
  64     my ($self, $attr_name) = @_;
  65     my $class_name = $self->associated_class->name;
  66     eval qq{sub {
  67         \$_[0]->{'$class_name'}->{'$attr_name'} = \$_[1] if scalar(\@_) == 2;
  68         \$_[0]->{'$class_name'}->{'$attr_name'};
  69     }};
  70 }
  71
  72 sub generate_reader_method {
  73     my ($self, $attr_name) = @_;
  74     my $class_name = $self->associated_class->name;
  75     eval qq{sub {
  76         Carp::confess "Cannot assign a value to a read-only accessor" if \@_ > 1;
  77         \$_[0]->{'$class_name'}->{'$attr_name'};
  78     }};
  79 }
  80
  81 sub generate_writer_method {
  82     my ($self, $attr_name) = @_;
  83     my $class_name = $self->associated_class->name;
  84     eval qq{sub {
  85         \$_[0]->{'$class_name'}->{'$attr_name'} = \$_[1];
  86     }};
  87 }
  88
  89 sub generate_predicate_method {
  90     my ($self, $attr_name) = @_;
  91     my $class_name = $self->associated_class->name;
  92     eval qq{sub {
  93         defined \$_[0]->{'$class_name'}->{'$attr_name'} ? 1 : 0;
  94     }};
  95 }
  96
  97 ## &remove_attribute is left as an exercise for the reader :)
  98
  99 1;
 100
 101 __END__
 102
 103 =pod
 104
 105 =head1 NAME
 106
 107 ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulated attributes
 108
 109 =head1 SYNOPSIS
 110
 111   package Foo;
 112
 113   use metaclass 'ClassEncapsulatedAttributes';
 114
 115   Foo->meta->add_attribute('foo' => (
 116       accessor  => 'Foo_foo',
 117       default   => 'init in FOO'
 118   ));
 119
 120   sub new  {
 121       my $class = shift;
 122       $class->meta->new_object(@_);
 123   }
 124
 125   package Bar;
 126   our @ISA = ('Foo');
 127
 128   # duplicate the attribute name here
 129   Bar->meta->add_attribute('foo' => (
 130       accessor  => 'Bar_foo',
 131       default   => 'init in BAR'
 132   ));
 133
 134   # ... later in other code ...
 135
 136   my $bar = Bar->new();
 137   prints $bar->Bar_foo(); # init in BAR
 138   prints $bar->Foo_foo(); # init in FOO
 139
 140   # and ...
 141
 142   my $bar = Bar->new(
 143       'Foo' => { 'foo' => 'Foo::foo' },
 144       'Bar' => { 'foo' => 'Bar::foo' }
 145   );
 146
 147   prints $bar->Bar_foo(); # Foo::foo
 148   prints $bar->Foo_foo(); # Bar::foo
 149
 150 =head1 DESCRIPTION
 151
 152 This is an example metaclass which encapsulates a class's
 153 attributes on a per-class basis. This means that there is no
 154 possibility of name clashes with inherited attributes. This
 155 is similar to how C++ handles its data members.
 156
 157 =head1 ACKNOWLEDGEMENTS
 158
 159 Thanks to Yuval "nothingmuch" Kogman for the idea for this example.
 160
 161 =head1 AUTHOR
 162
 163 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 164
 165 =head1 COPYRIGHT AND LICENSE
 166
 167 Copyright 2006 by Infinity Interactive, Inc.
 168
 169 L<http://www.iinteractive.com>
 170
 171 This library is free software; you can redistribute it and/or modify
 172 it under the same terms as Perl itself.
 173
 174 =cut