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