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