← Back to branch summary

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

« back to all changes in this revision

Viewing changes to lib/Class/Meta/Attribute.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/Attribute.pm
 
1
package Class::Meta::Attribute;
 
2
 
 
3
# $Id: Attribute.pm 2405 2005-12-17 03:41:09Z theory $
 
4
 
 
5
=head1 NAME
 
6
 
 
7
Class::Meta::Attribute - Class::Meta class attribute introspection
 
8
 
 
9
=head1 SYNOPSIS
 
10
 
 
11
  # Assuming MyApp::Thingy was generated by Class::Meta.
 
12
  my $class = MyApp::Thingy->my_class;
 
13
  my $thingy = MyApp::Thingy->new;
 
14
 
 
15
  print "\nAttributes:\n";
 
16
  for my $attr ($class->attributes) {
 
17
      print "  o ", $attr->name, " => ", $attr->get($thingy), $/;
 
18
      if ($attr->authz >= Class::Meta::SET && $attr->type eq 'string') {
 
19
          $attr->get($thingy, 'hey there!');
 
20
          print "    Changed to: ", $attr->get($thingy) $/;
 
21
      }
 
22
  }
 
23
 
 
24
=head1 DESCRIPTION
 
25
 
 
26
An object of this class describes an attribute of a class created by
 
27
Class::Meta. It includes metadata such as the name of the attribute, its data
 
28
type, its accessibility, and whether or not a value is required. It also
 
29
provides methods to easily get and set the value of the attribute for a given
 
30
instance of the class.
 
31
 
 
32
Class::Meta::Attribute objects are created by Class::Meta; they are never
 
33
instantiated directly in client code. To access the attribute objects for a
 
34
Class::Meta-generated class, simply call its C<my_class()> method to retrieve
 
35
its Class::Meta::Class object, and then call the C<attributes()> method on the
 
36
Class::Meta::Class object.
 
37
 
 
38
=cut
 
39
 
 
40
##############################################################################
 
41
# Dependencies                                                               #
 
42
##############################################################################
 
43
use strict;
 
44
 
 
45
##############################################################################
 
46
# Package Globals                                                            #
 
47
##############################################################################
 
48
our $VERSION = "0.52";
 
49
 
 
50
##############################################################################
 
51
# Constructors                                                               #
 
52
##############################################################################
 
53
 
 
54
=head1 INTERFACE
 
55
 
 
56
=head2 Constructors
 
57
 
 
58
=head3 new
 
59
 
 
60
A protected method for constructing a Class::Meta::Attribute object. Do not
 
61
call this method directly; Call the
 
62
L<C<add_attribute()>|Class::Meta/"add_attribute"> method on a Class::Meta
 
63
object, instead.
 
64
 
 
65
=cut
 
66
 
 
67
sub new {
 
68
    my $pkg = shift;
 
69
    my $class = shift;
 
70
 
 
71
    # Check to make sure that only Class::Meta or a subclass is constructing a
 
72
    # Class::Meta::Attribute object.
 
73
    my $caller = caller;
 
74
    Class::Meta->handle_error("Package '$caller' cannot create $pkg "
 
75
                              . "objects")
 
76
      unless UNIVERSAL::isa($caller, 'Class::Meta')
 
77
        || UNIVERSAL::isa($caller, __PACKAGE__);
 
78
 
 
79
    # Make sure we can get all the arguments.
 
80
    $class->handle_error("Odd number of parameters in call to new() when "
 
81
                         . "named parameters were expected")
 
82
      if @_ % 2;
 
83
    my %p = @_;
 
84
 
 
85
    # Validate the name.
 
86
    $class->handle_error("Parameter 'name' is required in call to new()")
 
87
      unless $p{name};
 
88
    # Is this too paranoid?
 
89
    $class->handle_error("Attribute '$p{name}' is not a valid attribute "
 
90
                         . "name -- only alphanumeric and '_' characters "
 
91
                         . "allowed")
 
92
      if $p{name} =~ /\W/;
 
93
 
 
94
    # Grab the package name.
 
95
    $p{package} = $class->{package};
 
96
 
 
97
    # Set the required and once attributes.
 
98
    for (qw(required once)) {
 
99
        $p{$_} = $p{$_} ? 1 : 0;
 
100
    }
 
101
 
 
102
    # Make sure the name hasn't already been used for another attribute
 
103
    $class->handle_error("Attribute '$p{name}' already exists in class '"
 
104
                         . $class->{attrs}{$p{name}}{package} . "'")
 
105
      if ! delete $p{override} && exists $class->{attrs}{$p{name}};
 
106
 
 
107
    # Check the view.
 
108
    if (exists $p{view}) {
 
109
        $class->handle_error("Not a valid view parameter: "
 
110
                                     . "'$p{view}'")
 
111
          unless $p{view} == Class::Meta::PUBLIC
 
112
          or     $p{view} == Class::Meta::PROTECTED
 
113
          or     $p{view} == Class::Meta::TRUSTED
 
114
          or     $p{view} == Class::Meta::PRIVATE;
 
115
    } else {
 
116
        # Make it public by default.
 
117
        $p{view} = Class::Meta::PUBLIC;
 
118
    }
 
119
 
 
120
    # Check the authorization level.
 
121
    if (exists $p{authz}) {
 
122
        $class->handle_error("Not a valid authz parameter: "
 
123
                                     . "'$p{authz}'")
 
124
          unless $p{authz} == Class::Meta::NONE
 
125
          or     $p{authz} == Class::Meta::READ
 
126
          or     $p{authz} == Class::Meta::WRITE
 
127
          or     $p{authz} == Class::Meta::RDWR;
 
128
    } else {
 
129
        # Make it read/write by default.
 
130
        $p{authz} = Class::Meta::RDWR;
 
131
    }
 
132
 
 
133
    # Check the creation constant.
 
134
    if (exists $p{create}) {
 
135
        $class->handle_error("Not a valid create parameter: "
 
136
                                     . "'$p{create}'")
 
137
          unless $p{create} == Class::Meta::NONE
 
138
          or     $p{create} == Class::Meta::GET
 
139
          or     $p{create} == Class::Meta::SET
 
140
          or     $p{create} == Class::Meta::GETSET;
 
141
    } else {
 
142
        # Rely on the authz setting by default.
 
143
        $p{create} = $p{authz};
 
144
    }
 
145
 
 
146
    # Check the context.
 
147
    if (exists $p{context}) {
 
148
        $class->handle_error("Not a valid context parameter: "
 
149
                                     . "'$p{context}'")
 
150
          unless $p{context} == Class::Meta::OBJECT
 
151
          or     $p{context} == Class::Meta::CLASS;
 
152
    } else {
 
153
        # Put it in object context by default.
 
154
        $p{context} = Class::Meta::OBJECT;
 
155
    }
 
156
 
 
157
    # Check the default.
 
158
    if (exists $p{default}) {
 
159
        # A code ref should be executed when the default is called.
 
160
        $p{_def_code} = delete $p{default}
 
161
          if ref $p{default} eq 'CODE';
 
162
    }
 
163
 
 
164
    # Create and cache the attribute object.
 
165
    $class->{attrs}{$p{name}} = bless \%p, ref $pkg || $pkg;
 
166
 
 
167
    # Index its view.
 
168
    push @{ $class->{all_attr_ord} }, $p{name};
 
169
    if ($p{view} > Class::Meta::PRIVATE) {
 
170
        push @{$class->{prot_attr_ord}}, $p{name}
 
171
          unless $p{view} == Class::Meta::TRUSTED;
 
172
        if ($p{view} > Class::Meta::PROTECTED) {
 
173
            push @{$class->{trst_attr_ord}}, $p{name};
 
174
            push @{$class->{attr_ord}}, $p{name}
 
175
              if $p{view} == Class::Meta::PUBLIC;
 
176
        }
 
177
    }
 
178
 
 
179
    # Store a reference to the class object.
 
180
    $p{class} = $class;
 
181
 
 
182
    # Let 'em have it.
 
183
    return $class->{attrs}{$p{name}};
 
184
}
 
185
 
 
186
##############################################################################
 
187
# Instance Methods                                                           #
 
188
##############################################################################
 
189
 
 
190
=head2 Instance Methods
 
191
 
 
192
=head3 name
 
193
 
 
194
  my $name = $attr->name;
 
195
 
 
196
Returns the name of the attribute.
 
197
 
 
198
=head3 type
 
199
 
 
200
  my $type = $attr->type;
 
201
 
 
202
Returns the name of the attribute's data type. Typical values are "scalar",
 
203
"string", and "boolean". See L<Class::Meta|Class::Meta/"Data Types"> for a
 
204
complete list.
 
205
 
 
206
=head3 desc
 
207
 
 
208
  my $desc = $attr->desc;
 
209
 
 
210
Returns a description of the attribute.
 
211
 
 
212
=head3 label
 
213
 
 
214
  my $label = $attr->label;
 
215
 
 
216
Returns a label for the attribute, suitable for use in a user interface. It is
 
217
distinguished from the attribute name, which functions to name the accessor
 
218
methods for the attribute.
 
219
 
 
220
=head3 required
 
221
 
 
222
  my $req = $attr->required;
 
223
 
 
224
Indicates if the attribute is required to have a value.
 
225
 
 
226
=head3 once
 
227
 
 
228
  my $once = $attr->once;
 
229
 
 
230
Indicates whether an attribute value can be set to a defined value only once.
 
231
 
 
232
=head3 package
 
233
 
 
234
  my $package = $attr->package;
 
235
 
 
236
Returns the package name of the class that attribute is associated with.
 
237
 
 
238
=head3 view
 
239
 
 
240
  my $view = $attr->view;
 
241
 
 
242
Returns the view of the attribute, reflecting its visibility. The possible
 
243
values are defined by the following constants:
 
244
 
 
245
=over 4
 
246
 
 
247
=item Class::Meta::PUBLIC
 
248
 
 
249
=item Class::Meta::PRIVATE
 
250
 
 
251
=item Class::Meta::TRUSTED
 
252
 
 
253
=item Class::Meta::PROTECTED
 
254
 
 
255
=back
 
256
 
 
257
=head3 context
 
258
 
 
259
  my $context = $attr->context;
 
260
 
 
261
Returns the context of the attribute, essentially whether it is a class or
 
262
object attribute. The possible values are defined by the following constants:
 
263
 
 
264
=over 4
 
265
 
 
266
=item Class::Meta::CLASS
 
267
 
 
268
=item Class::Meta::OBJECT
 
269
 
 
270
=back
 
271
 
 
272
=head3 authz
 
273
 
 
274
  my $authz = $attr->authz;
 
275
 
 
276
Returns the authorization for the attribute, which determines whether it can be
 
277
read or changed. The possible values are defined by the following constants:
 
278
 
 
279
=over 4
 
280
 
 
281
=item Class::Meta::READ
 
282
 
 
283
=item Class::Meta::WRITE
 
284
 
 
285
=item Class::Meta::RDWR
 
286
 
 
287
=item Class::Meta::NONE
 
288
 
 
289
=back
 
290
 
 
291
=head3 class
 
292
 
 
293
  my $class = $attr->class;
 
294
 
 
295
Returns the Class::Meta::Class object that this attribute is associated
 
296
with. Note that this object will always represent the class in which the
 
297
attribute is defined, and I<not> any of its subclasses.
 
298
 
 
299
=cut
 
300
 
 
301
sub name     { $_[0]->{name}     }
 
302
sub type     { $_[0]->{type}     }
 
303
sub desc     { $_[0]->{desc}     }
 
304
sub label    { $_[0]->{label}    }
 
305
sub required { $_[0]->{required} }
 
306
sub once     { $_[0]->{once}     }
 
307
sub package  { $_[0]->{package}  }
 
308
sub view     { $_[0]->{view}     }
 
309
sub context  { $_[0]->{context}  }
 
310
sub authz    { $_[0]->{authz}    }
 
311
sub class    { $_[0]->{class}    }
 
312
 
 
313
##############################################################################
 
314
 
 
315
=head3 default
 
316
 
 
317
  my $default = $attr->default;
 
318
 
 
319
Returns the default value for a new instance of this attribute. Since the
 
320
default value can be determined dynamically, the value returned by
 
321
C<default()> may change on subsequent calls. It all depends on what was
 
322
passed for the C<default> parameter in the call to C<add_attribute()> on the
 
323
Class::Meta object that generated the class.
 
324
 
 
325
=cut
 
326
 
 
327
sub default {
 
328
    if (my $code = $_[0]->{_def_code}) {
 
329
        return $code->();
 
330
    }
 
331
    return $_[0]->{default};
 
332
}
 
333
 
 
334
##############################################################################
 
335
 
 
336
=head3 get
 
337
 
 
338
  my $value = $attr->get($thingy);
 
339
 
 
340
This method calls the "get" accessor method on the object passed as the sole
 
341
argument and returns the value of the attribute for that object. Note that it
 
342
uses a C<goto> to execute the accessor, so the call to C<set()> itself
 
343
will not appear in a call stack trace.
 
344
 
 
345
=cut
 
346
 
 
347
sub get {
 
348
    my $self = shift;
 
349
    my $code = $self->{_get}
 
350
      or $self->class->handle_error("Cannot get attribute '",
 
351
                                    $self->name, "'");
 
352
    goto &$code;
 
353
}
 
354
 
 
355
##############################################################################
 
356
 
 
357
=head3 set
 
358
 
 
359
  $attr->set($thingy, $new_value);
 
360
 
 
361
This method calls the "set" accessor method on the object passed as the first
 
362
argument and passes any remaining arguments to assign a new value to the
 
363
attribute for that object. Note that it uses a C<goto> to execute the
 
364
accessor, so the call to C<set()> itself will not appear in a call stack
 
365
trace.
 
366
 
 
367
=cut
 
368
 
 
369
sub set {
 
370
    my $self = shift;
 
371
    my $code = $self->{_set}
 
372
      or $self->class->handle_error("Cannot set attribute '",
 
373
                                    $self->name, "'");
 
374
    goto &$code;
 
375
}
 
376
 
 
377
##############################################################################
 
378
 
 
379
=head3 build
 
380
 
 
381
  $attr->build($class);
 
382
 
 
383
This is a protected method, designed to be called only by the Class::Meta
 
384
class or a subclass of Class::Meta. It takes a single argument, the
 
385
Class::Meta::Class object for the class in which the attribute was defined,
 
386
and generates attribute accessors by calling out to the C<make_attr_get()> and
 
387
C<make_attr_set()> methods of Class::Meta::Type as appropriate for the
 
388
Class::Meta::Attribute object.
 
389
 
 
390
Although you should never call this method directly, subclasses of
 
391
Class::Meta::Constructor may need to override its behavior.
 
392
 
 
393
=cut
 
394
 
 
395
sub build {
 
396
    my ($self, $class) = @_;
 
397
 
 
398
    # Check to make sure that only Class::Meta or a subclass is building
 
399
    # attribute accessors.
 
400
    my $caller = caller;
 
401
    $self->class->handle_error("Package '$caller' cannot call " . ref($self)
 
402
                               . "->build")
 
403
      unless UNIVERSAL::isa($caller, 'Class::Meta')
 
404
        || UNIVERSAL::isa($caller, __PACKAGE__);
 
405
 
 
406
    # Get the data type object, replace any alias, and assemble the
 
407
    # validation checks.
 
408
    my $type = Class::Meta::Type->new($self->{type});
 
409
    $self->{type} = $type->key;
 
410
    my $create = delete $self->{create};
 
411
    $type->build($class->{package}, $self, $create)
 
412
      if $create != Class::Meta::NONE;
 
413
 
 
414
    # Create the attribute object get code reference.
 
415
    if ($self->{authz} >= Class::Meta::READ) {
 
416
        $self->{_get} = $type->make_attr_get($self);
 
417
    }
 
418
 
 
419
    # Create the attribute object set code reference.
 
420
    if ($self->{authz} >= Class::Meta::WRITE) {
 
421
        $self->{_set} = $type->make_attr_set($self);
 
422
    }
 
423
 
 
424
}
 
425
 
 
426
1;
 
427
__END__
 
428
 
 
429
=head1 BUGS
 
430
 
 
431
Please send bug reports to <bug-class-meta@rt.cpan.org> or report them via the
 
432
CPAN Request Tracker at L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.
 
433
 
 
434
=head1 AUTHOR
 
435
 
 
436
David Wheeler <david@kineticode.com>
 
437
 
 
438
=head1 SEE ALSO
 
439
 
 
440
Other classes of interest within the Class::Meta distribution include:
 
441
 
 
442
=over 4
 
443
 
 
444
=item L<Class::Meta|Class::Meta>
 
445
 
 
446
=item L<Class::Meta::Class|Class::Meta::Class>
 
447
 
 
448
=item L<Class::Meta::Method|Class::Meta::Method>
 
449
 
 
450
=item L<Class::Meta::Constructor|Class::Meta::Constructor>
 
451
 
 
452
=item L<Class::Meta::Type|Class::Meta::Type>
 
453
 
 
454
=back
 
455
 
 
456
=head1 COPYRIGHT AND LICENSE
 
457
 
 
458
Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
 
459
 
 
460
This module is free software; you can redistribute it and/or modify it under
 
461
the same terms as Perl itself.
 
462
 
 
463
=cut