From: Guillermo Roditi Date: Fri, 26 Oct 2007 18:22:11 +0000 (+0000) Subject: builder changes. sorry about diff noise, my editor ate trailing whitespace :( X-Git-Tag: 0_44~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1d68af0454f55a8b088f8bc1887a0a5ce54d2a22;p=gitmo%2FClass-MOP.git builder changes. sorry about diff noise, my editor ate trailing whitespace :( --- diff --git a/Changes b/Changes index 8955b23..7806341 100644 --- a/Changes +++ b/Changes @@ -4,6 +4,15 @@ Revision history for Perl extension Class-MOP. - 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 diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index c090e43..14afdef 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -21,29 +21,29 @@ our $AUTHORITY = 'cpan:STEVAN'; # 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 ... @@ -53,45 +53,45 @@ sub load_class { 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 ## -------------------------------------------------------- @@ -100,12 +100,12 @@ sub is_class_loaded { 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', @@ -121,7 +121,7 @@ Class::MOP::Package->meta->add_attribute( 'namespace' => \&Class::MOP::Package::namespace }, # NOTE: - # protect this from silliness + # protect this from silliness init_arg => '!............( DO NOT DO THIS )............!', default => sub { \undef } )) @@ -133,19 +133,19 @@ Class::MOP::Package->meta->add_attribute( 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 :) @@ -154,32 +154,32 @@ Class::MOP::Module->meta->add_attribute( 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 } )) @@ -191,12 +191,12 @@ Class::MOP::Module->meta->add_attribute( 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', @@ -207,10 +207,10 @@ Class::MOP::Class->meta->add_attribute( 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 { {} } @@ -222,11 +222,11 @@ Class::MOP::Class->meta->add_attribute( 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 } )) @@ -234,12 +234,12 @@ Class::MOP::Class->meta->add_attribute( 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', )) @@ -247,38 +247,38 @@ Class::MOP::Class->meta->add_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 @@ -287,12 +287,12 @@ Class::MOP::Attribute->meta->add_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 } )) @@ -302,12 +302,12 @@ Class::MOP::Attribute->meta->add_attribute( 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 } )) @@ -354,6 +354,14 @@ Class::MOP::Attribute->meta->add_attribute( ); 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 }, @@ -365,7 +373,7 @@ Class::MOP::Attribute->meta->add_attribute( 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 }, )) ); @@ -373,29 +381,35 @@ Class::MOP::Attribute->meta->add_attribute( 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); @@ -403,7 +417,7 @@ Class::MOP::Attribute->meta->add_method('new' => sub { Class::MOP::Attribute->meta->add_method('clone' => sub { my $self = shift; - $self->meta->clone_object($self, @_); + $self->meta->clone_object($self, @_); }); ## -------------------------------------------------------- @@ -420,9 +434,9 @@ Class::MOP::Method->meta->add_attribute( ## 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') @@ -435,7 +449,7 @@ Class::MOP::Method::Generated->meta->add_attribute( Class::MOP::Attribute->new('$!is_inline' => ( init_arg => 'is_inline', reader => { 'is_inline' => \&Class::MOP::Method::Generated::is_inline }, - )) + )) ); ## -------------------------------------------------------- @@ -444,17 +458,17 @@ Class::MOP::Method::Generated->meta->add_attribute( 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 }, - )) + )) ); @@ -464,26 +478,26 @@ Class::MOP::Method::Accessor->meta->add_attribute( 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( @@ -498,31 +512,31 @@ 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; @@ -531,136 +545,136 @@ __END__ =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 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 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 a class builder so much as it is a I>. 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 a class builder so much as it is a I>. 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 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 -modules, this module B require you subclass it, or even that -you C 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 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 +modules, this module B require you subclass it, or even that +you C 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 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 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 and C) and -two metaclasses (C and C) which have correct +Here is a diagram showing a set of two classes (C and C) and +two metaclasses (C and C) 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. If you -are interested in why this is an issue see the paper -I 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. If you +are interested in why this is an issue see the paper +I linked to in the L 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 @@ -671,27 +685,27 @@ The protocol is divided into 3 main sub-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 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 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 for more details. @@ -706,42 +720,42 @@ See L for more details. =item B -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 -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) 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) 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 -This will return an hash of all the metaclass instances that have -been cached by B keyed by the package name. +This will return an hash of all the metaclass instances that have +been cached by B keyed by the package name. =item B -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. =item B -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. =item B @@ -760,9 +774,9 @@ been cached by B. =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> +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> email me and let me know, I would love to hear about them. =over 4 @@ -783,18 +797,18 @@ email me and let me know, I would love to hear about them. =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 =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 @@ -816,11 +830,11 @@ L =back -=head2 Articles +=head2 Articles =over 4 -=item CPAN Module Review of Class::MOP +=item CPAN Module Review of Class::MOP L @@ -828,16 +842,16 @@ L and -L. 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, 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 and +L. 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, 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. @@ -847,7 +861,7 @@ 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 @@ -874,6 +888,6 @@ Copyright 2006, 2007 by Infinity Interactive, Inc. L 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 diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 202ec69..90f7d57 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -9,41 +9,46 @@ use Class::MOP::Method::Accessor; 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}, @@ -51,21 +56,22 @@ sub new { '$!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; @@ -79,18 +85,24 @@ sub initialize_instance_slot { 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'} } @@ -103,14 +115,16 @@ sub has_reader { defined($_[0]->{'$!reader'}) ? 1 : 0 } 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. @@ -119,19 +133,19 @@ sub init_arg { $_[0]->{'$!init_arg'} } 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'}; } @@ -139,21 +153,21 @@ sub 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) = @_; @@ -180,18 +194,18 @@ sub get_value { 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 ... @@ -206,34 +220,34 @@ sub process_accessors { 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(); @@ -244,11 +258,11 @@ sub install_accessors { $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; } @@ -257,25 +271,25 @@ sub install_accessors { 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; } } @@ -286,23 +300,23 @@ __END__ =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 )); @@ -310,13 +324,13 @@ Class::MOP::Attribute - Attribute Meta Object =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 @@ -327,7 +341,7 @@ object attributes. =item B -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: @@ -335,60 +349,67 @@ are as follows: =item I -This should be a string value representing the expected key in -an initialization hash. For instance, if we have an I +This should be a string value representing the expected key in +an initialization hash. For instance, if we have an I 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 -The value of this key is the default value which -C will initialize the -attribute to. +The value of this key is the default value which +C will initialize the +attribute to. + +=item I + +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 -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 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 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 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 and +this class to acheive it. However, this is currently left as an exercise to the reader :). =back @@ -403,39 +424,39 @@ reference which will be installed as the method itself. =item I -The I 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 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 -This method will properly handle the following code, by assigning an +This method will properly handle the following code, by assigning an C value to the attribute. $object->set_something(undef); =item I -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 -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 -This method will properly handle the following code, by assigning an +This method will properly handle the following code, by assigning an C value to the attribute. $object->set_something(); =item I -This is a basic test to see if the value of the attribute is not -C. 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. It will return true (C<1>) if the attribute's value is defined, and false (C<0>) otherwise. =item I @@ -449,14 +470,14 @@ back to their "unfulfilled" state. =item B -=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 @@ -473,20 +494,20 @@ even to attributes with just write only accessors. =item B -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 method calls. =item B This will clear the value in the C<$instance>. This is basically what the default -C would call. Note that this may be done even if the attirbute does not +C 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. I think they are pretty much self-explanitory. =over 4 @@ -509,13 +530,13 @@ passed into C. I think they are pretty much self-explanitory. =item B -As noted in the documentation for C above, if the I +As noted in the documentation for C above, if the I value is a CODE reference, this accessor will pass a single additional argument C<$instance> into it and return the value. =item B -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 @@ -552,8 +573,8 @@ These are all basic predicate methods for the values passed into C. =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. @@ -565,17 +586,17 @@ This returns the metaclass this attribute is associated with. =item B -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 -This will remove the weakened reference to the class. It does B -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 +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 instead. =back @@ -587,43 +608,43 @@ L instead. =item B Accessors are generated by an accessor metaclass, which is usually -a subclass of C. This method returns +a subclass of C. This method returns the name of the accessor metaclass that this attribute uses. =item B -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 -This will return the list of methods which have been associated with -the C methods. +This will return the list of methods which have been associated with +the C methods. =item B -This allows the attribute to generate and install code for it's own -I methods. This is called by +This allows the attribute to generate and install code for it's own +I methods. This is called by C. -This method will call C for each of the possible +This method will call C for each of the possible method types (accessor, reader, writer & predicate). =item B -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 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 methods listed below) or it will +use the custom method passed through the constructor. =item B -This allows the attribute to remove the method for it's own -I. This is called by +This allows the attribute to remove the method for it's own +I. This is called by C. -NOTE: This does not currently remove methods from the list returned +NOTE: This does not currently remove methods from the list returned by C, that is on the TODO list. =back @@ -634,13 +655,13 @@ by C, that is on the TODO list. =item B -This will return a B instance which is related +This will return a B instance which is related to this class. -It should also be noted that B 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 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 @@ -655,7 +676,7 @@ Copyright 2006, 2007 by Infinity Interactive, Inc. L 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 diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 2c79d9c..ee65f1d 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -13,7 +13,7 @@ use Scalar::Util 'blessed', 'reftype', 'weaken'; 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'; @@ -789,7 +789,7 @@ sub is_immutable { 0 } 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); } diff --git a/t/005_attributes.t b/t/005_attributes.t index a295619..40cd712 100644 --- a/t/005_attributes.t +++ b/t/005_attributes.t @@ -3,11 +3,11 @@ 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'); @@ -16,11 +16,16 @@ my $BAR_ATTR = Class::MOP::Attribute->new('$bar' => ( )); 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'); @@ -35,21 +40,21 @@ 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); @@ -62,17 +67,17 @@ is($BAZ_ATTR->name, '$baz', '... got the attributes name correctly'); ::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'); @@ -89,42 +94,42 @@ is($BAZ_ATTR->name, '$baz', '... got the attributes name correctly'); { 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'); @@ -138,18 +143,18 @@ is($BAZ_ATTR->name, '$baz', '... got the attributes name correctly'); 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'); @@ -166,3 +171,24 @@ is($BAZ_ATTR->name, '$baz', '... got the attributes name correctly'); 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'); +} diff --git a/t/014_attribute_introspection.t b/t/014_attribute_introspection.t index d2d9103..368494b 100644 --- a/t/014_attribute_introspection.t +++ b/t/014_attribute_introspection.t @@ -3,11 +3,11 @@ 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'); } { @@ -18,50 +18,51 @@ BEGIN { { 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', @@ -69,6 +70,7 @@ BEGIN { '$!writer', '$!predicate', '$!clearer', + '$!builder', '$!init_arg', '$!default', '$!associated_class', @@ -79,15 +81,15 @@ BEGIN { [ 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. } diff --git a/t/020_attribute.t b/t/020_attribute.t index 56a0acf..33cafdd 100644 --- a/t/020_attribute.t +++ b/t/020_attribute.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 67; +use Test::More tests => 73; use Test::Exception; BEGIN { @@ -17,30 +17,31 @@ 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'); } @@ -52,25 +53,26 @@ BEGIN { 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'); } { @@ -82,66 +84,75 @@ BEGIN { 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'); + +} diff --git a/t/021_attribute_errors_and_edge_cases.t b/t/021_attribute_errors_and_edge_cases.t index 7e948ab..da28766 100644 --- a/t/021_attribute_errors_and_edge_cases.t +++ b/t/021_attribute_errors_and_edge_cases.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 23; +use Test::More tests => 29; use Test::Exception; BEGIN { @@ -19,25 +19,25 @@ 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' => ( @@ -47,6 +47,47 @@ BEGIN { } +{ + 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(); @@ -62,30 +103,30 @@ BEGIN { } { - 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'; } { @@ -107,38 +148,38 @@ BEGIN { 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 { @@ -158,7 +199,7 @@ BEGIN { lives_ok { Class::MOP::Attribute->new('$foo', ( accessor => 'foo', - reader => 'get_foo', + reader => 'get_foo', writer => 'set_foo', )); } '... can create accessors with reader/writers';