- optimise metaclass-already-exists check in construct_class_instance
- duplicate check into initialize to save a call through
+ * Class::MOP::MOP
+ - Add support for the 'builder' attribute (groditi)
+
+ * Class::MOP::Attribute
+ - Add support for the 'builder' attribute (groditi)
+
+ *t/
+ - Alter tests (005, 014 020, 021) for new builder addition
+
0.43
* Class::MOP::Method::Accessor
- made this a subclass of Class::MOP::Method::Generated
# there is no need to worry about destruction though
# because they should die only when the program dies.
# After all, do package definitions even get reaped?
- my %METAS;
-
- # means of accessing all the metaclasses that have
+ my %METAS;
+
+ # means of accessing all the metaclasses that have
# been initialized thus far (for mugwumps obj browser)
- sub get_all_metaclasses { %METAS }
- sub get_all_metaclass_instances { values %METAS }
- sub get_all_metaclass_names { keys %METAS }
+ sub get_all_metaclasses { %METAS }
+ sub get_all_metaclass_instances { values %METAS }
+ sub get_all_metaclass_names { keys %METAS }
sub get_metaclass_by_name { $METAS{$_[0]} }
- sub store_metaclass_by_name { $METAS{$_[0]} = $_[1] }
- sub weaken_metaclass { weaken($METAS{$_[0]}) }
+ sub store_metaclass_by_name { $METAS{$_[0]} = $_[1] }
+ sub weaken_metaclass { weaken($METAS{$_[0]}) }
sub does_metaclass_exist { exists $METAS{$_[0]} && defined $METAS{$_[0]} }
- sub remove_metaclass_by_name { $METAS{$_[0]} = undef }
-
+ sub remove_metaclass_by_name { $METAS{$_[0]} = undef }
+
# NOTE:
- # We only cache metaclasses, meaning instances of
- # Class::MOP::Class. We do not cache instance of
+ # We only cache metaclasses, meaning instances of
+ # Class::MOP::Class. We do not cache instance of
# Class::MOP::Package or Class::MOP::Module. Mostly
- # because I don't yet see a good reason to do so.
+ # because I don't yet see a good reason to do so.
}
sub load_class {
my $class = shift;
- # see if this is already
+ # see if this is already
# loaded in the symbol table
return 1 if is_class_loaded($class);
# otherwise require it ...
confess "Could not load class ($class) because : $@" if $@;
unless (does_metaclass_exist($class)) {
eval { Class::MOP::Class->initialize($class) };
- confess "Could not initialize class ($class) because : $@" if $@;
+ confess "Could not initialize class ($class) because : $@" if $@;
}
1; # return true if it worked
}
sub is_class_loaded {
- my $class = shift;
- no strict 'refs';
- return 1 if defined ${"${class}::VERSION"} || defined @{"${class}::ISA"};
- foreach (keys %{"${class}::"}) {
- next if substr($_, -2, 2) eq '::';
- return 1 if defined &{"${class}::$_"};
- }
- return 0;
+ my $class = shift;
+ no strict 'refs';
+ return 1 if defined ${"${class}::VERSION"} || defined @{"${class}::ISA"};
+ foreach (keys %{"${class}::"}) {
+ next if substr($_, -2, 2) eq '::';
+ return 1 if defined &{"${class}::$_"};
+ }
+ return 0;
}
## ----------------------------------------------------------------------------
## Setting up our environment ...
## ----------------------------------------------------------------------------
-## Class::MOP needs to have a few things in the global perl environment so
+## Class::MOP needs to have a few things in the global perl environment so
## that it can operate effectively. Those things are done here.
## ----------------------------------------------------------------------------
# ... nothing yet actually ;)
## ----------------------------------------------------------------------------
-## Bootstrapping
+## Bootstrapping
## ----------------------------------------------------------------------------
-## The code below here is to bootstrap our MOP with itself. This is also
+## The code below here is to bootstrap our MOP with itself. This is also
## sometimes called "tying the knot". By doing this, we make it much easier
## to extend the MOP through subclassing and such since now you can use the
-## MOP itself to extend itself.
-##
+## MOP itself to extend itself.
+##
## Yes, I know, thats weird and insane, but it's a good thing, trust me :)
-## ----------------------------------------------------------------------------
+## ----------------------------------------------------------------------------
-# We need to add in the meta-attributes here so that
-# any subclass of Class::MOP::* will be able to
+# We need to add in the meta-attributes here so that
+# any subclass of Class::MOP::* will be able to
# inherit them using &construct_instance
## --------------------------------------------------------
Class::MOP::Package->meta->add_attribute(
Class::MOP::Attribute->new('$!package' => (
reader => {
- # NOTE: we need to do this in order
- # for the instance meta-object to
+ # NOTE: we need to do this in order
+ # for the instance meta-object to
# not fall into meta-circular death
- #
+ #
# we just alias the original method
- # rather than re-produce it here
+ # rather than re-produce it here
'name' => \&Class::MOP::Package::name
},
init_arg => 'package',
'namespace' => \&Class::MOP::Package::namespace
},
# NOTE:
- # protect this from silliness
+ # protect this from silliness
init_arg => '!............( DO NOT DO THIS )............!',
default => sub { \undef }
))
Class::MOP::Package->meta->add_method('initialize' => sub {
my $class = shift;
my $package_name = shift;
- $class->meta->new_object('package' => $package_name, @_);
+ $class->meta->new_object('package' => $package_name, @_);
});
## --------------------------------------------------------
## Class::MOP::Module
# NOTE:
-# yeah this is kind of stretching things a bit,
+# yeah this is kind of stretching things a bit,
# but truthfully the version should be an attribute
-# of the Module, the weirdness comes from having to
-# stick to Perl 5 convention and store it in the
-# $VERSION package variable. Basically if you just
-# squint at it, it will look how you want it to look.
+# of the Module, the weirdness comes from having to
+# stick to Perl 5 convention and store it in the
+# $VERSION package variable. Basically if you just
+# squint at it, it will look how you want it to look.
# Either as a package variable, or as a attribute of
# the metaclass, isn't abstraction great :)
reader => {
# NOTE:
# we just alias the original method
- # rather than re-produce it here
+ # rather than re-produce it here
'version' => \&Class::MOP::Module::version
},
# NOTE:
- # protect this from silliness
+ # protect this from silliness
init_arg => '!............( DO NOT DO THIS )............!',
default => sub { \undef }
))
);
# NOTE:
-# By following the same conventions as version here,
-# we are opening up the possibility that people can
-# use the $AUTHORITY in non-Class::MOP modules as
-# well.
+# By following the same conventions as version here,
+# we are opening up the possibility that people can
+# use the $AUTHORITY in non-Class::MOP modules as
+# well.
Class::MOP::Module->meta->add_attribute(
Class::MOP::Attribute->new('$!authority' => (
reader => {
# NOTE:
# we just alias the original method
- # rather than re-produce it here
+ # rather than re-produce it here
'authority' => \&Class::MOP::Module::authority
- },
+ },
# NOTE:
- # protect this from silliness
+ # protect this from silliness
init_arg => '!............( DO NOT DO THIS )............!',
default => sub { \undef }
))
Class::MOP::Class->meta->add_attribute(
Class::MOP::Attribute->new('%!attributes' => (
reader => {
- # NOTE: we need to do this in order
- # for the instance meta-object to
- # not fall into meta-circular death
- #
+ # NOTE: we need to do this in order
+ # for the instance meta-object to
+ # not fall into meta-circular death
+ #
# we just alias the original method
- # rather than re-produce it here
+ # rather than re-produce it here
'get_attribute_map' => \&Class::MOP::Class::get_attribute_map
},
init_arg => 'attributes',
Class::MOP::Class->meta->add_attribute(
Class::MOP::Attribute->new('%!methods' => (
init_arg => 'methods',
- reader => {
+ reader => {
# NOTE:
# we just alias the original method
- # rather than re-produce it here
+ # rather than re-produce it here
'get_method_map' => \&Class::MOP::Class::get_method_map
},
default => sub { {} }
accessor => {
# NOTE:
# we just alias the original method
- # rather than re-produce it here
+ # rather than re-produce it here
'superclasses' => \&Class::MOP::Class::superclasses
},
# NOTE:
- # protect this from silliness
+ # protect this from silliness
init_arg => '!............( DO NOT DO THIS )............!',
default => sub { \undef }
))
Class::MOP::Class->meta->add_attribute(
Class::MOP::Attribute->new('$!attribute_metaclass' => (
- reader => {
+ reader => {
# NOTE:
# we just alias the original method
- # rather than re-produce it here
+ # rather than re-produce it here
'attribute_metaclass' => \&Class::MOP::Class::attribute_metaclass
- },
+ },
init_arg => 'attribute_metaclass',
default => 'Class::MOP::Attribute',
))
Class::MOP::Class->meta->add_attribute(
Class::MOP::Attribute->new('$!method_metaclass' => (
- reader => {
+ reader => {
# NOTE:
# we just alias the original method
- # rather than re-produce it here
+ # rather than re-produce it here
'method_metaclass' => \&Class::MOP::Class::method_metaclass
},
init_arg => 'method_metaclass',
- default => 'Class::MOP::Method',
+ default => 'Class::MOP::Method',
))
);
Class::MOP::Class->meta->add_attribute(
Class::MOP::Attribute->new('$!instance_metaclass' => (
reader => {
- # NOTE: we need to do this in order
- # for the instance meta-object to
- # not fall into meta-circular death
- #
+ # NOTE: we need to do this in order
+ # for the instance meta-object to
+ # not fall into meta-circular death
+ #
# we just alias the original method
- # rather than re-produce it here
+ # rather than re-produce it here
'instance_metaclass' => \&Class::MOP::Class::instance_metaclass
},
init_arg => 'instance_metaclass',
- default => 'Class::MOP::Instance',
+ default => 'Class::MOP::Instance',
))
);
# NOTE:
-# we don't actually need to tie the knot with
-# Class::MOP::Class here, it is actually handled
-# within Class::MOP::Class itself in the
-# construct_class_instance method.
+# we don't actually need to tie the knot with
+# Class::MOP::Class here, it is actually handled
+# within Class::MOP::Class itself in the
+# construct_class_instance method.
## --------------------------------------------------------
## Class::MOP::Attribute
Class::MOP::Attribute->new('$!name' => (
init_arg => 'name',
reader => {
- # NOTE: we need to do this in order
- # for the instance meta-object to
- # not fall into meta-circular death
- #
+ # NOTE: we need to do this in order
+ # for the instance meta-object to
+ # not fall into meta-circular death
+ #
# we just alias the original method
- # rather than re-produce it here
+ # rather than re-produce it here
'name' => \&Class::MOP::Attribute::name
}
))
Class::MOP::Attribute->new('$!associated_class' => (
init_arg => 'associated_class',
reader => {
- # NOTE: we need to do this in order
- # for the instance meta-object to
- # not fall into meta-circular death
- #
+ # NOTE: we need to do this in order
+ # for the instance meta-object to
+ # not fall into meta-circular death
+ #
# we just alias the original method
- # rather than re-produce it here
+ # rather than re-produce it here
'associated_class' => \&Class::MOP::Attribute::associated_class
}
))
);
Class::MOP::Attribute->meta->add_attribute(
+ Class::MOP::Attribute->new('$!builder' => (
+ init_arg => 'builder',
+ reader => { 'builder' => \&Class::MOP::Attribute::builder },
+ predicate => { 'has_builder' => \&Class::MOP::Attribute::has_builder },
+ ))
+);
+
+Class::MOP::Attribute->meta->add_attribute(
Class::MOP::Attribute->new('$!init_arg' => (
init_arg => 'init_arg',
reader => { 'init_arg' => \&Class::MOP::Attribute::init_arg },
Class::MOP::Attribute->new('$!default' => (
init_arg => 'default',
# default has a custom 'reader' method ...
- predicate => { 'has_default' => \&Class::MOP::Attribute::has_default },
+ predicate => { 'has_default' => \&Class::MOP::Attribute::has_default },
))
);
Class::MOP::Attribute->new('@!associated_methods' => (
init_arg => 'associated_methods',
reader => { 'associated_methods' => \&Class::MOP::Attribute::associated_methods },
- default => sub { [] }
+ default => sub { [] }
))
);
# NOTE: (meta-circularity)
# This should be one of the last things done
# it will "tie the knot" with Class::MOP::Attribute
-# so that it uses the attributes meta-objects
-# to construct itself.
+# so that it uses the attributes meta-objects
+# to construct itself.
Class::MOP::Attribute->meta->add_method('new' => sub {
my $class = shift;
my $name = shift;
- my %options = @_;
-
+ my %options = @_;
+
(defined $name && $name)
|| confess "You must provide a name for the attribute";
- $options{init_arg} = $name
+ $options{init_arg} = $name
if not exists $options{init_arg};
-
+
+ if(exists $options{builder}){
+ confess("builder must be a defined scalar value which is a method name")
+ if ref $options{builder} || !(defined $options{builder});
+ confess("Setting both default and builder is not allowed.")
+ if exists $options{default};
+ }
(Class::MOP::Attribute::is_default_a_coderef(\%options))
- || confess("References are not allowed as default values, you must ".
+ || confess("References are not allowed as default values, you must ".
"wrap then in a CODE reference (ex: sub { [] } and not [])")
- if exists $options{default} && ref $options{default};
+ if exists $options{default} && ref $options{default};
# return the new object
$class->meta->new_object(name => $name, %options);
Class::MOP::Attribute->meta->add_method('clone' => sub {
my $self = shift;
- $self->meta->clone_object($self, @_);
+ $self->meta->clone_object($self, @_);
});
## --------------------------------------------------------
## Class::MOP::Method::Wrapped
# NOTE:
-# the way this item is initialized, this
-# really does not follow the standard
-# practices of attributes, but we put
+# the way this item is initialized, this
+# really does not follow the standard
+# practices of attributes, but we put
# it here for completeness
Class::MOP::Method::Wrapped->meta->add_attribute(
Class::MOP::Attribute->new('%!modifier_table')
Class::MOP::Attribute->new('$!is_inline' => (
init_arg => 'is_inline',
reader => { 'is_inline' => \&Class::MOP::Method::Generated::is_inline },
- ))
+ ))
);
## --------------------------------------------------------
Class::MOP::Method::Accessor->meta->add_attribute(
Class::MOP::Attribute->new('$!attribute' => (
init_arg => 'attribute',
- reader => {
- 'associated_attribute' => \&Class::MOP::Method::Accessor::associated_attribute
+ reader => {
+ 'associated_attribute' => \&Class::MOP::Method::Accessor::associated_attribute
},
- ))
+ ))
);
Class::MOP::Method::Accessor->meta->add_attribute(
Class::MOP::Attribute->new('$!accessor_type' => (
init_arg => 'accessor_type',
reader => { 'accessor_type' => \&Class::MOP::Method::Accessor::accessor_type },
- ))
+ ))
);
Class::MOP::Method::Constructor->meta->add_attribute(
Class::MOP::Attribute->new('%!options' => (
init_arg => 'options',
- reader => {
- 'options' => \&Class::MOP::Method::Constructor::options
+ reader => {
+ 'options' => \&Class::MOP::Method::Constructor::options
},
- ))
+ ))
);
Class::MOP::Method::Constructor->meta->add_attribute(
Class::MOP::Attribute->new('$!associated_metaclass' => (
init_arg => 'metaclass',
- reader => {
- 'associated_metaclass' => \&Class::MOP::Method::Constructor::associated_metaclass
- },
- ))
+ reader => {
+ 'associated_metaclass' => \&Class::MOP::Method::Constructor::associated_metaclass
+ },
+ ))
);
## --------------------------------------------------------
## Class::MOP::Instance
# NOTE:
-# these don't yet do much of anything, but are just
+# these don't yet do much of anything, but are just
# included for completeness
Class::MOP::Instance->meta->add_attribute(
## Now close all the Class::MOP::* classes
# NOTE:
-# we don't need to inline the
-# constructors or the accessors
-# this only lengthens the compile
-# time of the MOP, and gives us
+# we don't need to inline the
+# constructors or the accessors
+# this only lengthens the compile
+# time of the MOP, and gives us
# no actual benefits.
$_->meta->make_immutable(
inline_constructor => 0,
inline_accessors => 0,
) for qw/
- Class::MOP::Package
- Class::MOP::Module
- Class::MOP::Class
-
+ Class::MOP::Package
+ Class::MOP::Module
+ Class::MOP::Class
+
Class::MOP::Attribute
- Class::MOP::Method
- Class::MOP::Instance
-
- Class::MOP::Object
+ Class::MOP::Method
+ Class::MOP::Instance
+
+ Class::MOP::Object
Class::MOP::Method::Generated
-
+
Class::MOP::Method::Accessor
- Class::MOP::Method::Constructor
- Class::MOP::Method::Wrapped
+ Class::MOP::Method::Constructor
+ Class::MOP::Method::Wrapped
/;
1;
=pod
-=head1 NAME
+=head1 NAME
Class::MOP - A Meta Object Protocol for Perl 5
=head1 DESCRIPTON
-This module is an attempt to create a meta object protocol for the
-Perl 5 object system. It makes no attempt to change the behavior or
-characteristics of the Perl 5 object system, only to create a
+This module is an attempt to create a meta object protocol for the
+Perl 5 object system. It makes no attempt to change the behavior or
+characteristics of the Perl 5 object system, only to create a
protocol for its manipulation and introspection.
-That said, it does attempt to create the tools for building a rich
-set of extensions to the Perl 5 object system. Every attempt has been
-made for these tools to keep to the spirit of the Perl 5 object
+That said, it does attempt to create the tools for building a rich
+set of extensions to the Perl 5 object system. Every attempt has been
+made for these tools to keep to the spirit of the Perl 5 object
system that we all know and love.
-This documentation is admittedly sparse on details, as time permits
-I will try to improve them. For now, I suggest looking at the items
-listed in the L<SEE ALSO> section for more information. In particular
-the book "The Art of the Meta Object Protocol" was very influential
+This documentation is admittedly sparse on details, as time permits
+I will try to improve them. For now, I suggest looking at the items
+listed in the L<SEE ALSO> section for more information. In particular
+the book "The Art of the Meta Object Protocol" was very influential
in the development of this system.
=head2 What is a Meta Object Protocol?
-A meta object protocol is an API to an object system.
+A meta object protocol is an API to an object system.
-To be more specific, it is a set of abstractions of the components of
-an object system (typically things like; classes, object, methods,
-object attributes, etc.). These abstractions can then be used to both
+To be more specific, it is a set of abstractions of the components of
+an object system (typically things like; classes, object, methods,
+object attributes, etc.). These abstractions can then be used to both
inspect and manipulate the object system which they describe.
-It can be said that there are two MOPs for any object system; the
-implicit MOP, and the explicit MOP. The implicit MOP handles things
-like method dispatch or inheritance, which happen automatically as
-part of how the object system works. The explicit MOP typically
-handles the introspection/reflection features of the object system.
-All object systems have implicit MOPs, without one, they would not
-work. Explict MOPs however as less common, and depending on the
-language can vary from restrictive (Reflection in Java or C#) to
-wide open (CLOS is a perfect example).
+It can be said that there are two MOPs for any object system; the
+implicit MOP, and the explicit MOP. The implicit MOP handles things
+like method dispatch or inheritance, which happen automatically as
+part of how the object system works. The explicit MOP typically
+handles the introspection/reflection features of the object system.
+All object systems have implicit MOPs, without one, they would not
+work. Explict MOPs however as less common, and depending on the
+language can vary from restrictive (Reflection in Java or C#) to
+wide open (CLOS is a perfect example).
=head2 Yet Another Class Builder!! Why?
-This is B<not> a class builder so much as it is a I<class builder
-B<builder>>. My intent is that an end user does not use this module
-directly, but instead this module is used by module authors to
-build extensions and features onto the Perl 5 object system.
+This is B<not> a class builder so much as it is a I<class builder
+B<builder>>. My intent is that an end user does not use this module
+directly, but instead this module is used by module authors to
+build extensions and features onto the Perl 5 object system.
=head2 Who is this module for?
-This module is specifically for anyone who has ever created or
-wanted to create a module for the Class:: namespace. The tools which
-this module will provide will hopefully make it easier to do more
-complex things with Perl 5 classes by removing such barriers as
-the need to hack the symbol tables, or understand the fine details
-of method dispatch.
+This module is specifically for anyone who has ever created or
+wanted to create a module for the Class:: namespace. The tools which
+this module will provide will hopefully make it easier to do more
+complex things with Perl 5 classes by removing such barriers as
+the need to hack the symbol tables, or understand the fine details
+of method dispatch.
=head2 What changes do I have to make to use this module?
-This module was designed to be as unintrusive as possible. Many of
-its features are accessible without B<any> change to your existsing
-code at all. It is meant to be a compliment to your existing code and
-not an intrusion on your code base. Unlike many other B<Class::>
-modules, this module B<does not> require you subclass it, or even that
-you C<use> it in within your module's package.
+This module was designed to be as unintrusive as possible. Many of
+its features are accessible without B<any> change to your existsing
+code at all. It is meant to be a compliment to your existing code and
+not an intrusion on your code base. Unlike many other B<Class::>
+modules, this module B<does not> require you subclass it, or even that
+you C<use> it in within your module's package.
-The only features which requires additions to your code are the
+The only features which requires additions to your code are the
attribute handling and instance construction features, and these are
-both completely optional features. The only reason for this is because
-Perl 5's object system does not actually have these features built
+both completely optional features. The only reason for this is because
+Perl 5's object system does not actually have these features built
in. More information about this feature can be found below.
=head2 A Note about Performance?
-It is a common misconception that explict MOPs are performance drains.
-But this is not a universal truth at all, it is an side-effect of
-specific implementations. For instance, using Java reflection is much
-slower because the JVM cannot take advantage of any compiler
-optimizations, and the JVM has to deal with much more runtime type
-information as well. Reflection in C# is marginally better as it was
-designed into the language and runtime (the CLR). In contrast, CLOS
-(the Common Lisp Object System) was built to support an explicit MOP,
-and so performance is tuned for it.
-
-This library in particular does it's absolute best to avoid putting
-B<any> drain at all upon your code's performance. In fact, by itself
-it does nothing to affect your existing code. So you only pay for
+It is a common misconception that explict MOPs are performance drains.
+But this is not a universal truth at all, it is an side-effect of
+specific implementations. For instance, using Java reflection is much
+slower because the JVM cannot take advantage of any compiler
+optimizations, and the JVM has to deal with much more runtime type
+information as well. Reflection in C# is marginally better as it was
+designed into the language and runtime (the CLR). In contrast, CLOS
+(the Common Lisp Object System) was built to support an explicit MOP,
+and so performance is tuned for it.
+
+This library in particular does it's absolute best to avoid putting
+B<any> drain at all upon your code's performance. In fact, by itself
+it does nothing to affect your existing code. So you only pay for
what you actually use.
=head2 About Metaclass compatibility
-This module makes sure that all metaclasses created are both upwards
-and downwards compatible. The topic of metaclass compatibility is
-highly esoteric and is something only encountered when doing deep and
-involved metaclass hacking. There are two basic kinds of metaclass
-incompatibility; upwards and downwards.
+This module makes sure that all metaclasses created are both upwards
+and downwards compatible. The topic of metaclass compatibility is
+highly esoteric and is something only encountered when doing deep and
+involved metaclass hacking. There are two basic kinds of metaclass
+incompatibility; upwards and downwards.
-Upwards metaclass compatibility means that the metaclass of a
-given class is either the same as (or a subclass of) all of the
+Upwards metaclass compatibility means that the metaclass of a
+given class is either the same as (or a subclass of) all of the
class's ancestors.
-Downward metaclass compatibility means that the metaclasses of a
-given class's anscestors are all either the same as (or a subclass
+Downward metaclass compatibility means that the metaclasses of a
+given class's anscestors are all either the same as (or a subclass
of) that metaclass.
-Here is a diagram showing a set of two classes (C<A> and C<B>) and
-two metaclasses (C<Meta::A> and C<Meta::B>) which have correct
+Here is a diagram showing a set of two classes (C<A> and C<B>) and
+two metaclasses (C<Meta::A> and C<Meta::B>) which have correct
metaclass compatibility both upwards and downwards.
+---------+ +---------+
| Meta::A |<----| Meta::B | <....... (instance of )
- +---------+ +---------+ <------- (inherits from)
+ +---------+ +---------+ <------- (inherits from)
^ ^
: :
+---------+ +---------+
| A |<----| B |
+---------+ +---------+
-As I said this is a highly esoteric topic and one you will only run
-into if you do a lot of subclassing of B<Class::MOP::Class>. If you
-are interested in why this is an issue see the paper
-I<Uniform and safe metaclass composition> linked to in the
+As I said this is a highly esoteric topic and one you will only run
+into if you do a lot of subclassing of B<Class::MOP::Class>. If you
+are interested in why this is an issue see the paper
+I<Uniform and safe metaclass composition> linked to in the
L<SEE ALSO> section of this document.
=head2 Using custom metaclasses
-Always use the metaclass pragma when using a custom metaclass, this
-will ensure the proper initialization order and not accidentely
-create an incorrect type of metaclass for you. This is a very rare
-problem, and one which can only occur if you are doing deep metaclass
+Always use the metaclass pragma when using a custom metaclass, this
+will ensure the proper initialization order and not accidentely
+create an incorrect type of metaclass for you. This is a very rare
+problem, and one which can only occur if you are doing deep metaclass
programming. So in other words, don't worry about it.
=head1 PROTOCOLS
=item The Class protocol
-This provides a means of manipulating and introspecting a Perl 5
-class. It handles all of symbol table hacking for you, and provides
+This provides a means of manipulating and introspecting a Perl 5
+class. It handles all of symbol table hacking for you, and provides
a rich set of methods that go beyond simple package introspection.
See L<Class::MOP::Class> for more details.
=item The Attribute protocol
-This provides a consistent represenation for an attribute of a
-Perl 5 class. Since there are so many ways to create and handle
-atttributes in Perl 5 OO, this attempts to provide as much of a
-unified approach as possible, while giving the freedom and
+This provides a consistent represenation for an attribute of a
+Perl 5 class. Since there are so many ways to create and handle
+atttributes in Perl 5 OO, this attempts to provide as much of a
+unified approach as possible, while giving the freedom and
flexibility to subclass for specialization.
See L<Class::MOP::Attribute> for more details.
=item The Method protocol
-This provides a means of manipulating and introspecting methods in
-the Perl 5 object system. As with attributes, there are many ways to
-approach this topic, so we try to keep it pretty basic, while still
+This provides a means of manipulating and introspecting methods in
+the Perl 5 object system. As with attributes, there are many ways to
+approach this topic, so we try to keep it pretty basic, while still
making it possible to extend the system in many ways.
See L<Class::MOP::Method> for more details.
=item B<load_class ($class_name)>
-This will load a given C<$class_name> and if it does not have an
+This will load a given C<$class_name> and if it does not have an
already initialized metaclass, then it will intialize one for it.
=item B<is_class_loaded ($class_name)>
-This will return a boolean depending on if the C<$class_name> has
-been loaded.
+This will return a boolean depending on if the C<$class_name> has
+been loaded.
-NOTE: This does a basic check of the symbol table to try and
+NOTE: This does a basic check of the symbol table to try and
determine as best it can if the C<$class_name> is loaded, it
-is probably correct about 99% of the time.
+is probably correct about 99% of the time.
=back
=head2 Metaclass cache functions
-Class::MOP holds a cache of metaclasses, the following are functions
-(B<not methods>) which can be used to access that cache. It is not
-recommended that you mess with this, bad things could happen. But if
+Class::MOP holds a cache of metaclasses, the following are functions
+(B<not methods>) which can be used to access that cache. It is not
+recommended that you mess with this, bad things could happen. But if
you are brave and willing to risk it, go for it.
=over 4
=item B<get_all_metaclasses>
-This will return an hash of all the metaclass instances that have
-been cached by B<Class::MOP::Class> keyed by the package name.
+This will return an hash of all the metaclass instances that have
+been cached by B<Class::MOP::Class> keyed by the package name.
=item B<get_all_metaclass_instances>
-This will return an array of all the metaclass instances that have
+This will return an array of all the metaclass instances that have
been cached by B<Class::MOP::Class>.
=item B<get_all_metaclass_names>
-This will return an array of all the metaclass names that have
+This will return an array of all the metaclass names that have
been cached by B<Class::MOP::Class>.
=item B<get_metaclass_by_name ($name)>
=head2 Books
-There are very few books out on Meta Object Protocols and Metaclasses
-because it is such an esoteric topic. The following books are really
-the only ones I have found. If you know of any more, B<I<please>>
+There are very few books out on Meta Object Protocols and Metaclasses
+because it is such an esoteric topic. The following books are really
+the only ones I have found. If you know of any more, B<I<please>>
email me and let me know, I would love to hear about them.
=over 4
=item Uniform and safe metaclass composition
-An excellent paper by the people who brought us the original Traits paper.
-This paper is on how Traits can be used to do safe metaclass composition,
-and offers an excellent introduction section which delves into the topic of
+An excellent paper by the people who brought us the original Traits paper.
+This paper is on how Traits can be used to do safe metaclass composition,
+and offers an excellent introduction section which delves into the topic of
metaclass compatibility.
L<http://www.iam.unibe.ch/~scg/Archive/Papers/Duca05ySafeMetaclassTrait.pdf>
=item Safe Metaclass Programming
-This paper seems to precede the above paper, and propose a mix-in based
-approach as opposed to the Traits based approach. Both papers have similar
-information on the metaclass compatibility problem space.
+This paper seems to precede the above paper, and propose a mix-in based
+approach as opposed to the Traits based approach. Both papers have similar
+information on the metaclass compatibility problem space.
L<http://citeseer.ist.psu.edu/37617.html>
=back
-=head2 Articles
+=head2 Articles
=over 4
-=item CPAN Module Review of Class::MOP
+=item CPAN Module Review of Class::MOP
L<http://www.oreillynet.com/onlamp/blog/2006/06/cpan_module_review_classmop.html>
=head1 SIMILAR MODULES
-As I have said above, this module is a class-builder-builder, so it is
-not the same thing as modules like L<Class::Accessor> and
-L<Class::MethodMaker>. That being said there are very few modules on CPAN
-with similar goals to this module. The one I have found which is most
-like this module is L<Class::Meta>, although it's philosophy and the MOP it
-creates are very different from this modules.
+As I have said above, this module is a class-builder-builder, so it is
+not the same thing as modules like L<Class::Accessor> and
+L<Class::MethodMaker>. That being said there are very few modules on CPAN
+with similar goals to this module. The one I have found which is most
+like this module is L<Class::Meta>, although it's philosophy and the MOP it
+creates are very different from this modules.
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
=item Rob Kinyon
-Thanks to Rob for actually getting the development of this module kick-started.
+Thanks to Rob for actually getting the development of this module kick-started.
=back
L<http://www.iinteractive.com>
This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
+it under the same terms as Perl itself.
=cut
use Carp 'confess';
use Scalar::Util 'blessed', 'reftype', 'weaken';
-our $VERSION = '0.15';
+our $VERSION = '0.16';
our $AUTHORITY = 'cpan:STEVAN';
use base 'Class::MOP::Object';
-sub meta {
+sub meta {
require Class::MOP::Class;
Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
}
# NOTE: (meta-circularity)
-# This method will be replaced in the
-# boostrap section of Class::MOP, by
-# a new version which uses the
+# This method will be replaced in the
+# boostrap section of Class::MOP, by
+# a new version which uses the
# &Class::MOP::Class::construct_instance
# method to build an attribute meta-object
# which itself is described with attribute
-# meta-objects.
+# meta-objects.
# - Ain't meta-circularity grand? :)
sub new {
my $class = shift;
my $name = shift;
- my %options = @_;
-
+ my %options = @_;
+
(defined $name && $name)
|| confess "You must provide a name for the attribute";
-
- $options{init_arg} = $name
+
+ $options{init_arg} = $name
if not exists $options{init_arg};
-
+ if(exists $options{builder}){
+ confess("builder must be a defined scalar value which is a method name")
+ if ref $options{builder} || !(defined $options{builder});
+ confess("Setting both default and builder is not allowed.")
+ if exists $options{default};
+ }
(is_default_a_coderef(\%options))
- || confess("References are not allowed as default values, you must ".
+ || confess("References are not allowed as default values, you must ".
"wrap then in a CODE reference (ex: sub { [] } and not [])")
- if exists $options{default} && ref $options{default};
-
+ if exists $options{default} && ref $options{default};
+
bless {
'$!name' => $name,
'$!accessor' => $options{accessor},
'$!writer' => $options{writer},
'$!predicate' => $options{predicate},
'$!clearer' => $options{clearer},
+ '$!builder' => $options{builder},
'$!init_arg' => $options{init_arg},
'$!default' => $options{default},
- # keep a weakened link to the
+ # keep a weakened link to the
# class we are associated with
'$!associated_class' => undef,
- # and a list of the methods
+ # and a list of the methods
# associated with this attr
'@!associated_methods' => [],
} => $class;
}
# NOTE:
-# this is a primative (and kludgy) clone operation
+# this is a primative (and kludgy) clone operation
# for now, it will be replaced in the Class::MOP
-# bootstrap with a proper one, however we know
+# bootstrap with a proper one, however we know
# that this one will work fine for now.
sub clone {
my $self = shift;
my ($self, $meta_instance, $instance, $params) = @_;
my $init_arg = $self->{'$!init_arg'};
# try to fetch the init arg from the %params ...
- my $val;
+ my $val;
$val = $params->{$init_arg} if exists $params->{$init_arg};
- # if nothing was in the %params, we can use the
+ # if nothing was in the %params, we can use the
# attribute's default value (if it has one)
if (!defined $val && defined $self->{'$!default'}) {
$val = $self->default($instance);
}
+ if (!defined $val && defined $self->{'$!builder'}) {
+ my $builder = $self->{'$!builder'};
+ confess(blessed($instance)." does not support builder method '$builder' for attribute '" . $self->name . "'")
+ unless $instance->can($builder);
+ $val = $instance->$builder;
+ }
$meta_instance->set_slot_value($instance, $self->name, $val);
}
# NOTE:
-# the next bunch of methods will get bootstrapped
+# the next bunch of methods will get bootstrapped
# away in the Class::MOP bootstrapping section
sub name { $_[0]->{'$!name'} }
sub has_writer { defined($_[0]->{'$!writer'}) ? 1 : 0 }
sub has_predicate { defined($_[0]->{'$!predicate'}) ? 1 : 0 }
sub has_clearer { defined($_[0]->{'$!clearer'}) ? 1 : 0 }
+sub has_builder { defined($_[0]->{'$!builder'}) ? 1 : 0 }
sub has_init_arg { defined($_[0]->{'$!init_arg'}) ? 1 : 0 }
sub has_default { defined($_[0]->{'$!default'}) ? 1 : 0 }
-sub accessor { $_[0]->{'$!accessor'} }
+sub accessor { $_[0]->{'$!accessor'} }
sub reader { $_[0]->{'$!reader'} }
sub writer { $_[0]->{'$!writer'} }
sub predicate { $_[0]->{'$!predicate'} }
sub clearer { $_[0]->{'$!clearer'} }
+sub builder { $_[0]->{'$!builder'} }
sub init_arg { $_[0]->{'$!init_arg'} }
# end bootstrapped away method section.
sub get_read_method { $_[0]->reader || $_[0]->accessor }
sub get_write_method { $_[0]->writer || $_[0]->accessor }
-sub is_default_a_coderef {
- ('CODE' eq (reftype($_[0]->{'$!default'} || $_[0]->{default}) || ''))
+sub is_default_a_coderef {
+ ('CODE' eq (reftype($_[0]->{'$!default'} || $_[0]->{default}) || ''))
}
-sub default {
+sub default {
my ($self, $instance) = @_;
if (defined $instance && $self->is_default_a_coderef) {
- # if the default is a CODE ref, then
+ # if the default is a CODE ref, then
# we pass in the instance and default
- # can return a value based on that
+ # can return a value based on that
# instance. Somewhat crude, but works.
return $self->{'$!default'}->($instance);
- }
+ }
$self->{'$!default'};
}
sub slots { (shift)->name }
-# class association
+# class association
sub attach_to_class {
my ($self, $class) = @_;
(blessed($class) && $class->isa('Class::MOP::Class'))
|| confess "You must pass a Class::MOP::Class instance (or a subclass)";
- weaken($self->{'$!associated_class'} = $class);
+ weaken($self->{'$!associated_class'} = $class);
}
sub detach_from_class {
my $self = shift;
- $self->{'$!associated_class'} = undef;
+ $self->{'$!associated_class'} = undef;
}
-# method association
+# method association
sub associate_method {
my ($self, $method) = @_;
sub has_value {
my ($self, $instance) = @_;
-
+
defined Class::MOP::Class->initialize(blessed($instance))
->get_meta_instance
- ->get_slot_value($instance, $self->name) ? 1 : 0;
+ ->get_slot_value($instance, $self->name) ? 1 : 0;
}
sub clear_value {
my ($self, $instance) = @_;
-
+
Class::MOP::Class->initialize(blessed($instance))
->get_meta_instance
- ->deinitialize_slot($instance, $self->name);
+ ->deinitialize_slot($instance, $self->name);
}
## load em up ...
my ($name, $method) = %{$accessor};
$method = $self->accessor_metaclass->wrap($method);
$self->associate_method($method);
- return ($name, $method);
+ return ($name, $method);
}
else {
- my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable);
+ my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable);
my $method;
eval {
$method = $self->accessor_metaclass->new(
attribute => $self,
is_inline => $inline_me,
accessor_type => $type,
- );
+ );
};
- confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@;
+ confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@;
$self->associate_method($method);
return ($accessor, $method);
- }
+ }
}
sub install_accessors {
my $self = shift;
my $inline = shift;
my $class = $self->associated_class;
-
+
$class->add_method(
$self->process_accessors('accessor' => $self->accessor(), $inline)
) if $self->has_accessor();
- $class->add_method(
+ $class->add_method(
$self->process_accessors('reader' => $self->reader(), $inline)
) if $self->has_reader();
$class->add_method(
$self->process_accessors('predicate' => $self->predicate(), $inline)
) if $self->has_predicate();
-
+
$class->add_method(
$self->process_accessors('clearer' => $self->clearer(), $inline)
) if $self->has_clearer();
-
+
return;
}
my ($accessor, $class) = @_;
if (reftype($accessor) && reftype($accessor) eq 'HASH') {
($accessor) = keys %{$accessor};
- }
- my $method = $class->get_method($accessor);
- $class->remove_method($accessor)
+ }
+ my $method = $class->get_method($accessor);
+ $class->remove_method($accessor)
if (blessed($method) && $method->isa('Class::MOP::Method::Accessor'));
};
-
+
sub remove_accessors {
my $self = shift;
# TODO:
- # we really need to make sure to remove from the
- # associates methods here as well. But this is
- # such a slimly used method, I am not worried
+ # we really need to make sure to remove from the
+ # associates methods here as well. But this is
+ # such a slimly used method, I am not worried
# about it right now.
$_remove_accessor->($self->accessor(), $self->associated_class()) if $self->has_accessor();
$_remove_accessor->($self->reader(), $self->associated_class()) if $self->has_reader();
$_remove_accessor->($self->writer(), $self->associated_class()) if $self->has_writer();
$_remove_accessor->($self->predicate(), $self->associated_class()) if $self->has_predicate();
$_remove_accessor->($self->clearer(), $self->associated_class()) if $self->has_clearer();
- return;
+ return;
}
}
=pod
-=head1 NAME
+=head1 NAME
Class::MOP::Attribute - Attribute Meta Object
=head1 SYNOPSIS
-
+
Class::MOP::Attribute->new('$foo' => (
accessor => 'foo', # dual purpose get/set accessor
- predicate => 'has_foo' # predicate check for defined-ness
+ predicate => 'has_foo' # predicate check for defined-ness
init_arg => '-foo', # class->new will look for a -foo key
default => 'BAR IS BAZ!' # if no -foo key is provided, use this
));
-
+
Class::MOP::Attribute->new('$.bar' => (
reader => 'bar', # getter
- writer => 'set_bar', # setter
- predicate => 'has_bar' # predicate check for defined-ness
+ writer => 'set_bar', # setter
+ predicate => 'has_bar' # predicate check for defined-ness
init_arg => ':bar', # class->new will look for a :bar key
# no default value means it is undef
));
=head1 DESCRIPTION
The Attribute Protocol is almost entirely an invention of this module,
-and is completely optional to this MOP. This is because Perl 5 does not
-have consistent notion of what is an attribute of a class. There are
-so many ways in which this is done, and very few (if any) are
+and is completely optional to this MOP. This is because Perl 5 does not
+have consistent notion of what is an attribute of a class. There are
+so many ways in which this is done, and very few (if any) are
easily discoverable by this module.
-So, all that said, this module attempts to inject some order into this
-chaos, by introducing a consistent API which can be used to create
+So, all that said, this module attempts to inject some order into this
+chaos, by introducing a consistent API which can be used to create
object attributes.
=head1 METHODS
=item B<new ($name, ?%options)>
-An attribute must (at the very least), have a C<$name>. All other
+An attribute must (at the very least), have a C<$name>. All other
C<%options> are contained added as key-value pairs. Acceptable keys
are as follows:
=item I<init_arg>
-This should be a string value representing the expected key in
-an initialization hash. For instance, if we have an I<init_arg>
+This should be a string value representing the expected key in
+an initialization hash. For instance, if we have an I<init_arg>
value of C<-foo>, then the following code will Just Work.
MyClass->meta->construct_instance(-foo => "Hello There");
-In an init_arg is not assigned, it will automatically use the
+In an init_arg is not assigned, it will automatically use the
value of C<$name>.
=item I<default>
-The value of this key is the default value which
-C<Class::MOP::Class::construct_instance> will initialize the
-attribute to.
+The value of this key is the default value which
+C<Class::MOP::Class::construct_instance> will initialize the
+attribute to.
+
+=item I<builder>
+
+The value of this key is the name of the method that will be
+called to obtain the value used to initialize the attribute.
+This should be a method in the class associated with the attribute,
+not a method in the attribute class itself.
B<NOTE:>
-If the value is a simple scalar (string or number), then it can
-be just passed as is. However, if you wish to initialize it with
-a HASH or ARRAY ref, then you need to wrap that inside a CODE
+If the value is a simple scalar (string or number), then it can
+be just passed as is. However, if you wish to initialize it with
+a HASH or ARRAY ref, then you need to wrap that inside a CODE
reference, like so:
Class::MOP::Attribute->new('@foo' => (
default => sub { [] },
));
-
- # or ...
-
+
+ # or ...
+
Class::MOP::Attribute->new('%foo' => (
default => sub { {} },
- ));
+ ));
-If you wish to initialize an attribute with a CODE reference
+If you wish to initialize an attribute with a CODE reference
itself, then you need to wrap that in a subroutine as well, like
so:
-
+
Class::MOP::Attribute->new('&foo' => (
default => sub { sub { print "Hello World" } },
));
-And lastly, if the value of your attribute is dependent upon
-some other aspect of the instance structure, then you can take
-advantage of the fact that when the I<default> value is a CODE
-reference, it is passed the raw (unblessed) instance structure
+And lastly, if the value of your attribute is dependent upon
+some other aspect of the instance structure, then you can take
+advantage of the fact that when the I<default> value is a CODE
+reference, it is passed the raw (unblessed) instance structure
as it's only argument. So you can do things like this:
Class::MOP::Attribute->new('$object_identity' => (
default => sub { Scalar::Util::refaddr($_[0]) },
));
-This last feature is fairly limited as there is no gurantee of
-the order of attribute initializations, so you cannot perform
-any kind of dependent initializations. However, if this is
-something you need, you could subclass B<Class::MOP::Class> and
-this class to acheive it. However, this is currently left as
+This last feature is fairly limited as there is no gurantee of
+the order of attribute initializations, so you cannot perform
+any kind of dependent initializations. However, if this is
+something you need, you could subclass B<Class::MOP::Class> and
+this class to acheive it. However, this is currently left as
an exercise to the reader :).
=back
=item I<accessor>
-The I<accessor> is a standard perl-style read/write accessor. It will
-return the value of the attribute, and if a value is passed as an argument,
+The I<accessor> is a standard perl-style read/write accessor. It will
+return the value of the attribute, and if a value is passed as an argument,
it will assign that value to the attribute.
B<NOTE:>
-This method will properly handle the following code, by assigning an
+This method will properly handle the following code, by assigning an
C<undef> value to the attribute.
$object->set_something(undef);
=item I<reader>
-This is a basic read-only accessor, it will just return the value of
+This is a basic read-only accessor, it will just return the value of
the attribute.
=item I<writer>
-This is a basic write accessor, it accepts a single argument, and
-assigns that value to the attribute. This method does not intentially
-return a value, however perl will return the result of the last
-expression in the subroutine, which returns in this returning the
-same value that it was passed.
+This is a basic write accessor, it accepts a single argument, and
+assigns that value to the attribute. This method does not intentially
+return a value, however perl will return the result of the last
+expression in the subroutine, which returns in this returning the
+same value that it was passed.
B<NOTE:>
-This method will properly handle the following code, by assigning an
+This method will properly handle the following code, by assigning an
C<undef> value to the attribute.
$object->set_something();
=item I<predicate>
-This is a basic test to see if the value of the attribute is not
-C<undef>. It will return true (C<1>) if the attribute's value is
+This is a basic test to see if the value of the attribute is not
+C<undef>. It will return true (C<1>) if the attribute's value is
defined, and false (C<0>) otherwise.
=item I<clearer>
=item B<initialize_instance_slot ($instance, $params)>
-=back
+=back
=head2 Value management
-These methods are basically "backdoors" to the instance, which can be used
-to bypass the regular accessors, but still stay within the context of the MOP.
+These methods are basically "backdoors" to the instance, which can be used
+to bypass the regular accessors, but still stay within the context of the MOP.
-These methods are not for general use, and should only be used if you really
+These methods are not for general use, and should only be used if you really
know what you are doing.
=over 4
=item B<has_value ($instance)>
-Returns a boolean indicating if the item in the C<$instance> has a value in it.
+Returns a boolean indicating if the item in the C<$instance> has a value in it.
This is basically what the default C<predicate> method calls.
=item B<clear_value ($instance)>
This will clear the value in the C<$instance>. This is basically what the default
-C<clearer> would call. Note that this may be done even if the attirbute does not
+C<clearer> would call. Note that this may be done even if the attirbute does not
have any associated read, write or clear methods.
=back
=head2 Informational
-These are all basic read-only value accessors for the values
+These are all basic read-only value accessors for the values
passed into C<new>. I think they are pretty much self-explanitory.
=over 4
=item B<default (?$instance)>
-As noted in the documentation for C<new> above, if the I<default>
+As noted in the documentation for C<new> above, if the I<default>
value is a CODE reference, this accessor will pass a single additional
argument C<$instance> into it and return the value.
=item B<slots>
-Returns a list of slots required by the attribute. This is usually
+Returns a list of slots required by the attribute. This is usually
just one, which is the name of the attribute.
=item B<get_read_method>
=head2 Class association
-These methods allow you to manage the attributes association with
-the class that contains it. These methods should not be used
+These methods allow you to manage the attributes association with
+the class that contains it. These methods should not be used
lightly, nor are they very magical, they are mostly used internally
and by metaclass instances.
=item B<attach_to_class ($class)>
-This will store a weaken reference to C<$class> internally. You should
+This will store a weaken reference to C<$class> internally. You should
note that just changing the class assocation will not remove the attribute
from it's old class, and initialize it (and it's accessors) in the new
C<$class>. It is up to you to do this manually.
=item B<detach_from_class>
-This will remove the weakened reference to the class. It does B<not>
-remove the attribute itself from the class (or remove it's accessors),
-you must do that yourself if you want too. Actually if that is what
-you want to do, you should probably be looking at
+This will remove the weakened reference to the class. It does B<not>
+remove the attribute itself from the class (or remove it's accessors),
+you must do that yourself if you want too. Actually if that is what
+you want to do, you should probably be looking at
L<Class::MOP::Class::remove_attribute> instead.
=back
=item B<accessor_metaclass>
Accessors are generated by an accessor metaclass, which is usually
-a subclass of C<Class::MOP::Method::Accessor>. This method returns
+a subclass of C<Class::MOP::Method::Accessor>. This method returns
the name of the accessor metaclass that this attribute uses.
=item B<associate_method ($method)>
-This will associate a C<$method> with the given attribute which is
-used internally by the accessor generator.
+This will associate a C<$method> with the given attribute which is
+used internally by the accessor generator.
=item B<associated_methods>
-This will return the list of methods which have been associated with
-the C<associate_method> methods.
+This will return the list of methods which have been associated with
+the C<associate_method> methods.
=item B<install_accessors>
-This allows the attribute to generate and install code for it's own
-I<accessor/reader/writer/predicate> methods. This is called by
+This allows the attribute to generate and install code for it's own
+I<accessor/reader/writer/predicate> methods. This is called by
C<Class::MOP::Class::add_attribute>.
-This method will call C<process_accessors> for each of the possible
+This method will call C<process_accessors> for each of the possible
method types (accessor, reader, writer & predicate).
=item B<process_accessors ($type, $value)>
-This takes a C<$type> (accessor, reader, writer or predicate), and
+This takes a C<$type> (accessor, reader, writer or predicate), and
a C<$value> (the value passed into the constructor for each of the
-different types). It will then either generate the method itself
-(using the C<generate_*_method> methods listed below) or it will
-use the custom method passed through the constructor.
+different types). It will then either generate the method itself
+(using the C<generate_*_method> methods listed below) or it will
+use the custom method passed through the constructor.
=item B<remove_accessors>
-This allows the attribute to remove the method for it's own
-I<accessor/reader/writer/predicate/clearer>. This is called by
+This allows the attribute to remove the method for it's own
+I<accessor/reader/writer/predicate/clearer>. This is called by
C<Class::MOP::Class::remove_attribute>.
-NOTE: This does not currently remove methods from the list returned
+NOTE: This does not currently remove methods from the list returned
by C<associated_methods>, that is on the TODO list.
=back
=item B<meta>
-This will return a B<Class::MOP::Class> instance which is related
+This will return a B<Class::MOP::Class> instance which is related
to this class.
-It should also be noted that B<Class::MOP> will actually bootstrap
-this module by installing a number of attribute meta-objects into
-it's metaclass. This will allow this class to reap all the benifits
-of the MOP when subclassing it.
+It should also be noted that B<Class::MOP> will actually bootstrap
+this module by installing a number of attribute meta-objects into
+it's metaclass. This will allow this class to reap all the benifits
+of the MOP when subclassing it.
=back
L<http://www.iinteractive.com>
This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
+it under the same terms as Perl itself.
=cut
use Sub::Name 'subname';
use B 'svref_2object';
-our $VERSION = '0.22';
+our $VERSION = '0.23';
our $AUTHORITY = 'cpan:STEVAN';
use base 'Class::MOP::Module';
my $self = shift;
return if $self->is_mutable;
my $options = delete $IMMUTABLE_OPTIONS{$self->name};
- confess "unable to find immutabilizing options" unless $options;
+ confess "unable to find immutabilizing options" unless ref $options;
my $transformer = delete $options->{IMMUTABLE_TRANSFORMER};
$transformer->make_metaclass_mutable($self, %$options);
}
use strict;
use warnings;
-use Test::More tests => 50;
+use Test::More tests => 54;
use Test::Exception;
-BEGIN {
- use_ok('Class::MOP');
+BEGIN {
+ use_ok('Class::MOP');
}
my $FOO_ATTR = Class::MOP::Attribute->new('$foo');
));
my $BAZ_ATTR = Class::MOP::Attribute->new('$baz' => (
reader => 'get_baz',
- writer => 'set_baz',
+ writer => 'set_baz',
));
my $BAR_ATTR_2 = Class::MOP::Attribute->new('$bar');
+my $FOO_ATTR_2 = Class::MOP::Attribute->new('$foo' => (
+ accessor => 'foo',
+ builder => 'build_foo'
+));
+
is($FOO_ATTR->name, '$foo', '... got the attributes name correctly');
is($BAR_ATTR->name, '$bar', '... got the attributes name correctly');
is($BAZ_ATTR->name, '$baz', '... got the attributes name correctly');
} '... we added an attribute to Foo successfully';
::ok($meta->has_attribute('$foo'), '... Foo has $foo attribute');
::is($meta->get_attribute('$foo'), $FOO_ATTR, '... got the right attribute back for Foo');
-
+
::ok(!$meta->has_method('foo'), '... no accessor created');
-
+
::lives_ok {
$meta->add_attribute($BAR_ATTR_2);
} '... we added an attribute to Foo successfully';
::ok($meta->has_attribute('$bar'), '... Foo has $bar attribute');
- ::is($meta->get_attribute('$bar'), $BAR_ATTR_2, '... got the right attribute back for Foo');
+ ::is($meta->get_attribute('$bar'), $BAR_ATTR_2, '... got the right attribute back for Foo');
::ok(!$meta->has_method('bar'), '... no accessor created');
}
{
package Bar;
our @ISA = ('Foo');
-
+
my $meta = Bar->meta;
::lives_ok {
$meta->add_attribute($BAR_ATTR);
::is($attr->get_write_method, 'bar', '... got the right write method for Bar');
::ok($meta->has_method('bar'), '... an accessor has been created');
- ::isa_ok($meta->get_method('bar'), 'Class::MOP::Method::Accessor');
+ ::isa_ok($meta->get_method('bar'), 'Class::MOP::Method::Accessor');
}
{
package Baz;
our @ISA = ('Bar');
-
+
my $meta = Baz->meta;
::lives_ok {
$meta->add_attribute($BAZ_ATTR);
} '... we added an attribute to Baz successfully';
- ::ok($meta->has_attribute('$baz'), '... Baz has $baz attribute');
+ ::ok($meta->has_attribute('$baz'), '... Baz has $baz attribute');
::is($meta->get_attribute('$baz'), $BAZ_ATTR, '... got the right attribute back for Baz');
my $attr = $meta->get_attribute('$baz');
{
my $meta = Baz->meta;
isa_ok($meta, 'Class::MOP::Class');
-
+
is($meta->find_attribute_by_name('$bar'), $BAR_ATTR, '... got the right attribute for "bar"');
- is($meta->find_attribute_by_name('$baz'), $BAZ_ATTR, '... got the right attribute for "baz"');
- is($meta->find_attribute_by_name('$foo'), $FOO_ATTR, '... got the right attribute for "foo"');
-
+ is($meta->find_attribute_by_name('$baz'), $BAZ_ATTR, '... got the right attribute for "baz"');
+ is($meta->find_attribute_by_name('$foo'), $FOO_ATTR, '... got the right attribute for "foo"');
+
is_deeply(
[ sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ],
- [
+ [
$BAR_ATTR,
$BAZ_ATTR,
- $FOO_ATTR,
+ $FOO_ATTR,
],
'... got the right list of applicable attributes for Baz');
-
+
is_deeply(
[ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ],
[ Bar->meta, Baz->meta, Foo->meta ],
- '... got the right list of associated classes from the applicable attributes for Baz');
-
+ '... got the right list of associated classes from the applicable attributes for Baz');
+
my $attr;
lives_ok {
$attr = $meta->remove_attribute('$baz');
} '... removed the $baz attribute successfully';
- is($attr, $BAZ_ATTR, '... got the right attribute back for Baz');
-
- ok(!$meta->has_attribute('$baz'), '... Baz no longer has $baz attribute');
- is($meta->get_attribute('$baz'), undef, '... Baz no longer has $baz attribute');
+ is($attr, $BAZ_ATTR, '... got the right attribute back for Baz');
+
+ ok(!$meta->has_attribute('$baz'), '... Baz no longer has $baz attribute');
+ is($meta->get_attribute('$baz'), undef, '... Baz no longer has $baz attribute');
ok(!$meta->has_method('get_baz'), '... a reader has been removed');
ok(!$meta->has_method('set_baz'), '... a writer has been removed');
is_deeply(
[ sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ],
- [
+ [
$BAR_ATTR,
- $FOO_ATTR,
+ $FOO_ATTR,
],
'... got the right list of applicable attributes for Baz');
lives_ok {
$attr = Bar->meta->remove_attribute('$bar');
} '... removed the $bar attribute successfully';
- is($attr, $BAR_ATTR, '... got the right attribute back for Bar');
+ is($attr, $BAR_ATTR, '... got the right attribute back for Bar');
- ok(!Bar->meta->has_attribute('$bar'), '... Bar no longer has $bar attribute');
+ ok(!Bar->meta->has_attribute('$bar'), '... Bar no longer has $bar attribute');
ok(!Bar->meta->has_method('bar'), '... a accessor has been removed');
}
is_deeply(
[ sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ],
- [
+ [
$BAR_ATTR_2,
- $FOO_ATTR,
+ $FOO_ATTR,
],
'... got the right list of applicable attributes for Baz');
is($val, undef, '... got the right value back (undef)');
}
+
+{
+ package Buzz;
+ use metaclass;
+ use Scalar::Util qw/blessed/;
+
+ my $meta = Buzz->meta;
+ ::lives_ok {
+ $meta->add_attribute($FOO_ATTR_2);
+ } '... we added an attribute to Buzz successfully';
+
+ ::lives_ok {
+ $meta->add_method(build_foo => sub{ blessed shift; });
+ } '... we added a method to Buzz successfully';
+}
+
+{
+ my $buzz;
+ ::lives_ok { $buzz = Buzz->meta->new_object } '...Buzz instantiated successfully';
+ ::is($buzz->foo, 'Buzz', 'foo builder works as expected');
+}
use strict;
use warnings;
-use Test::More tests => 51;
+use Test::More tests => 54;
use Test::Exception;
BEGIN {
- use_ok('Class::MOP');
+ use_ok('Class::MOP');
}
{
{
my $meta = Class::MOP::Attribute->meta();
isa_ok($meta, 'Class::MOP::Class');
-
+
my @methods = qw(
meta
new clone
-
+
initialize_instance_slot
-
+
name
has_accessor accessor
has_writer writer get_write_method
has_reader reader get_read_method
has_predicate predicate
has_clearer clearer
+ has_builder builder
has_init_arg init_arg
has_default default is_default_a_coderef
-
+
slots
get_value
set_value
has_value
clear_value
-
+
associated_class
- attach_to_class detach_from_class
-
+ attach_to_class detach_from_class
+
accessor_metaclass
-
+
associated_methods
associate_method
-
+
process_accessors
install_accessors
remove_accessors
);
-
+
is_deeply(
[ sort $meta->get_method_list ],
[ sort @methods ],
- '... our method list matches');
-
+ '... our method list matches');
+
foreach my $method_name (@methods) {
ok($meta->has_method($method_name), '... Class::MOP::Attribute->has_method(' . $method_name . ')');
}
-
+
my @attributes = (
'$!name',
'$!accessor',
'$!writer',
'$!predicate',
'$!clearer',
+ '$!builder',
'$!init_arg',
'$!default',
'$!associated_class',
[ sort $meta->get_attribute_list ],
[ sort @attributes ],
'... our attribute list matches');
-
+
foreach my $attribute_name (@attributes) {
- ok($meta->has_attribute($attribute_name), '... Class::MOP::Attribute->has_attribute(' . $attribute_name . ')');
+ ok($meta->has_attribute($attribute_name), '... Class::MOP::Attribute->has_attribute(' . $attribute_name . ')');
}
-
- # We could add some tests here to make sure that
- # the attribute have the appropriate
- # accessor/reader/writer/predicate combinations,
- # but that is getting a little excessive so I
- # wont worry about it for now. Maybe if I get
+
+ # We could add some tests here to make sure that
+ # the attribute have the appropriate
+ # accessor/reader/writer/predicate combinations,
+ # but that is getting a little excessive so I
+ # wont worry about it for now. Maybe if I get
# bored I will do it.
}
use strict;
use warnings;
-use Test::More tests => 67;
+use Test::More tests => 73;
use Test::Exception;
BEGIN {
is($attr->name, '$foo', '... $attr->name == $foo');
ok($attr->has_init_arg, '... $attr does have an init_arg');
- is($attr->init_arg, '$foo', '... $attr init_arg is the name');
-
+ is($attr->init_arg, '$foo', '... $attr init_arg is the name');
+
ok(!$attr->has_accessor, '... $attr does not have an accessor');
ok(!$attr->has_reader, '... $attr does not have an reader');
ok(!$attr->has_writer, '... $attr does not have an writer');
- ok(!$attr->has_default, '... $attr does not have an default');
-
+ ok(!$attr->has_default, '... $attr does not have an default');
+ ok(!$attr->has_builder, '... $attr does not have a builder');
+
my $class = Class::MOP::Class->initialize('Foo');
isa_ok($class, 'Class::MOP::Class');
-
+
lives_ok {
$attr->attach_to_class($class);
} '... attached a class successfully';
-
+
is($attr->associated_class, $class, '... the class was associated correctly');
-
+
my $attr_clone = $attr->clone();
isa_ok($attr_clone, 'Class::MOP::Attribute');
isnt($attr, $attr_clone, '... but they are different instances');
-
+
is($attr->associated_class, $attr_clone->associated_class, '... the associated classes are the same though');
- is($attr->associated_class, $class, '... the associated classes are the same though');
- is($attr_clone->associated_class, $class, '... the associated classes are the same though');
-
+ is($attr->associated_class, $class, '... the associated classes are the same though');
+ is($attr_clone->associated_class, $class, '... the associated classes are the same though');
+
is_deeply($attr, $attr_clone, '... but they are the same inside');
}
isa_ok($attr, 'Class::MOP::Attribute');
is($attr->name, '$foo', '... $attr->name == $foo');
-
+
ok($attr->has_init_arg, '... $attr does have an init_arg');
is($attr->init_arg, '-foo', '... $attr->init_arg == -foo');
- ok($attr->has_default, '... $attr does have an default');
+ ok($attr->has_default, '... $attr does have an default');
is($attr->default, 'BAR', '... $attr->default == BAR');
-
+ ok(!$attr->has_builder, '... $attr does not have a builder');
+
ok(!$attr->has_accessor, '... $attr does not have an accessor');
ok(!$attr->has_reader, '... $attr does not have an reader');
- ok(!$attr->has_writer, '... $attr does not have an writer');
-
+ ok(!$attr->has_writer, '... $attr does not have an writer');
+
my $attr_clone = $attr->clone();
isa_ok($attr_clone, 'Class::MOP::Attribute');
isnt($attr, $attr_clone, '... but they are different instances');
-
+
is($attr->associated_class, $attr_clone->associated_class, '... the associated classes are the same though');
- is($attr->associated_class, undef, '... the associated class is actually undef');
- is($attr_clone->associated_class, undef, '... the associated class is actually undef');
-
- is_deeply($attr, $attr_clone, '... but they are the same inside');
+ is($attr->associated_class, undef, '... the associated class is actually undef');
+ is($attr_clone->associated_class, undef, '... the associated class is actually undef');
+
+ is_deeply($attr, $attr_clone, '... but they are the same inside');
}
{
isa_ok($attr, 'Class::MOP::Attribute');
is($attr->name, '$foo', '... $attr->name == $foo');
-
+
ok($attr->has_init_arg, '... $attr does have an init_arg');
is($attr->init_arg, '-foo', '... $attr->init_arg == -foo');
- ok($attr->has_default, '... $attr does have an default');
+ ok($attr->has_default, '... $attr does have an default');
is($attr->default, 'BAR', '... $attr->default == BAR');
- ok($attr->has_accessor, '... $attr does have an accessor');
+ ok($attr->has_accessor, '... $attr does have an accessor');
is($attr->accessor, 'foo', '... $attr->accessor == foo');
-
+
ok(!$attr->has_reader, '... $attr does not have an reader');
- ok(!$attr->has_writer, '... $attr does not have an writer');
-
+ ok(!$attr->has_writer, '... $attr does not have an writer');
+
my $attr_clone = $attr->clone();
isa_ok($attr_clone, 'Class::MOP::Attribute');
isnt($attr, $attr_clone, '... but they are different instances');
-
- is_deeply($attr, $attr_clone, '... but they are the same inside');
+
+ is_deeply($attr, $attr_clone, '... but they are the same inside');
}
{
my $attr = Class::MOP::Attribute->new('$foo', (
reader => 'get_foo',
- writer => 'set_foo',
+ writer => 'set_foo',
init_arg => '-foo',
default => 'BAR'
));
isa_ok($attr, 'Class::MOP::Attribute');
is($attr->name, '$foo', '... $attr->name == $foo');
-
+
ok($attr->has_init_arg, '... $attr does have an init_arg');
is($attr->init_arg, '-foo', '... $attr->init_arg == -foo');
- ok($attr->has_default, '... $attr does have an default');
+ ok($attr->has_default, '... $attr does have an default');
is($attr->default, 'BAR', '... $attr->default == BAR');
ok($attr->has_reader, '... $attr does have an reader');
- is($attr->reader, 'get_foo', '... $attr->reader == get_foo');
+ is($attr->reader, 'get_foo', '... $attr->reader == get_foo');
ok($attr->has_writer, '... $attr does have an writer');
- is($attr->writer, 'set_foo', '... $attr->writer == set_foo');
+ is($attr->writer, 'set_foo', '... $attr->writer == set_foo');
+
+ ok(!$attr->has_accessor, '... $attr does not have an accessor');
- ok(!$attr->has_accessor, '... $attr does not have an accessor');
-
my $attr_clone = $attr->clone();
isa_ok($attr_clone, 'Class::MOP::Attribute');
isnt($attr, $attr_clone, '... but they are different instances');
-
- is_deeply($attr, $attr_clone, '... but they are the same inside');
+
+ is_deeply($attr, $attr_clone, '... but they are the same inside');
}
{
my $attr = Class::MOP::Attribute->new('$foo');
isa_ok($attr, 'Class::MOP::Attribute');
-
+
my $attr_clone = $attr->clone('name' => '$bar');
isa_ok($attr_clone, 'Class::MOP::Attribute');
isnt($attr, $attr_clone, '... but they are different instances');
-
+
isnt($attr->name, $attr_clone->name, '... we changes the name parameter');
-
+
is($attr->name, '$foo', '... $attr->name == $foo');
- is($attr_clone->name, '$bar', '... $attr_clone->name == $bar');
+ is($attr_clone->name, '$bar', '... $attr_clone->name == $bar');
}
+{
+ my $attr = Class::MOP::Attribute->new('$foo', (builder => 'foo_builder'));
+ isa_ok($attr, 'Class::MOP::Attribute');
+
+ ok(!$attr->has_default, '... $attr does not have a default');
+ ok($attr->has_builder, '... $attr does have a builder');
+ is($attr->builder, 'foo_builder', '... $attr->builder == foo_builder');
+
+}
use strict;
use warnings;
-use Test::More tests => 23;
+use Test::More tests => 29;
use Test::Exception;
BEGIN {
default => qr/hello (.*)/
));
} '... no refs for defaults';
-
+
dies_ok {
Class::MOP::Attribute->new('$test' => (
default => []
));
- } '... no refs for defaults';
-
+ } '... no refs for defaults';
+
dies_ok {
Class::MOP::Attribute->new('$test' => (
default => {}
));
- } '... no refs for defaults';
-
-
+ } '... no refs for defaults';
+
+
dies_ok {
Class::MOP::Attribute->new('$test' => (
default => \(my $var)
));
- } '... no refs for defaults';
+ } '... no refs for defaults';
dies_ok {
Class::MOP::Attribute->new('$test' => (
}
+{
+ dies_ok {
+ Class::MOP::Attribute->new('$test' => (
+ builder => qr/hello (.*)/
+ ));
+ } '... no refs for builders';
+
+ dies_ok {
+ Class::MOP::Attribute->new('$test' => (
+ builder => []
+ ));
+ } '... no refs for builders';
+
+ dies_ok {
+ Class::MOP::Attribute->new('$test' => (
+ builder => {}
+ ));
+ } '... no refs for builders';
+
+
+ dies_ok {
+ Class::MOP::Attribute->new('$test' => (
+ builder => \(my $var)
+ ));
+ } '... no refs for builders';
+
+ dies_ok {
+ Class::MOP::Attribute->new('$test' => (
+ builder => bless {} => 'Foo'
+ ));
+ } '... no refs for builders';
+
+ dies_ok {
+ Class::MOP::Attribute->new('$test' => (
+ builder => 'Foo', default => 'Foo'
+ ));
+ } '... no default AND builder';
+
+}
+
+
{ # bad construtor args
dies_ok {
Class::MOP::Attribute->new();
}
{
- my $attr = Class::MOP::Attribute->new('$test');
+ my $attr = Class::MOP::Attribute->new('$test');
dies_ok {
$attr->attach_to_class();
} '... attach_to_class died as expected';
-
+
dies_ok {
$attr->attach_to_class('Fail');
- } '... attach_to_class died as expected';
-
+ } '... attach_to_class died as expected';
+
dies_ok {
$attr->attach_to_class(bless {} => 'Fail');
- } '... attach_to_class died as expected';
+ } '... attach_to_class died as expected';
}
{
my $attr = Class::MOP::Attribute->new('$test' => (
reader => [ 'whoops, this wont work' ]
));
-
+
$attr->attach_to_class(Class::MOP::Class->initialize('Foo'));
dies_ok {
$attr->install_accessors;
- } '... bad reader format';
+ } '... bad reader format';
}
{
my $attr = My::Attribute->new('$test' => (
reader => 'test'
));
-
+
dies_ok {
$attr->install_accessors;
- } '... failed to generate accessors correctly';
+ } '... failed to generate accessors correctly';
}
{
my $attr = Class::MOP::Attribute->new('$test' => (
predicate => 'has_test'
));
-
+
my $Bar = Class::MOP::Class->create('Bar');
isa_ok($Bar, 'Class::MOP::Class');
-
+
$Bar->add_attribute($attr);
-
+
can_ok('Bar', 'has_test');
-
- is($attr, $Bar->remove_attribute('$test'), '... removed the $test attribute');
-
- ok(!Bar->can('has_test'), '... Bar no longer has the "has_test" method');
+
+ is($attr, $Bar->remove_attribute('$test'), '... removed the $test attribute');
+
+ ok(!Bar->can('has_test'), '... Bar no longer has the "has_test" method');
}
{
# NOTE:
- # the next three tests once tested that
- # the code would fail, but we lifted the
- # restriction so you can have an accessor
- # along with a reader/writer pair (I mean
- # why not really). So now they test that
- # it works, which is kinda silly, but it
+ # the next three tests once tested that
+ # the code would fail, but we lifted the
+ # restriction so you can have an accessor
+ # along with a reader/writer pair (I mean
+ # why not really). So now they test that
+ # it works, which is kinda silly, but it
# tests the API change, so I keep it.
lives_ok {
lives_ok {
Class::MOP::Attribute->new('$foo', (
accessor => 'foo',
- reader => 'get_foo',
+ reader => 'get_foo',
writer => 'set_foo',
));
} '... can create accessors with reader/writers';
projects / gitmo/Class-MOP.git / commitdiff