← Back to branch summary

~ubuntu-branches/ubuntu/karmic/libclass-meta-perl/karmic

« back to all changes in this revision

Viewing changes to lib/Class/Meta/AccessorBuilder/Affordance.pm

  • Committer: Bazaar Package Importer
  • Author(s): Krzysztof Krzyzaniak (eloy)
  • Date: 2006-01-03 17:29:20 UTC
  • Revision ID: james.westby@ubuntu.com-20060103172920-h94p8qrrav90bzq0
Tags: upstream-0.52
Import upstream version 0.52

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/Class/Meta/AccessorBuilder/Affordance.pm
 
1
package Class::Meta::AccessorBuilder::Affordance;
 
2
 
 
3
# $Id: Affordance.pm 2405 2005-12-17 03:41:09Z theory $
 
4
 
 
5
=head1 NAME
 
6
 
 
7
Class::Meta::AccessorBuilder::Affordance - Affordance style accessor generation
 
8
 
 
9
=head1 SYNOPSIS
 
10
 
 
11
  package MyApp::TypeDef;
 
12
 
 
13
  use strict;
 
14
  use Class::Meta::Type;
 
15
  use IO::Socket;
 
16
 
 
17
  my $type = Class::Meta::Type->add( key     => 'io_socket',
 
18
                                     builder => 'affordance',
 
19
                                     desc    => 'IO::Socket object',
 
20
                                     name    => 'IO::Socket Object' );
 
21
 
 
22
=head1 DESCRIPTION
 
23
 
 
24
This module provides the an affordance style accessor builder for Class::Meta.
 
25
Affordance accessors are attribute accessor methods that separate the getting
 
26
and setting of an attribute value into distinct methods. The approach both
 
27
eliminates the overhead of checking to see whether an accessor is called as a
 
28
getter or a setter, which is common for Perl style accessors, while also
 
29
creating a psychological barrier to accidentally misusing an attribute.
 
30
 
 
31
=head2 Accessors
 
32
 
 
33
Class::Meta::AccessorBuilder::Affordance create two different types of
 
34
accessors: getters and setters. The type of accessors created depends on the
 
35
value of the C<authz> attribute of the Class::Meta::Attribute for which the
 
36
accessor is being created.
 
37
 
 
38
For example, if the C<authz> is Class::Meta::RDWR, then two accessor methods
 
39
will be created:
 
40
 
 
41
  my $value = $obj->get_io_socket;
 
42
  $obj->set_io_socket($value);
 
43
 
 
44
If the value of C<authz> is Class::Meta::READ, then only the get method
 
45
will be created:
 
46
 
 
47
  my $value = $obj->io_socket;
 
48
 
 
49
And finally, if the value of C<authz> is Class::Meta::WRITE, then only the set
 
50
method will be created (why anyone would want this is beyond me, but I provide
 
51
for the sake of completeness):
 
52
 
 
53
  my $value = $obj->io_socket;
 
54
 
 
55
=head2 Data Type Validation
 
56
 
 
57
Class::Meta::AccessorBuilder::Affordance uses all of the validation checks
 
58
passed to it to validate new values before assigning them to an attribute. It
 
59
also checks to see if the attribute is required, and if so, adds a check to
 
60
ensure that its value is never undefined. It does not currently check to
 
61
ensure that private and protected methods are used only in their appropriate
 
62
contexts, but may do so in a future release.
 
63
 
 
64
=head2 Class Attributes
 
65
 
 
66
If the C<context> attribute of the attribute object for which accessors are to
 
67
be built is C<Class::Meta::CLASS>, Class::Meta::AccessorBuilder will build
 
68
accessors for a class attribute instead of an object attribute. Of course,
 
69
this means that if you change the value of the class attribute in any
 
70
context--whether via a an object, the class name, or an an inherited class
 
71
name or object, the value will be changed everywhere.
 
72
 
 
73
For example, for a class attribute "count", you can expect the following to
 
74
work:
 
75
 
 
76
  MyApp::Custom->set_count(10);
 
77
  my $count = MyApp::Custom->get_count; # Returns 10.
 
78
  my $obj = MyApp::Custom->new;
 
79
  $count = $obj->get_count;             # Returns 10.
 
80
 
 
81
  $obj->set_count(22);
 
82
  $count = $obj->get_count;             # Returns 22.
 
83
  my $count = MyApp::Custom->get_count; # Returns 22.
 
84
 
 
85
  MyApp::Custom->set_count(35);
 
86
  $count = $obj->get_count;             # Returns 35.
 
87
  my $count = MyApp::Custom->get_count; # Returns 35.
 
88
 
 
89
Currently, class attribute accessors are not designed to be inheritable in the
 
90
way designed by Class::Data::Inheritable, although this might be changed in a
 
91
future release. For now, I expect that the current simple approach will cover
 
92
the vast majority of circumstances.
 
93
 
 
94
B<Note:> Class attribute accessors will not work accurately in multiprocess
 
95
environments such as mod_perl. If you change a class attribute's value in one
 
96
process, it will not be changed in any of the others. Furthermore, class
 
97
attributes are not currently shared across threads. So if you're using
 
98
Class::Meta class attributes in a multi-threaded environment (such as iThreads
 
99
in Perl 5.8.0 and later) the changes to a class attribute in one thread will
 
100
not be reflected in other threads.
 
101
 
 
102
=head1 Private and Protected Attributes
 
103
 
 
104
Any attributes that have their C<view> attribute set to Class::Meta::Private
 
105
or Class::Meta::Protected get additional validation installed to ensure that
 
106
they're truly private and protected. This includes when they are set via
 
107
parameters to constructors generated by Class::Meta. The validation is
 
108
performed by checking the caller of the accessors, and throwing an exception
 
109
when the caller isn't the class that owns the attribute (for private
 
110
attributes) or when it doesn't inherit from the class that owns the attribute
 
111
(for protected attributes).
 
112
 
 
113
As an implementation note, this validation is performed for parameters passed
 
114
to constructors created by Class::Meta by ignoring looking for the first
 
115
caller that isn't Class::Meta::Constructor:
 
116
 
 
117
  my $caller = caller;
 
118
  # Circumvent generated constructors.
 
119
  for (my $i = 1; $caller eq 'Class::Meta::Constructor'; $i++) {
 
120
      $caller = caller($i);
 
121
  }
 
122
 
 
123
This works because Class::Meta::Constructor installs the closures that become
 
124
constructors, and thus, when those closures call accessors to set new values
 
125
for attributes, the caller is Class::Meta::Constructor. By going up the stack
 
126
until we find another package, we correctly check to see what context is
 
127
setting attribute values via a constructor, rather than the constructor method
 
128
itself being the context.
 
129
 
 
130
This is a bit of a hack, but since Perl uses call stacks for checking security
 
131
in this way, it's the best I could come up with. Other suggestions welcome. Or
 
132
see L<Class::Meta::Type|Class::Meta::Type/"Custom Accessor Building"> to
 
133
create your own accessor generation code
 
134
 
 
135
=head1 INTERFACE
 
136
 
 
137
The following functions must be implemented by any Class::Meta accessor
 
138
generation module.
 
139
 
 
140
=head2 Functions
 
141
 
 
142
=head3 build_attr_get
 
143
 
 
144
  my $code = Class::Meta::AccessorBuilder::Affordance::build_attr_get();
 
145
 
 
146
This function is called by C<Class::Meta::Type::make_attr_get()> and returns a
 
147
code reference that can be used by the C<get()> method of
 
148
Class::Meta::Attribute to return the value stored for that attribute for the
 
149
object passed to the code reference.
 
150
 
 
151
=head3 build_attr_set
 
152
 
 
153
  my $code = Class::Meta::AccessorBuilder::Affordance::build_attr_set();
 
154
 
 
155
This function is called by C<Class::Meta::Type::make_attr_set()> and returns a
 
156
code reference that can be used by the C<set()> method of
 
157
Class::Meta::Attribute to set the value stored for that attribute for the
 
158
object passed to the code reference.
 
159
 
 
160
=head3 build
 
161
 
 
162
  Class::Meta::AccessorBuilder::Affordance::build(
 
163
    $pkg, $attribute, $create, @checks
 
164
  );
 
165
 
 
166
This method is called by the C<build()> method of Class::Meta::Type, and does
 
167
the work of actually generating the accessors for an attribute object. The
 
168
arguments passed to it are:
 
169
 
 
170
=over 4
 
171
 
 
172
=item $pkg
 
173
 
 
174
The name of the class to which the accessors will be added.
 
175
 
 
176
=item $attribute
 
177
 
 
178
The Class::Meta::Attribute object that specifies the attribute for which the
 
179
accessors will be created.
 
180
 
 
181
=item $create
 
182
 
 
183
The value of the C<create> attribute of the Class::Meta::Attribute object,
 
184
which determines what accessors, if any, are to be created.
 
185
 
 
186
=item @checks
 
187
 
 
188
A list of code references that validate the value of an attribute. These will
 
189
be used in the set acccessor (mutator) to validate new attribute values.
 
190
 
 
191
=back
 
192
 
 
193
=cut
 
194
 
 
195
use strict;
 
196
use Class::Meta;
 
197
our $VERSION = "0.52";
 
198
 
 
199
sub build_attr_get {
 
200
    UNIVERSAL::can($_[0]->package, 'get_' . $_[0]->name);
 
201
}
 
202
 
 
203
sub build_attr_set {
 
204
    UNIVERSAL::can($_[0]->package, 'set_' . $_[0]->name);
 
205
}
 
206
 
 
207
my $req_chk = sub {
 
208
    $_[2]->class->handle_error("Attribute ", $_[2]->name, " must be defined")
 
209
      unless defined $_[0];
 
210
};
 
211
 
 
212
my $once_chk = sub {
 
213
    $_[2]->class->handle_error("Attribute ", $_[2]->name,
 
214
                               " can only be set once")
 
215
      if defined $_[1]->{$_[2]->name};
 
216
};
 
217
 
 
218
sub build {
 
219
    my ($pkg, $attr, $name, $get, $set) = __PACKAGE__->_build(@_);
 
220
    # Install the accessors.
 
221
    no strict 'refs';
 
222
    *{"${pkg}::get_$name"} = $get if $get;
 
223
    *{"${pkg}::set_$name"} = $set if $set;
 
224
}
 
225
 
 
226
sub _build {
 
227
    shift;
 
228
    my ($pkg, $attr, $create, @checks) = @_;
 
229
    my $name = $attr->name;
 
230
 
 
231
    # Add the required check, if needed.
 
232
    unshift @checks, $req_chk if $attr->required;
 
233
 
 
234
    # Add a once check, if needed.
 
235
    unshift @checks, $once_chk if $attr->once;
 
236
 
 
237
    my ($get, $set);
 
238
    if ($attr->context == Class::Meta::CLASS) {
 
239
        # Create class attribute accessors by creating a closure tha
 
240
        # references this variable.
 
241
        my $data = $attr->default;
 
242
 
 
243
        if ($create >= Class::Meta::GET) {
 
244
            # Create GET accessor.
 
245
            $get = sub { $data };
 
246
        }
 
247
 
 
248
        if ($create >= Class::Meta::SET) {
 
249
            # Create SET accessor.
 
250
            if (@checks) {
 
251
                $set = sub {
 
252
                    # Check the value passed in.
 
253
                    $_->($_[1], { $name => $data,
 
254
                                  __pkg => ref $_[0] || $_[0] },
 
255
                         $attr) for @checks;
 
256
                    # Assign the value.
 
257
                    $data = $_[1];
 
258
                };
 
259
            } else {
 
260
                $set = sub {
 
261
                    # Assign the value.
 
262
                    $data = $_[1];
 
263
                };
 
264
            }
 
265
        }
 
266
    } else {
 
267
        # Create object attribute accessors.
 
268
        if ($create >= Class::Meta::GET) {
 
269
            # Create GET accessor.
 
270
            $get = sub { $_[0]->{$name} };
 
271
        }
 
272
 
 
273
        if ($create >= Class::Meta::SET) {
 
274
            # Create SET accessor.
 
275
            if (@checks) {
 
276
                $set = sub {
 
277
                    # Check the value passed in.
 
278
                    $_->($_[1], $_[0], $attr) for @checks;
 
279
                    # Assign the value.
 
280
                    $_[0]->{$name} = $_[1];
 
281
                };
 
282
            } else {
 
283
                $set = sub {
 
284
                    # Assign the value.
 
285
                    $_[0]->{$name} = $_[1];
 
286
                };
 
287
            }
 
288
        }
 
289
    }
 
290
 
 
291
    # Add public and private checks, if required.
 
292
    if ($attr->view == Class::Meta::PROTECTED) {
 
293
        for ($get, $set) {
 
294
            my $real_sub = $_ or next;
 
295
            $_ = sub {
 
296
                my $caller = caller;
 
297
                # Circumvent generated constructors.
 
298
                for (my $i = 1; $caller eq 'Class::Meta::Constructor'; $i++) {
 
299
                    $caller = caller($i);
 
300
                }
 
301
                $attr->class->handle_error("$name is a protected attribute "
 
302
                                             . "of $pkg")
 
303
                  unless UNIVERSAL::isa($caller, $pkg);
 
304
                goto &$real_sub;
 
305
            };
 
306
        }
 
307
    } elsif ($attr->view == Class::Meta::PRIVATE) {
 
308
        for ($get, $set) {
 
309
            my $real_sub = $_ or next;
 
310
            $_ = sub {
 
311
                my $caller = caller;
 
312
                # Circumvent generated constructors.
 
313
                for (my $i = 1; $caller eq 'Class::Meta::Constructor'; $i++) {
 
314
                    $caller = caller($i);
 
315
                }
 
316
             $attr->class->handle_error("$name is a private attribute of $pkg")
 
317
               unless $caller eq $pkg;
 
318
                goto &$real_sub;
 
319
            };
 
320
        }
 
321
    } elsif ($attr->view == Class::Meta::TRUSTED) {
 
322
        # XXX Should we have an accessor for this?
 
323
        my $trusted = $attr->class->{trusted};
 
324
        for ($get, $set) {
 
325
            my $real_sub = $_ or next;
 
326
            $_ = sub {
 
327
                my $caller = caller;
 
328
                # Circumvent generated constructors.
 
329
                for (my $i = 1; $caller eq 'Class::Meta::Constructor'; $i++) {
 
330
                    $caller = caller($i);
 
331
                }
 
332
                goto &$real_sub if $caller eq $pkg;
 
333
                for my $pack (@{$trusted}) {
 
334
                    goto &$real_sub if UNIVERSAL::isa($caller, $pack);
 
335
                }
 
336
                $attr->class->handle_error("$name is a trusted attribute of $pkg");
 
337
            };
 
338
        }
 
339
    }
 
340
    return ($pkg, $attr, $name, $get, $set);
 
341
}
 
342
 
 
343
1;
 
344
__END__
 
345
 
 
346
=head1 BUGS
 
347
 
 
348
Please send bug reports to <bug-class-meta@rt.cpan.org> or report them via the
 
349
CPAN Request Tracker at L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.
 
350
 
 
351
=head1 AUTHOR
 
352
 
 
353
David Wheeler <david@kineticode.com>
 
354
 
 
355
=head1 SEE ALSO
 
356
 
 
357
=over 4
 
358
 
 
359
=item L<Class::Meta|Class::Meta>
 
360
 
 
361
This class contains most of the documentation you need to get started with
 
362
Class::Meta.
 
363
 
 
364
=item L<Class::Meta::AccessorBuilder|Class::Meta::AccessorBuilder>
 
365
 
 
366
This module generates Perl style accessors.
 
367
 
 
368
=item L<Class::Meta::Type|Class::Meta::Type>
 
369
 
 
370
This class manages the creation of data types.
 
371
 
 
372
=item L<Class::Meta::Attribute|Class::Meta::Attribute>
 
373
 
 
374
This class manages Class::Meta class attributes, most of which will have
 
375
generated accessors.
 
376
 
 
377
=back
 
378
 
 
379
=head1 COPYRIGHT AND LICENSE
 
380
 
 
381
Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
 
382
 
 
383
This module is free software; you can redistribute it and/or modify it under
 
384
the same terms as Perl itself.
 
385
 
 
386
=cut