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