← 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/Class.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/Class.pm
 
1
package Class::Meta::Class;
 
2
 
 
3
# $Id: Class.pm 2405 2005-12-17 03:41:09Z theory $
 
4
 
 
5
=head1 NAME
 
6
 
 
7
Class::Meta::Class - Class::Meta class 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 "Examining object of class ", $class->package, $/;
 
16
 
 
17
  print "\nConstructors:\n";
 
18
  for my $ctor ($class->constructors) {
 
19
      print "  o ", $ctor->name, $/;
 
20
  }
 
21
 
 
22
  print "\nAttributes:\n";
 
23
  for my $attr ($class->attributes) {
 
24
      print "  o ", $attr->name, " => ", $attr->get($thingy) $/;
 
25
  }
 
26
 
 
27
  print "\nMethods:\n";
 
28
  for my $meth ($class->methods) {
 
29
      print "  o ", $meth->name, $/;
 
30
  }
 
31
 
 
32
=head1 DESCRIPTION
 
33
 
 
34
Object of this class describe classes created by Class::Meta. They contain
 
35
everything you need to know about a class to be able to put objects of that
 
36
class to good use. In addition to retrieving metadata about the class itself,
 
37
you can retrieve objects that describe the constructors, attributes, and
 
38
methods of the class. See C<Class::Meta|Class::Meta> for a fuller description
 
39
of the utility of the Class::Meta suite of modules.
 
40
 
 
41
Class::Meta::Class objects are created by Class::Meta; they are never
 
42
instantiated directly in client code. To access the class object for a
 
43
Class::Meta-generated class, simply call its C<my_class()> method.
 
44
 
 
45
At this point, those attributes tend to be database-specific. Once other types
 
46
of data stores are added (XML, LDAP, etc.), other attributes may be added to
 
47
allow their schemas to be built, as well.
 
48
 
 
49
=cut
 
50
 
 
51
##############################################################################
 
52
# Dependencies                                                               #
 
53
##############################################################################
 
54
use strict;
 
55
use Class::ISA ();
 
56
use Class::Meta;
 
57
use Class::Meta::Attribute;
 
58
use Class::Meta::Method;
 
59
 
 
60
##############################################################################
 
61
# Package Globals                                                            #
 
62
##############################################################################
 
63
our $VERSION = "0.52";
 
64
our @CARP_NOT = qw(Class::Meta);
 
65
 
 
66
=head1 INTERFACE
 
67
 
 
68
=head2 Constructors
 
69
 
 
70
=head3 new
 
71
 
 
72
A protected method for constructing a Class::Meta::Class object. Do not call
 
73
this method directly; Call the L<C<new()>|Class::Meta/new"> constructor on a
 
74
Class::Meta object, instead. A Class::Meta::Class object will be constructed
 
75
by default, and can always be retreived via the C<my_class()> method of the
 
76
class for which it was constructed.
 
77
 
 
78
=cut
 
79
 
 
80
##############################################################################
 
81
 
 
82
sub new {
 
83
    my ($pkg, $spec) = @_;
 
84
    # Check to make sure that only Class::Meta or a subclass is
 
85
    # constructing a Class::Meta::Class object.
 
86
    my $caller = caller;
 
87
    Class::Meta->handle_error("Package '$caller' cannot create $pkg objects")
 
88
      unless UNIVERSAL::isa($caller, 'Class::Meta')
 
89
      || UNIVERSAL::isa($caller, __PACKAGE__);
 
90
 
 
91
    # Set the name to be the same as the key by default.
 
92
    $spec->{name} = $spec->{key} unless defined $spec->{name};
 
93
 
 
94
    # Set the abstract attribute.
 
95
    $spec->{abstract} = $spec->{abstract} ? 1 : 0;
 
96
 
 
97
    # Set the trusted attribute.
 
98
    $spec->{trusted} = exists $spec->{trust}
 
99
      ? ref $spec->{trust} ? delete $spec->{trust} : [ delete $spec->{trust} ]
 
100
      : [];
 
101
 
 
102
    # Okay, create the class object.
 
103
    my $self = bless $spec, ref $pkg || $pkg;
 
104
}
 
105
 
 
106
##############################################################################
 
107
# Instance Methods
 
108
##############################################################################
 
109
 
 
110
=head2 Instance Methods
 
111
 
 
112
=head3 package
 
113
 
 
114
  my $pkg = $class->package;
 
115
 
 
116
Returns the name of the package that the Class::Meta::Class object describes.
 
117
 
 
118
=head3 key
 
119
 
 
120
  my $key = $class->key;
 
121
 
 
122
Returns the key name that uniquely identifies the class across the
 
123
application. The key name may simply be the same as the package name.
 
124
 
 
125
=head3 name
 
126
 
 
127
  my $name = $class->name;
 
128
 
 
129
Returns the name of the the class. This should generally be a descriptive
 
130
name, rather than a package name.
 
131
 
 
132
=head3 desc
 
133
 
 
134
  my $desc = $class->desc;
 
135
 
 
136
Returns a description of the class.
 
137
 
 
138
=head3 abstract
 
139
 
 
140
  my $abstract = $class->abstract;
 
141
 
 
142
Returns true if the class is an abstract class, and false if it is not.
 
143
 
 
144
=cut
 
145
 
 
146
sub package  { $_[0]->{package}  }
 
147
sub key      { $_[0]->{key}      }
 
148
sub name     { $_[0]->{name}     }
 
149
sub desc     { $_[0]->{desc}     }
 
150
sub abstract { $_[0]->{abstract} }
 
151
 
 
152
##############################################################################
 
153
 
 
154
=head3 is_a
 
155
 
 
156
  if ($class->is_a('MyApp::Base')) {
 
157
      print "All your base are belong to us\n";
 
158
  }
 
159
 
 
160
This method returns true if the object or package name passed as an argument
 
161
is an instance of the class described by the Class::Meta::Class object or one
 
162
of its subclasses. Functionally equivalent to
 
163
C<< $class->package->isa($pkg) >>, but more efficient.
 
164
 
 
165
=cut
 
166
 
 
167
sub is_a { UNIVERSAL::isa($_[0]->{package}, $_[1]) }
 
168
 
 
169
##############################################################################
 
170
# Accessors to get at the constructor, attribute, and method objects.
 
171
##############################################################################
 
172
 
 
173
=head3 constructors
 
174
 
 
175
  my @constructors = $class->constructors;
 
176
  my $ctor = $class->constructors($ctor_name);
 
177
  @constructors = $class->constructors(@ctor_names);
 
178
 
 
179
Provides access to the Class::Meta::Constructor objects that describe the
 
180
constructors for the class. When called with no arguments, it returns all of
 
181
the constructor objects. When called with a single argument, it returns the
 
182
constructor object for the constructor with the specified name. When called
 
183
with a list of arguments, returns all of the constructor objects with the
 
184
specified names.
 
185
 
 
186
=cut
 
187
 
 
188
##############################################################################
 
189
 
 
190
=head3 attributes
 
191
 
 
192
  my @attributes = $class->attributes;
 
193
  my $attr = $class->attributes($attr_name);
 
194
  @attributes = $class->attributes(@attr_names);
 
195
 
 
196
Provides access to the Class::Meta::Attribute objects that describe the
 
197
attributes for the class. When called with no arguments, it returns all of the
 
198
attribute objects. When called with a single argument, it returns the
 
199
attribute object for the attribute with the specified name. When called with a
 
200
list of arguments, returns all of the attribute objects with the specified
 
201
names.
 
202
 
 
203
=cut
 
204
 
 
205
##############################################################################
 
206
 
 
207
=head3 methods
 
208
 
 
209
  my @methods = $class->methods;
 
210
  my $meth = $class->methods($meth_name);
 
211
  @methods = $class->methods(@meth_names);
 
212
 
 
213
Provides access to the Class::Meta::Method objects that describe the methods
 
214
for the class. When called with no arguments, it returns all of the method
 
215
objects. When called with a single argument, it returns the method object for
 
216
the method with the specified name. When called with a list of arguments,
 
217
returns all of the method objects with the specified names.
 
218
 
 
219
=cut
 
220
 
 
221
for ([qw(attributes attr)], [qw(methods meth)], [qw(constructors ctor)]) {
 
222
    my ($meth, $key) = @$_;
 
223
    no strict 'refs';
 
224
    *{$meth} = sub {
 
225
        my $self = shift;
 
226
        my $objs = $self->{"${key}s"};
 
227
        # Who's talking to us?
 
228
        my $caller = caller;
 
229
        for (my $i = 1; UNIVERSAL::isa($caller, __PACKAGE__); $i++) {
 
230
            $caller = caller($i);
 
231
        }
 
232
        # XXX Do we want to make these additive instead of discreet, so that
 
233
        # a class can get both protected and trusted attributes, for example?
 
234
        my $list = do {
 
235
            if (@_) {
 
236
                # Explicit list requested.
 
237
                \@_;
 
238
            } elsif ($caller eq $self->{package}) {
 
239
                # List of protected interface objects.
 
240
                $self->{"priv_$key\_ord"} || [];
 
241
            } elsif (UNIVERSAL::isa($caller, $self->{package})) {
 
242
                # List of protected interface objects.
 
243
                $self->{"prot_$key\_ord"} || [];
 
244
            } elsif (_trusted($self, $caller)) {
 
245
                # List of trusted interface objects.
 
246
                $self->{"trst_$key\_ord"} || [];
 
247
            } else {
 
248
                # List of public interface objects.
 
249
                $self->{"$key\_ord"} || [];
 
250
            }
 
251
        };
 
252
        return @$list == 1 ? $objs->{$list->[0]} : @{$objs}{@$list};
 
253
    };
 
254
}
 
255
 
 
256
##############################################################################
 
257
 
 
258
=head3 parents
 
259
 
 
260
  my @parents = $class->parents;
 
261
 
 
262
Returns a list of Class::Meta::Class objects representing all of the
 
263
Class::Meta-built parent classes of a class.
 
264
 
 
265
=cut
 
266
 
 
267
sub parents {
 
268
    my $self = shift;
 
269
    return map { $_->my_class } grep { UNIVERSAL::can($_, 'my_class') }
 
270
      Class::ISA::super_path($self->package);
 
271
}
 
272
 
 
273
##############################################################################
 
274
 
 
275
=head3 handle_error
 
276
 
 
277
  $class->handle_error($error)
 
278
 
 
279
Handles Class::Meta-related errors using either the error handler specified
 
280
when the Class::Meta::Class object was created or the default error handler at
 
281
the time the Class::Meta::Class object was created.
 
282
 
 
283
=cut
 
284
 
 
285
sub handle_error {
 
286
    my $code = shift->{error_handler};
 
287
    $code->(join '', @_)
 
288
}
 
289
 
 
290
##############################################################################
 
291
 
 
292
=head3 build
 
293
 
 
294
  $class->build($classes);
 
295
 
 
296
This is a protected method, designed to be called only by the Class::Meta
 
297
class or a subclass of Class::Meta. It copies the attribute, constructor, and
 
298
method objects from all of the parent classes of the class object so that they
 
299
will be readily available from the C<attributes()>, C<constructors()>, and
 
300
C<methods()> methods. Its sole argument is a reference to the hash of all
 
301
Class::Meta::Class objects (keyed off their package names) stored by
 
302
Class::Meta.
 
303
 
 
304
Although you should never call this method directly, subclasses of
 
305
Class::Meta::Class may need to override its behavior.
 
306
 
 
307
=cut
 
308
 
 
309
sub build {
 
310
    my ($self, $classes) = @_;
 
311
 
 
312
    # Check to make sure that only Class::Meta or a subclass is building
 
313
    # attribute accessors.
 
314
    my $caller = caller;
 
315
    $self->handle_error("Package '$caller' cannot call " . ref($self)
 
316
                        . "->build")
 
317
      unless UNIVERSAL::isa($caller, 'Class::Meta')
 
318
      || UNIVERSAL::isa($caller, __PACKAGE__);
 
319
 
 
320
    # Copy attributes again to make sure that overridden attributes
 
321
    # truly override.
 
322
    $self->_inherit($classes, qw(ctor meth attr));
 
323
}
 
324
 
 
325
##############################################################################
 
326
# Private Methods.
 
327
##############################################################################
 
328
 
 
329
sub _inherit {
 
330
    my $self = shift;
 
331
    my $classes = shift;
 
332
 
 
333
    # Get a list of all of the parent classes.
 
334
    my $package = $self->package;
 
335
    my @classes = reverse Class::ISA::self_and_super_path($package);
 
336
 
 
337
    # Hrm, how can I avoid iterating over the classes a second time?
 
338
    my @trusted;
 
339
    for my $super (@classes) {
 
340
        push @trusted, @{$classes->{$super}{trusted}}
 
341
          if $classes->{$super}{trusted};
 
342
    }
 
343
    $self->{trusted} = \@trusted if @trusted;
 
344
 
 
345
    # For each metadata class, copy the parents' objects.
 
346
    for my $key (@_) {
 
347
        my (@lookup, @all, @ord, @prot, @trst, @priv, %sall, %sord, %sprot, %strst);
 
348
        for my $super (@classes) {
 
349
            my $class = $classes->{$super};
 
350
            if (my $things = $class->{$key . 's'}) {
 
351
                push @lookup, %{ $things };
 
352
 
 
353
                if (my $ord = $class->{"$key\_ord"}) {
 
354
                    push @ord, grep { not $sord{$_}++ }   @{ $ord} ;
 
355
                }
 
356
 
 
357
                if (my $prot = $class->{"prot_$key\_ord"}) {
 
358
                    push @prot, grep { not $sprot{$_}++ } @{ $prot };
 
359
                }
 
360
 
 
361
                if (my $trust = $class->{"trst_$key\_ord"}) {
 
362
                    push @trst, grep { not $strst{$_}++ } @{ $trust };
 
363
                }
 
364
 
 
365
                if (my $all = $class->{"all_$key\_ord"}) {
 
366
                    for my $name (@{ $all }) {
 
367
                        next if $sall{$name}++;
 
368
                        push @all, $name;
 
369
                        my $view  = $things->{$name}->view;
 
370
                        push @priv, $name if $super eq $package
 
371
                            || $view == Class::Meta::PUBLIC
 
372
                            || $view == Class::Meta::PROTECTED
 
373
                            || _trusted($class, $package);
 
374
                    }
 
375
                }
 
376
            }
 
377
        }
 
378
 
 
379
        $self->{"${key}s"}        = { @lookup } if @lookup;
 
380
        $self->{"$key\_ord"}      = \@ord       if @ord;
 
381
        $self->{"all_$key\_ord"}  = \@all       if @all;
 
382
        $self->{"prot_$key\_ord"} = \@prot      if @prot;
 
383
        $self->{"trst_$key\_ord"} = \@trst      if @trst;
 
384
        $self->{"priv_$key\_ord"} = \@priv      if @priv;
 
385
    }
 
386
 
 
387
 
 
388
    return $self;
 
389
}
 
390
 
 
391
sub _trusted {
 
392
    my ($self, $caller) = @_;
 
393
    my $trusted = $self->{trusted} or return;
 
394
    for my $pkg (@{$trusted}) {
 
395
        return 1 if UNIVERSAL::isa($caller, $pkg);
 
396
    }
 
397
    return;
 
398
}
 
399
 
 
400
1;
 
401
__END__
 
402
 
 
403
=head1 BUGS
 
404
 
 
405
Please send bug reports to <bug-class-meta@rt.cpan.org> or report them via the
 
406
CPAN Request Tracker at L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.
 
407
 
 
408
=head1 AUTHOR
 
409
 
 
410
David Wheeler <david@kineticode.com>
 
411
 
 
412
=head1 SEE ALSO
 
413
 
 
414
Other classes of interest within the Class::Meta distribution include:
 
415
 
 
416
=over 4
 
417
 
 
418
=item L<Class::Meta|Class::Meta>
 
419
 
 
420
=item L<Class::Meta::Constructor|Class::Meta::Constructor>
 
421
 
 
422
=item L<Class::Meta::Attribute|Class::Meta::Attribute>
 
423
 
 
424
=item L<Class::Meta::Method|Class::Meta::Method>
 
425
 
 
426
=back
 
427
 
 
428
=head1 COPYRIGHT AND LICENSE
 
429
 
 
430
Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
 
431
 
 
432
This module is free software; you can redistribute it and/or modify it under
 
433
the same terms as Perl itself.
 
434
 
 
435
=cut