← Back to branch summary

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

« back to all changes in this revision

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