Have is_class_loaded use the old code from Moose's ClassName type check
[gitmo/Class-MOP.git] / 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