1
package Class::Meta::Class;
3
# $Id: Class.pm 2405 2005-12-17 03:41:09Z theory $
7
Class::Meta::Class - Class::Meta class introspection
11
# Assuming MyApp::Thingy was generated by Class::Meta.
12
my $class = MyApp::Thingy->my_class;
13
my $thingy = MyApp::Thingy->new;
15
print "Examining object of class ", $class->package, $/;
17
print "\nConstructors:\n";
18
for my $ctor ($class->constructors) {
19
print " o ", $ctor->name, $/;
22
print "\nAttributes:\n";
23
for my $attr ($class->attributes) {
24
print " o ", $attr->name, " => ", $attr->get($thingy) $/;
28
for my $meth ($class->methods) {
29
print " o ", $meth->name, $/;
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.
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.
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.
51
##############################################################################
53
##############################################################################
57
use Class::Meta::Attribute;
58
use Class::Meta::Method;
60
##############################################################################
62
##############################################################################
63
our $VERSION = "0.52";
64
our @CARP_NOT = qw(Class::Meta);
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.
80
##############################################################################
83
my ($pkg, $spec) = @_;
84
# Check to make sure that only Class::Meta or a subclass is
85
# constructing a Class::Meta::Class object.
87
Class::Meta->handle_error("Package '$caller' cannot create $pkg objects")
88
unless UNIVERSAL::isa($caller, 'Class::Meta')
89
|| UNIVERSAL::isa($caller, __PACKAGE__);
91
# Set the name to be the same as the key by default.
92
$spec->{name} = $spec->{key} unless defined $spec->{name};
94
# Set the abstract attribute.
95
$spec->{abstract} = $spec->{abstract} ? 1 : 0;
97
# Set the trusted attribute.
98
$spec->{trusted} = exists $spec->{trust}
99
? ref $spec->{trust} ? delete $spec->{trust} : [ delete $spec->{trust} ]
102
# Okay, create the class object.
103
my $self = bless $spec, ref $pkg || $pkg;
106
##############################################################################
108
##############################################################################
110
=head2 Instance Methods
114
my $pkg = $class->package;
116
Returns the name of the package that the Class::Meta::Class object describes.
120
my $key = $class->key;
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.
127
my $name = $class->name;
129
Returns the name of the the class. This should generally be a descriptive
130
name, rather than a package name.
134
my $desc = $class->desc;
136
Returns a description of the class.
140
my $abstract = $class->abstract;
142
Returns true if the class is an abstract class, and false if it is not.
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} }
152
##############################################################################
156
if ($class->is_a('MyApp::Base')) {
157
print "All your base are belong to us\n";
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.
167
sub is_a { UNIVERSAL::isa($_[0]->{package}, $_[1]) }
169
##############################################################################
170
# Accessors to get at the constructor, attribute, and method objects.
171
##############################################################################
175
my @constructors = $class->constructors;
176
my $ctor = $class->constructors($ctor_name);
177
@constructors = $class->constructors(@ctor_names);
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
188
##############################################################################
192
my @attributes = $class->attributes;
193
my $attr = $class->attributes($attr_name);
194
@attributes = $class->attributes(@attr_names);
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
205
##############################################################################
209
my @methods = $class->methods;
210
my $meth = $class->methods($meth_name);
211
@methods = $class->methods(@meth_names);
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.
221
for ([qw(attributes attr)], [qw(methods meth)], [qw(constructors ctor)]) {
222
my ($meth, $key) = @$_;
226
my $objs = $self->{"${key}s"};
227
# Who's talking to us?
229
for (my $i = 1; UNIVERSAL::isa($caller, __PACKAGE__); $i++) {
230
$caller = caller($i);
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?
236
# Explicit list requested.
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"} || [];
248
# List of public interface objects.
249
$self->{"$key\_ord"} || [];
252
return @$list == 1 ? $objs->{$list->[0]} : @{$objs}{@$list};
256
##############################################################################
260
my @parents = $class->parents;
262
Returns a list of Class::Meta::Class objects representing all of the
263
Class::Meta-built parent classes of a class.
269
return map { $_->my_class } grep { UNIVERSAL::can($_, 'my_class') }
270
Class::ISA::super_path($self->package);
273
##############################################################################
277
$class->handle_error($error)
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.
286
my $code = shift->{error_handler};
290
##############################################################################
294
$class->build($classes);
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
304
Although you should never call this method directly, subclasses of
305
Class::Meta::Class may need to override its behavior.
310
my ($self, $classes) = @_;
312
# Check to make sure that only Class::Meta or a subclass is building
313
# attribute accessors.
315
$self->handle_error("Package '$caller' cannot call " . ref($self)
317
unless UNIVERSAL::isa($caller, 'Class::Meta')
318
|| UNIVERSAL::isa($caller, __PACKAGE__);
320
# Copy attributes again to make sure that overridden attributes
322
$self->_inherit($classes, qw(ctor meth attr));
325
##############################################################################
327
##############################################################################
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);
337
# Hrm, how can I avoid iterating over the classes a second time?
339
for my $super (@classes) {
340
push @trusted, @{$classes->{$super}{trusted}}
341
if $classes->{$super}{trusted};
343
$self->{trusted} = \@trusted if @trusted;
345
# For each metadata class, copy the parents' objects.
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 };
353
if (my $ord = $class->{"$key\_ord"}) {
354
push @ord, grep { not $sord{$_}++ } @{ $ord} ;
357
if (my $prot = $class->{"prot_$key\_ord"}) {
358
push @prot, grep { not $sprot{$_}++ } @{ $prot };
361
if (my $trust = $class->{"trst_$key\_ord"}) {
362
push @trst, grep { not $strst{$_}++ } @{ $trust };
365
if (my $all = $class->{"all_$key\_ord"}) {
366
for my $name (@{ $all }) {
367
next if $sall{$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);
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;
392
my ($self, $caller) = @_;
393
my $trusted = $self->{trusted} or return;
394
for my $pkg (@{$trusted}) {
395
return 1 if UNIVERSAL::isa($caller, $pkg);
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>.
410
David Wheeler <david@kineticode.com>
414
Other classes of interest within the Class::Meta distribution include:
418
=item L<Class::Meta|Class::Meta>
420
=item L<Class::Meta::Constructor|Class::Meta::Constructor>
422
=item L<Class::Meta::Attribute|Class::Meta::Attribute>
424
=item L<Class::Meta::Method|Class::Meta::Method>
428
=head1 COPYRIGHT AND LICENSE
430
Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
432
This module is free software; you can redistribute it and/or modify it under
433
the same terms as Perl itself.