From: Guillermo Roditi Date: Fri, 26 Oct 2007 20:39:44 +0000 (+0000) Subject: builder and lazy_build changes. note that this ups the req of MOP to 0.43! sorry... X-Git-Tag: 0_27~12 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=26fbace8d6e64e26057f3778161dd7029f517b6a;p=gitmo%2FMoose.git builder and lazy_build changes. note that this ups the req of MOP to 0.43! sorry about the change noise. editor kills trailing whitespace --- diff --git a/Changes b/Changes index 43b8c22..3c73545 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,16 @@ Revision history for Perl extension Moose +0.XX + * Moose::Meta::Attribute + - Added support for the new builder option (groditi) + - Added support for lazy_buil option (groditi) + + * Moose::Meta::Method::Accessor + - Added support for lazy_buil option (groditi) + + * t/ + - tests for builder and lazy_build + 0.27 * fixing some misc. bits in the docs that got mentioned on CPAN Forum diff --git a/Makefile.PL b/Makefile.PL index 2159752..b43cdca 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -12,7 +12,7 @@ my $win32 = !! ( $^O eq 'Win32' or $^O eq 'cygwin' ); # prereqs requires 'Scalar::Util' => $win32 ? '1.17' : '1.18'; requires 'Carp'; -requires 'Class::MOP' => '0.39'; +requires 'Class::MOP' => '0.43'; requires 'Sub::Name' => '0.02'; requires 'Sub::Exporter' => '0.972'; requires 'B'; diff --git a/lib/Moose.pm b/lib/Moose.pm index 7b3bad7..1747b9c 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -4,7 +4,7 @@ package Moose; use strict; use warnings; -our $VERSION = '0.27'; +our $VERSION = '0.28'; our $AUTHORITY = 'cpan:STEVAN'; use Scalar::Util 'blessed', 'reftype'; @@ -33,7 +33,7 @@ use Moose::Util::TypeConstraints; sub init_meta { my ( $class, $base_class, $metaclass ) = @_; $base_class = $class unless defined $base_class; - $metaclass = 'Moose::Meta::Class' unless defined $metaclass; + $metaclass = 'Moose::Meta::Class' unless defined $metaclass; confess "The Metaclass $metaclass must be a subclass of Moose::Meta::Class." @@ -206,7 +206,7 @@ use Moose::Util::TypeConstraints; # 1 extra level because it's called by import so there's a layer of indirection sub _get_caller{ my $offset = 1; - return + return ref $_[1] && defined $_[1]->{into} ? $_[1]->{into} : ref $_[1] && defined $_[1]->{into_level} @@ -216,7 +216,7 @@ use Moose::Util::TypeConstraints; sub import { $CALLER = _get_caller(@_); - + strict->import; warnings->import; @@ -294,61 +294,61 @@ Moose - A complete modern object system for Perl 5 package Point; use Moose; # automatically turns on strict and warnings - + has 'x' => (is => 'rw', isa => 'Int'); has 'y' => (is => 'rw', isa => 'Int'); - + sub clear { my $self = shift; $self->x(0); - $self->y(0); + $self->y(0); } - + package Point3D; use Moose; - + extends 'Point'; - + has 'z' => (is => 'rw', isa => 'Int'); - + after 'clear' => sub { my $self = shift; $self->z(0); - }; + }; =head1 DESCRIPTION -Moose is an extension of the Perl 5 object system. +Moose is an extension of the Perl 5 object system. =head2 Another object system!?!? -Yes, I know there has been an explosion recently of new ways to +Yes, I know there has been an explosion recently of new ways to build object's in Perl 5, most of them based on inside-out objects -and other such things. Moose is different because it is not a new -object system for Perl 5, but instead an extension of the existing +and other such things. Moose is different because it is not a new +object system for Perl 5, but instead an extension of the existing object system. -Moose is built on top of L, which is a metaclass system -for Perl 5. This means that Moose not only makes building normal -Perl 5 objects better, but it also provides the power of metaclass +Moose is built on top of L, which is a metaclass system +for Perl 5. This means that Moose not only makes building normal +Perl 5 objects better, but it also provides the power of metaclass programming. =head2 Is this for real? Or is this just an experiment? Moose is I on the prototypes and experiments I did for the Perl 6 -meta-model. However, Moose is B an experiment/prototype; it is for B. +meta-model. However, Moose is B an experiment/prototype; it is for B. -=head2 Is this ready for use in production? +=head2 Is this ready for use in production? -Yes, I believe that it is. +Yes, I believe that it is. -Moose has been used successfully in production environemnts by several people -and companies (including the one I work for). There are Moose applications -which have been in production with little or no issue now for over a year. -I consider it highly stable and we are commited to keeping it stable. +Moose has been used successfully in production environemnts by several people +and companies (including the one I work for). There are Moose applications +which have been in production with little or no issue now for over a year. +I consider it highly stable and we are commited to keeping it stable. -Of course, in the end, you need to make this call yourself. If you have -any questions or concerns, please feel free to email me, or even the list +Of course, in the end, you need to make this call yourself. If you have +any questions or concerns, please feel free to email me, or even the list or just stop by #moose and ask away. =head2 Is Moose just Perl 6 in Perl 5? @@ -364,7 +364,7 @@ Moose makes every attempt to provide as much convenience as possible during class construction/definition, but still stay out of your way if you want it to. Here are a few items to note when building classes with Moose. -Unless specified with C, any class which uses Moose will +Unless specified with C, any class which uses Moose will inherit from L. Moose will also manage all attributes (including inherited ones) that are @@ -375,8 +375,8 @@ or coercion. =head1 EXPORTED FUNCTIONS -Moose will export a number of functions into the class's namespace which -may then be used to set up the class. These functions all work directly +Moose will export a number of functions into the class's namespace which +may then be used to set up the class. These functions all work directly on the current class. =over 4 @@ -389,29 +389,29 @@ This is a method which provides access to the current class's metaclass. This function will set the superclass(es) for the current class. -This approach is recommended instead of C, because C -actually Ces onto the class's C<@ISA>, whereas C will -replace it. This is important to ensure that classes which do not have +This approach is recommended instead of C, because C +actually Ces onto the class's C<@ISA>, whereas C will +replace it. This is important to ensure that classes which do not have superclasses still properly inherit from L. =item B -This will apply a given set of C<@roles> to the local class. Role support +This will apply a given set of C<@roles> to the local class. Role support is currently under heavy development; see L for more details. =item B %options> -This will install an attribute of a given C<$name> into the current class. -The C<%options> are the same as those provided by -L, in addition to the list below which are provided +This will install an attribute of a given C<$name> into the current class. +The C<%options> are the same as those provided by +L, in addition to the list below which are provided by Moose (L to be more specific): =over 4 =item I 'rw'|'ro'> -The I option accepts either I (for read/write) or I (for read -only). These will create either a read/write accessor or a read-only +The I option accepts either I (for read/write) or I (for read +only). These will create either a read/write accessor or a read-only accessor respectively, using the same name as the C<$name> of the attribute. If you need more control over how your accessors are named, you can use the @@ -420,30 +420,30 @@ L. =item I $type_name> -The I option uses Moose's type constraint facilities to set up runtime -type checking for this attribute. Moose will perform the checks during class -construction, and within any accessors. The C<$type_name> argument must be a -string. The string may be either a class name or a type defined using +The I option uses Moose's type constraint facilities to set up runtime +type checking for this attribute. Moose will perform the checks during class +construction, and within any accessors. The C<$type_name> argument must be a +string. The string may be either a class name or a type defined using Moose's type definition features. (Refer to L for information on how to define a new type, and how to retrieve type meta-data). =item I (1|0)> -This will attempt to use coercion with the supplied type constraint to change -the value passed into any accessors or constructors. You B have supplied +This will attempt to use coercion with the supplied type constraint to change +the value passed into any accessors or constructors. You B have supplied a type constraint in order for this to work. See L for an example. =item I $role_name> -This will accept the name of a role which the value stored in this attribute +This will accept the name of a role which the value stored in this attribute is expected to have consumed. =item I (1|0)> -This marks the attribute as being required. This means a I value must be -supplied during class construction, and the attribute may never be set to -C with an accessor. +This marks the attribute as being required. This means a I value must be +supplied during class construction, and the attribute may never be set to +C with an accessor. =item I (1|0)> @@ -453,12 +453,12 @@ coerced. =item I (1|0)> -This will tell the class to not create this slot until absolutely necessary. +This will tell the class to not create this slot until absolutely necessary. If an attribute is marked as lazy it B have a default supplied. =item I (1|0)> -This tells the accessor whether to automatically dereference the value returned. +This tells the accessor whether to automatically dereference the value returned. This is only legal if your C option is either C or C. =item I $metaclass_name> @@ -487,13 +487,13 @@ attribute. =item I ARRAY | HASH | REGEXP | ROLE | CODE> -The I option provides Moose classes with automated delegation features. -This is a pretty complex and powerful option. It accepts many different option -formats, each with its own benefits and drawbacks. +The I option provides Moose classes with automated delegation features. +This is a pretty complex and powerful option. It accepts many different option +formats, each with its own benefits and drawbacks. B This feature is no longer experimental, but it may still have subtle bugs lurking in the deeper corners. If you think you have found a bug, you -probably have, so please report it to me right away. +probably have, so please report it to me right away. B The class being delegated to does not need to be a Moose based class, which is why this feature is especially useful when wrapping non-Moose classes. @@ -519,61 +519,61 @@ Below is the documentation for each option format: =item C -This is the most common usage for I. You basically pass a list of -method names to be delegated, and Moose will install a delegation method +This is the most common usage for I. You basically pass a list of +method names to be delegated, and Moose will install a delegation method for each one. =item C -This is the second most common usage for I. Instead of a list of -method names, you pass a HASH ref where each key is the method name you -want installed locally, and its value is the name of the original method -in the class being delegated to. +This is the second most common usage for I. Instead of a list of +method names, you pass a HASH ref where each key is the method name you +want installed locally, and its value is the name of the original method +in the class being delegated to. -This can be very useful for recursive classes like trees. Here is a +This can be very useful for recursive classes like trees. Here is a quick example (soon to be expanded into a Moose::Cookbook::Recipe): package Tree; use Moose; - + has 'node' => (is => 'rw', isa => 'Any'); - + has 'children' => ( is => 'ro', isa => 'ArrayRef', default => sub { [] } ); - + has 'parent' => ( is => 'rw', isa => 'Tree', is_weak_ref => 1, handles => { parent_node => 'node', - siblings => 'children', + siblings => 'children', } ); In this example, the Tree package gets C and C methods, which delegate to the C and C methods (respectively) of the Tree -instance stored in the C slot. +instance stored in the C slot. =item C -The regexp option works very similar to the ARRAY option, except that it builds -the list of methods for you. It starts by collecting all possible methods of the -class being delegated to, then filters that list using the regexp supplied here. +The regexp option works very similar to the ARRAY option, except that it builds +the list of methods for you. It starts by collecting all possible methods of the +class being delegated to, then filters that list using the regexp supplied here. -B An I option is required when using the regexp option format. This -is so that we can determine (at compile time) the method list from the class. +B An I option is required when using the regexp option format. This +is so that we can determine (at compile time) the method list from the class. Without an I this is just not possible. =item C -With the role option, you specify the name of a role whose "interface" then -becomes the list of methods to handle. The "interface" can be defined as; the -methods of the role and any required methods of the role. It should be noted -that this does B include any method modifiers or generated attribute +With the role option, you specify the name of a role whose "interface" then +becomes the list of methods to handle. The "interface" can be defined as; the +methods of the role and any required methods of the role. It should be noted +that this does B include any method modifiers or generated attribute methods (which is consistent with role composition). =item C @@ -585,7 +585,7 @@ metaclass twiddling. This takes a code reference, which should expect two arguments. The first is the attribute meta-object this I is attached to. The second is the metaclass of the class being delegated to. It expects you to return a hash (not -a HASH ref) of the methods you want mapped. +a HASH ref) of the methods you want mapped. =back @@ -593,23 +593,23 @@ a HASH ref) of the methods you want mapped. =item B %options> -This is variation on the normal attibute creator C which allows you to +This is variation on the normal attibute creator C which allows you to clone and extend an attribute from a superclass. Here is a quick example: package Foo; use Moose; - + has 'message' => ( - is => 'rw', + is => 'rw', isa => 'Str', default => 'Hello, I am a Foo' ); - + package My::Foo; use Moose; - + extends 'Foo'; - + has '+message' => (default => 'Hello I am My::Foo'); What is happening here is that B is cloning the C attribute @@ -621,15 +621,15 @@ sanity into it. You are only allowed to change the following attributes: =over 4 -=item I +=item I Change the default value of an attribute. -=item I +=item I Change whether the attribute attempts to coerce a value passed to it. -=item I +=item I Change if the attribute is required to have a value. @@ -648,8 +648,8 @@ subtype of the old type. =item I -You are allowed to B a new C definition, but you are B -allowed to I one. +You are allowed to B a new C definition, but you are B +allowed to I one. =back @@ -666,39 +666,39 @@ Modifiers"> for now. =item B -The keyword C is a no-op when called outside of an C method. In -the context of an C method, it will call the next most appropriate +The keyword C is a no-op when called outside of an C method. In +the context of an C method, it will call the next most appropriate superclass method with the same arguments as the original method. =item B -An C method is a way of explicitly saying "I am overriding this -method from my superclass". You can call C within this method, and -it will work as expected. The same thing I be accomplished with a normal -method call and the C pseudo-package; it is really your choice. +An C method is a way of explicitly saying "I am overriding this +method from my superclass". You can call C within this method, and +it will work as expected. The same thing I be accomplished with a normal +method call and the C pseudo-package; it is really your choice. =item B -The keyword C, much like C, is a no-op outside of the context of -an C method. You can think of C as being the inverse of +The keyword C, much like C, is a no-op outside of the context of +an C method. You can think of C as being the inverse of C; the details of how C and C work is best described in the L. =item B -An C method, is a way of explicitly saying "I am augmenting this -method from my superclass". Once again, the details of how C and +An C method, is a way of explicitly saying "I am augmenting this +method from my superclass". Once again, the details of how C and C work is best described in the L. =item B This is the C function, and exported here because I use it -all the time. This feature may change in the future, so you have been warned. +all the time. This feature may change in the future, so you have been warned. =item B This is the C function, it is exported here because I -use it all the time. It is highly recommended that this is used instead of +use it all the time. It is highly recommended that this is used instead of C anywhere you need to test for an object's class name. =back @@ -716,24 +716,24 @@ to work. Here is an example: has 'first_name' => (is => 'rw', isa => 'Str'); has 'last_name' => (is => 'rw', isa => 'Str'); - - sub full_name { + + sub full_name { my $self = shift; - $self->first_name . ' ' . $self->last_name + $self->first_name . ' ' . $self->last_name } - - no Moose; # keywords are removed from the Person package + + no Moose; # keywords are removed from the Person package =head1 EXTENDING AND EMBEDDING MOOSE -Moose also offers some options for extending or embedding it into your own +Moose also offers some options for extending or embedding it into your own framework. The basic premise is to have something that sets up your class' -metaclass and export the moose declarators (C, C, C,...). +metaclass and export the moose declarators (C, C, C,...). Here is an example: package MyFramework; use Moose; - + sub import { my $CALLER = caller(); @@ -746,10 +746,10 @@ Here is an example: Moose->import({into => $CALLER}); # Do my custom framework stuff - + return 1; } - + =head2 B Moose's C method supports the L form of C<{into =E $pkg}> @@ -757,12 +757,12 @@ and C<{into_level =E 1}> =head2 B -Moose does some boot strapping: it creates a metaclass object for your class, -and then injects a C accessor into your class to retrieve it. Then it -sets your baseclass to Moose::Object or the value you pass in unless you already -have one. This is all done via C which takes the name of your class +Moose does some boot strapping: it creates a metaclass object for your class, +and then injects a C accessor into your class to retrieve it. Then it +sets your baseclass to Moose::Object or the value you pass in unless you already +have one. This is all done via C which takes the name of your class and optionally a baseclass and a metaclass as arguments. - + =head1 CAVEATS =over 4 @@ -773,9 +773,9 @@ It should be noted that C and C B be used in the same method. However, they may be combined within the same class hierarchy; see F for an example. -The reason for this is that C is only valid within a method -with the C modifier, and C will never be valid within an -C method. In fact, C will skip over any C methods +The reason for this is that C is only valid within a method +with the C modifier, and C will never be valid within an +C method. In fact, C will skip over any C methods when searching for its appropriate C. This might seem like a restriction, but I am of the opinion that keeping these @@ -793,13 +793,13 @@ not (UPDATE: so far so good). =item I blame Audrey Tang for then encouraging my meta-model habit in #perl6. -=item Without Yuval "nothingmuch" Kogman this module would not be possible, +=item Without Yuval "nothingmuch" Kogman this module would not be possible, and it certainly wouldn't have this name ;P -=item The basis of the TypeContraints module was Rob Kinyon's idea +=item The basis of the TypeContraints module was Rob Kinyon's idea originally, I just ran with it. -=item Thanks to mst & chansen and the whole #moose poose for all the +=item Thanks to mst & chansen and the whole #moose poose for all the early ideas/feature-requests/encouragement/bug-finding. =item Thanks to David "Theory" Wheeler for meta-discussions and spelling fixes. @@ -813,8 +813,8 @@ early ideas/feature-requests/encouragement/bug-finding. =item L This is the official web home of Moose, it contains links to our public SVN repo -as well as links to a number of talks and articles on Moose and Moose related -technologies. +as well as links to a number of talks and articles on Moose and Moose related +technologies. =item L documentation @@ -826,21 +826,21 @@ technologies. =back -=head2 Papers +=head2 Papers =over 4 =item L -This paper (suggested by lbr on #moose) was what lead to the implementation -of the C/C and C/C features. If you really +This paper (suggested by lbr on #moose) was what lead to the implementation +of the C/C and C/C features. If you really want to understand them, I suggest you read this. =back =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. @@ -886,7 +886,7 @@ Jonathan (jrockway) Rockway Piotr (dexter) Roszatycki -Sam (mugwump) Vilain +Sam (mugwump) Vilain ... and many other #moose folks @@ -897,6 +897,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/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index b9a3912..77cd5b6 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -8,7 +8,7 @@ use Scalar::Util 'blessed', 'weaken', 'reftype'; use Carp 'confess'; use overload (); -our $VERSION = '0.12'; +our $VERSION = '0.13'; our $AUTHORITY = 'cpan:STEVAN'; use Moose::Meta::Method::Accessor; @@ -25,6 +25,7 @@ __PACKAGE__->meta->add_attribute('is' => (reader => '_is_metadata')); # these are actual options for the attrs __PACKAGE__->meta->add_attribute('required' => (reader => 'is_required' )); __PACKAGE__->meta->add_attribute('lazy' => (reader => 'is_lazy' )); +__PACKAGE__->meta->add_attribute('lazy_build' => (reader => 'is_lazy_build' )); __PACKAGE__->meta->add_attribute('coerce' => (reader => 'should_coerce' )); __PACKAGE__->meta->add_attribute('weak_ref' => (reader => 'is_weak_ref' )); __PACKAGE__->meta->add_attribute('auto_deref' => (reader => 'should_auto_deref')); @@ -46,9 +47,9 @@ __PACKAGE__->meta->add_attribute('documentation' => ( )); sub new { - my ($class, $name, %options) = @_; - $class->_process_options($name, \%options); - return $class->SUPER::new($name, %options); + my ($class, $name, %options) = @_; + $class->_process_options($name, \%options); + return $class->SUPER::new($name, %options); } sub clone_and_inherit_options { @@ -61,7 +62,7 @@ sub clone_and_inherit_options { delete $options{$legal_option}; } } - + # handles can only be added, not changed if ($options{handles}) { confess "You can only add the 'handles' option, you cannot change it" @@ -69,114 +70,131 @@ sub clone_and_inherit_options { $actual_options{handles} = $options{handles}; delete $options{handles}; } - - # isa can be changed, but only if the - # new type is a subtype + + # isa can be changed, but only if the + # new type is a subtype if ($options{isa}) { my $type_constraint; - if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) { - $type_constraint = $options{isa}; - } - else { - $type_constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa}); - (defined $type_constraint) - || confess "Could not find the type constraint '" . $options{isa} . "'"; - } - # NOTE: - # check here to see if the new type - # is a subtype of the old one - ($type_constraint->is_subtype_of($self->type_constraint->name)) - || confess "New type constraint setting must be a subtype of inherited one" - # iff we have a type constraint that is ... - if $self->has_type_constraint; - # then we use it :) - $actual_options{type_constraint} = $type_constraint; + if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) { + $type_constraint = $options{isa}; + } + else { + $type_constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa}); + (defined $type_constraint) + || confess "Could not find the type constraint '" . $options{isa} . "'"; + } + # NOTE: + # check here to see if the new type + # is a subtype of the old one + ($type_constraint->is_subtype_of($self->type_constraint->name)) + || confess "New type constraint setting must be a subtype of inherited one" + # iff we have a type constraint that is ... + if $self->has_type_constraint; + # then we use it :) + $actual_options{type_constraint} = $type_constraint; delete $options{isa}; } - (scalar keys %options == 0) + (scalar keys %options == 0) || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")"; $self->clone(%actual_options); } sub _process_options { my ($class, $name, $options) = @_; - - if (exists $options->{is}) { - if ($options->{is} eq 'ro') { - $options->{reader} ||= $name; - (!exists $options->{trigger}) - || confess "Cannot have a trigger on a read-only attribute"; - } - elsif ($options->{is} eq 'rw') { - $options->{accessor} = $name; - ((reftype($options->{trigger}) || '') eq 'CODE') - || confess "Trigger must be a CODE ref" - if exists $options->{trigger}; - } - else { - confess "I do not understand this option (is => " . $options->{is} . ")" - } - } - - if (exists $options->{isa}) { - - if (exists $options->{does}) { - if (eval { $options->{isa}->can('does') }) { - ($options->{isa}->does($options->{does})) - || confess "Cannot have an isa option and a does option if the isa does not do the does"; - } - else { - confess "Cannot have an isa option which cannot ->does()"; - } - } - - # allow for anon-subtypes here ... - if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) { - $options->{type_constraint} = $options->{isa}; - } - else { - $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint( - $options->{isa} => { - parent => Moose::Util::TypeConstraints::find_type_constraint('Object'), - constraint => sub { $_[0]->isa($options->{isa}) } - } - ); - } - } - elsif (exists $options->{does}) { - # allow for anon-subtypes here ... - if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) { - $options->{type_constraint} = $options->{isa}; - } - else { - $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint( - $options->{does} => { - parent => Moose::Util::TypeConstraints::find_type_constraint('Role'), - constraint => sub { $_[0]->does($options->{does}) } - } - ); - } - } - - if (exists $options->{coerce} && $options->{coerce}) { - (exists $options->{type_constraint}) - || confess "You cannot have coercion without specifying a type constraint"; + + if (exists $options->{is}) { + if ($options->{is} eq 'ro') { + $options->{reader} ||= $name; + (!exists $options->{trigger}) + || confess "Cannot have a trigger on a read-only attribute"; + } + elsif ($options->{is} eq 'rw') { + $options->{accessor} = $name; + ((reftype($options->{trigger}) || '') eq 'CODE') + || confess "Trigger must be a CODE ref" + if exists $options->{trigger}; + } + else { + confess "I do not understand this option (is => " . $options->{is} . ")" + } + } + + if (exists $options->{isa}) { + + if (exists $options->{does}) { + if (eval { $options->{isa}->can('does') }) { + ($options->{isa}->does($options->{does})) + || confess "Cannot have an isa option and a does option if the isa does not do the does"; + } + else { + confess "Cannot have an isa option which cannot ->does()"; + } + } + + # allow for anon-subtypes here ... + if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) { + $options->{type_constraint} = $options->{isa}; + } + else { + $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint( + $options->{isa} => { + parent => Moose::Util::TypeConstraints::find_type_constraint('Object'), + constraint => sub { $_[0]->isa($options->{isa}) } + } + ); + } + } + elsif (exists $options->{does}) { + # allow for anon-subtypes here ... + if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) { + $options->{type_constraint} = $options->{isa}; + } + else { + $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint( + $options->{does} => { + parent => Moose::Util::TypeConstraints::find_type_constraint('Role'), + constraint => sub { $_[0]->does($options->{does}) } + } + ); + } + } + + if (exists $options->{coerce} && $options->{coerce}) { + (exists $options->{type_constraint}) + || confess "You cannot have coercion without specifying a type constraint"; confess "You cannot have a weak reference to a coerced value" - if $options->{weak_ref}; - } - - if (exists $options->{auto_deref} && $options->{auto_deref}) { - (exists $options->{type_constraint}) - || confess "You cannot auto-dereference without specifying a type constraint"; - ($options->{type_constraint}->is_a_type_of('ArrayRef') || + if $options->{weak_ref}; + } + + if (exists $options->{auto_deref} && $options->{auto_deref}) { + (exists $options->{type_constraint}) + || confess "You cannot auto-dereference without specifying a type constraint"; + ($options->{type_constraint}->is_a_type_of('ArrayRef') || $options->{type_constraint}->is_a_type_of('HashRef')) - || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef"; - } - - if (exists $options->{lazy} && $options->{lazy}) { - (exists $options->{default}) - || confess "You cannot have lazy attribute without specifying a default value for it"; - } + || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef"; + } + + if (exists $options->{lazy_build} && $options->{lazy_build} == 1) { + confess("You can not use lazy_build and default for the same attribute") + if exists $options->{default}; + $options->{lazy} = 1; + $options->{required} = 1; + if($name =~ /^_/){ + $options->{builder} ||= "_build${name}"; + $options->{clearer} ||= "_clear${name}"; + $options->{predicate} ||= "_has${name}"; + } else { + $options->{builder} ||= "build_${name}"; + $options->{clearer} ||= "clear_${name}"; + $options->{predicate} ||= "has_${name}"; + } + } + + if (exists $options->{lazy} && $options->{lazy}) { + (exists $options->{default} || exists $options->{builder} ) + || confess "You cannot have lazy attribute without specifying a default value for it"; + } + } sub initialize_instance_slot { @@ -184,51 +202,56 @@ sub initialize_instance_slot { my $init_arg = $self->init_arg(); # try to fetch the init arg from the %params ... - my $val; + my $val; if (exists $params->{$init_arg}) { $val = $params->{$init_arg}; - + if (!defined $val && $self->is_required) { - confess "Attribute (" . $self->name . ") is required and cannot be undef"; + confess "Attribute (" . $self->name . ") is required and cannot be undef"; } } else { # skip it if it's lazy return if $self->is_lazy; # and die if it's required and doesn't have a default value - confess "Attribute (" . $self->name . ") is required" - if $self->is_required && !$self->has_default; + confess "Attribute (" . $self->name . ") is required" + if $self->is_required && !$self->has_default && !$self->has_builder; } - # 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 && $self->has_default) { - $val = $self->default($instance); - } - - if (defined $val || $self->has_default) { - if ($self->has_type_constraint) { - my $type_constraint = $self->type_constraint; - if ($self->should_coerce && $type_constraint->has_coercion) { - $val = $type_constraint->coerce($val); - } - (defined($type_constraint->check($val))) - || confess "Attribute (" . - $self->name . - ") does not pass the type constraint (" . + $val = $self->default($instance); + } elsif (!defined $val && $self->has_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; + } + + if (defined $val || $self->has_default) { + if ($self->has_type_constraint) { + my $type_constraint = $self->type_constraint; + if ($self->should_coerce && $type_constraint->has_coercion) { + $val = $type_constraint->coerce($val); + } + (defined($type_constraint->check($val))) + || confess "Attribute (" . + $self->name . + ") does not pass the type constraint (" . $type_constraint->name . - ") with '" . - (defined $val - ? (blessed($val) && overload::Overloaded($val) - ? overload::StrVal($val) - : $val) - : 'undef') . - "'"; + ") with '" . + (defined $val + ? (blessed($val) && overload::Overloaded($val) + ? overload::StrVal($val) + : $val) + : 'undef') . + "'"; + } } - } $meta_instance->set_slot_value($instance, $self->name, $val); - $meta_instance->weaken_slot_value($instance, $self->name) + $meta_instance->weaken_slot_value($instance, $self->name) if ref $val && $self->is_weak_ref; } @@ -236,44 +259,44 @@ sub initialize_instance_slot { sub set_value { my ($self, $instance, $value) = @_; - + my $attr_name = $self->name; - + if ($self->is_required) { - defined($value) + defined($value) || confess "Attribute ($attr_name) is required, so cannot be set to undef"; } - + if ($self->has_type_constraint) { - + my $type_constraint = $self->type_constraint; - + if ($self->should_coerce) { - $value = $type_constraint->coerce($value); + $value = $type_constraint->coerce($value); } defined($type_constraint->_compiled_type_constraint->($value)) - || confess "Attribute ($attr_name) does not pass the type constraint (" - . $type_constraint->name - . ") with " - . (defined($value) - ? ("'" . - (blessed($value) && overload::Overloaded($value) - ? overload::StrVal($value) - : $value) - . "'") + || confess "Attribute ($attr_name) does not pass the type constraint (" + . $type_constraint->name + . ") with " + . (defined($value) + ? ("'" . + (blessed($value) && overload::Overloaded($value) + ? overload::StrVal($value) + : $value) + . "'") : "undef") if defined($value); } - + my $meta_instance = Class::MOP::Class->initialize(blessed($instance)) ->get_meta_instance; - - $meta_instance->set_slot_value($instance, $attr_name, $value); - + + $meta_instance->set_slot_value($instance, $attr_name, $value); + if (ref $value && $self->is_weak_ref) { - $meta_instance->weaken_slot_value($instance, $attr_name); + $meta_instance->weaken_slot_value($instance, $attr_name); } - + if ($self->has_trigger) { $self->trigger->($instance, $value, $self); } @@ -281,94 +304,99 @@ sub set_value { sub get_value { my ($self, $instance) = @_; - + if ($self->is_lazy) { - unless ($self->has_value($instance)) { - if ($self->has_default) { - my $default = $self->default($instance); - $self->set_value($instance, $default); - } - else { - $self->set_value($instance, undef); - } - } + unless ($self->has_value($instance)) { + if ($self->has_default) { + my $default = $self->default($instance); + $self->set_value($instance, $default); + } + if ( $self->has_builder ){ + my $builder = $self->builder; + confess(blessed($instance)." does not support builder method '$builder' for attribute '" . $self->name . "'") + unless $instance->can($builder); + $self->set_value($instance, $instance->$builder); + } else { + $self->set_value($instance, undef); + } + } } - + if ($self->should_auto_deref) { - + my $type_constraint = $self->type_constraint; if ($type_constraint->is_a_type_of('ArrayRef')) { my $rv = $self->SUPER::get_value($instance); return unless defined $rv; return wantarray ? @{ $rv } : $rv; - } + } elsif ($type_constraint->is_a_type_of('HashRef')) { my $rv = $self->SUPER::get_value($instance); return unless defined $rv; return wantarray ? %{ $rv } : $rv; - } + } else { confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'"; } - + } else { - + return $self->SUPER::get_value($instance); - } + } } -## installing accessors +## installing accessors sub accessor_metaclass { 'Moose::Meta::Method::Accessor' } sub install_accessors { my $self = shift; - $self->SUPER::install_accessors(@_); - + $self->SUPER::install_accessors(@_); + if ($self->has_handles) { - + # NOTE: # Here we canonicalize the 'handles' option - # this will sort out any details and always - # return an hash of methods which we want + # this will sort out any details and always + # return an hash of methods which we want # to delagate to, see that method for details my %handles = $self->_canonicalize_handles(); - + # find the name of the accessor for this attribute my $accessor_name = $self->reader || $self->accessor; (defined $accessor_name) || confess "You cannot install delegation without a reader or accessor for the attribute"; - + # make sure we handle HASH accessors correctly ($accessor_name) = keys %{$accessor_name} if ref($accessor_name) eq 'HASH'; - + # install the delegation ... my $associated_class = $self->associated_class; foreach my $handle (keys %handles) { my $method_to_call = $handles{$handle}; - + (!$associated_class->has_method($handle)) || confess "You cannot overwrite a locally defined method ($handle) with a delegation"; - + # NOTE: # handles is not allowed to delegate - # any of these methods, as they will - # override the ones in your class, which + # any of these methods, as they will + # override the ones in your class, which # is almost certainly not what you want. next if $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle); - + if ((reftype($method_to_call) || '') eq 'CODE') { - $associated_class->add_method($handle => $method_to_call); + $associated_class->add_method($handle => $method_to_call); } else { $associated_class->add_method($handle => sub { # FIXME - # we should check for lack of - # a callable return value from - # the accessor here + # we should check for lack of + # a callable return value from + # the accessor here my $proxy = (shift)->$accessor_name(); @_ = ($proxy, @_); goto &{ $proxy->can($method_to_call)}; @@ -376,7 +404,7 @@ sub install_accessors { } } } - + return; } @@ -395,7 +423,7 @@ sub _canonicalize_handles { elsif ($handle_type eq 'Regexp') { ($self->has_type_constraint) || confess "Cannot delegate methods based on a RegExpr without a type constraint (isa)"; - return map { ($_ => $_) } + return map { ($_ => $_) } grep { /$handles/ } $self->_get_delegate_method_list; } elsif ($handle_type eq 'CODE') { @@ -408,14 +436,14 @@ sub _canonicalize_handles { else { my $role_meta = eval { $handles->meta }; if ($@) { - confess "Unable to canonicalize the 'handles' option with $handles because : $@"; + confess "Unable to canonicalize the 'handles' option with $handles because : $@"; } (blessed $role_meta && $role_meta->isa('Moose::Meta::Role')) || confess "Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role"; - + return map { $_ => $_ } ( - $role_meta->get_method_list, + $role_meta->get_method_list, $role_meta->get_required_method_list ); } @@ -424,17 +452,17 @@ sub _canonicalize_handles { sub _find_delegate_metaclass { my $self = shift; if (my $class = $self->_isa_metadata) { - # if the class does have + # if the class does have # a meta method, use it return $class->meta if $class->can('meta'); - # otherwise we might be + # otherwise we might be # dealing with a non-Moose - # class, and need to make + # class, and need to make # our own metaclass return Moose::Meta::Class->initialize($class); } elsif (my $role = $self->_does_metadata) { - # our role will always have + # our role will always have # a meta method return $role->meta; } @@ -448,11 +476,11 @@ sub _get_delegate_method_list { my $meta = $self->_find_delegate_metaclass; if ($meta->isa('Class::MOP::Class')) { return map { $_->{name} } # NOTE: !never! delegate &meta - grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' } + grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' } $meta->compute_all_applicable_methods; } elsif ($meta->isa('Moose::Meta::Role')) { - return $meta->get_method_list; + return $meta->get_method_list; } else { confess "Unable to recognize the delegate metaclass '$meta'"; @@ -471,20 +499,20 @@ Moose::Meta::Attribute - The Moose attribute metaclass =head1 DESCRIPTION -This is a subclass of L with Moose specific -extensions. +This is a subclass of L with Moose specific +extensions. -For the most part, the only time you will ever encounter an -instance of this class is if you are doing some serious deep -introspection. To really understand this class, you need to refer +For the most part, the only time you will ever encounter an +instance of this class is if you are doing some serious deep +introspection. To really understand this class, you need to refer to the L documentation. =head1 METHODS =head2 Overridden methods -These methods override methods in L and add -Moose specific features. You can safely assume though that they +These methods override methods in L and add +Moose specific features. You can safely assume though that they will behave just as L does. =over 4 @@ -524,15 +552,15 @@ for an example. =head2 Additional Moose features -Moose attributes support type-constraint checking, weak reference -creation and type coercion. +Moose attributes support type-constraint checking, weak reference +creation and type coercion. =over 4 =item B -This is to support the C feature, it clones an attribute -from a superclass and allows a very specific set of changes to be made +This is to support the C feature, it clones an attribute +from a superclass and allows a very specific set of changes to be made to the attribute. =item B @@ -541,8 +569,8 @@ Returns true if this meta-attribute has a type constraint. =item B -A read-only accessor for this meta-attribute's type constraint. For -more information on what you can do with this, see the documentation +A read-only accessor for this meta-attribute's type constraint. For +more information on what you can do with this, see the documentation for L. =item B @@ -565,7 +593,29 @@ Returns true if this meta-attribute is required to have a value. Returns true if this meta-attribute should be initialized lazily. -NOTE: lazy attributes, B have a C field set. +NOTE: lazy attributes, B have a C or C field set. + +=item B + +Returns true if this meta-attribute should be initialized lazily through +the builder generated by lazy_build. Using C 1> will +make your attribute required and lazy. In addition it will set the builder, clearer +and predicate options for you using the following convention. + + #If your attribute name starts with an underscore: + has '_foo' => (lazy_build => 1); + #is the same as + has '_foo' => (lazy => 1, required => 1, builder => '_build_foo', predicate => '_has_foo', clearer => '_clear_foo'); + # or + has '_foo' => (lazy => 1, required => 1, builder => '_build_foo', default => sub{shift->_build_foo}, clearer => '_clear_foo'); + + #If your attribute name does not start with an underscore: + has 'foo' => (lazy => 1, required => 1, builder => 'build_foo', predicate => 'has_foo', clearer => 'clear_foo'); + # or + has '_foo' => (lazy => 1, required => 1, builder => '_build_foo', default => sub{shift->build_foo}, clearer => '_clear_foo'); + +NOTE: This means your class should provide a method whose name matches the value +of the builder part, in this case _build_foo or build_foo. =item B @@ -573,10 +623,10 @@ Returns true if this meta-attribute should perform type coercion. =item B -Returns true if this meta-attribute should perform automatic -auto-dereferencing. +Returns true if this meta-attribute should perform automatic +auto-dereferencing. -NOTE: This can only be done for attributes whose type constraint is +NOTE: This can only be done for attributes whose type constraint is either I or I. =item B @@ -585,14 +635,14 @@ Returns true if this meta-attribute has a trigger set. =item B -This is a CODE reference which will be executed every time the -value of an attribute is assigned. The CODE ref will get two values, -the invocant and the new value. This can be used to handle I +This is a CODE reference which will be executed every time the +value of an attribute is assigned. The CODE ref will get two values, +the invocant and the new value. This can be used to handle I bi-directional relations. =item B -This is a string which contains the documentation for this attribute. +This is a string which contains the documentation for this attribute. It serves no direct purpose right now, but it might in the future in some kind of automated documentation system perhaps. @@ -604,7 +654,7 @@ Returns true if this meta-attribute has any documentation. =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. @@ -621,6 +671,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/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm index a6547de..d5e67e3 100644 --- a/lib/Moose/Meta/Method/Accessor.pm +++ b/lib/Moose/Meta/Method/Accessor.pm @@ -6,7 +6,7 @@ use warnings; use Carp 'confess'; -our $VERSION = '0.05'; +our $VERSION = '0.06'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::Method', @@ -16,7 +16,7 @@ use base 'Moose::Meta::Method', sub generate_accessor_method_inline { my $self = $_[0]; - my $attr = $self->associated_attribute; + my $attr = $self->associated_attribute; my $attr_name = $attr->name; my $inv = '$_[0]'; my $slot_access = $self->_inline_get($inv, $attr_name); @@ -28,28 +28,28 @@ sub generate_accessor_method_inline { . $self->_inline_check_required . $self->_inline_check_coercion . $self->_inline_check_constraint($value_name) - . $self->_inline_store($inv, $value_name) - . $self->_inline_trigger($inv, $value_name) + . $self->_inline_store($inv, $value_name) + . $self->_inline_trigger($inv, $value_name) . ' }' . $self->_inline_check_lazy . $self->_inline_post_body(@_) . 'return ' . $self->_inline_auto_deref($self->_inline_get($inv)) . ' }'; - + # NOTE: # set up the environment - my $type_constraint = $attr->type_constraint + my $type_constraint = $attr->type_constraint ? $attr->type_constraint->_compiled_type_constraint : undef; - + my $sub = eval $code; confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@; - return $sub; + return $sub; } sub generate_writer_method_inline { my $self = $_[0]; - my $attr = $self->associated_attribute; + my $attr = $self->associated_attribute; my $attr_name = $attr->name; my $inv = '$_[0]'; my $slot_access = $self->_inline_get($inv, $attr_name); @@ -59,30 +59,30 @@ sub generate_writer_method_inline { . $self->_inline_pre_body(@_) . $self->_inline_check_required . $self->_inline_check_coercion - . $self->_inline_check_constraint($value_name) - . $self->_inline_store($inv, $value_name) - . $self->_inline_post_body(@_) - . $self->_inline_trigger($inv, $value_name) + . $self->_inline_check_constraint($value_name) + . $self->_inline_store($inv, $value_name) + . $self->_inline_post_body(@_) + . $self->_inline_trigger($inv, $value_name) . ' }'; - + # NOTE: # set up the environment - my $type_constraint = $attr->type_constraint + my $type_constraint = $attr->type_constraint ? $attr->type_constraint->_compiled_type_constraint - : undef; - + : undef; + my $sub = eval $code; confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@; - return $sub; + return $sub; } sub generate_reader_method_inline { my $self = $_[0]; - my $attr = $self->associated_attribute; + my $attr = $self->associated_attribute; my $attr_name = $attr->name; my $inv = '$_[0]'; my $slot_access = $self->_inline_get($inv, $attr_name); - + my $code = 'sub {' . $self->_inline_pre_body(@_) . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;' @@ -90,13 +90,13 @@ sub generate_reader_method_inline { . $self->_inline_post_body(@_) . 'return ' . $self->_inline_auto_deref( $slot_access ) . ';' . '}'; - + # NOTE: # set up the environment - my $type_constraint = $attr->type_constraint + my $type_constraint = $attr->type_constraint ? $attr->type_constraint->_compiled_type_constraint - : undef; - + : undef; + my $sub = eval $code; confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@; return $sub; @@ -110,106 +110,117 @@ sub _inline_pre_body { '' } sub _inline_post_body { '' } sub _inline_check_constraint { - my ($self, $value) = @_; - - my $attr = $self->associated_attribute; - - return '' unless $attr->has_type_constraint; - - # FIXME - # This sprintf is insanely annoying, we should - # fix it someday - SL - return sprintf <<'EOF', $value, $value, $value, $value, $value, $value, $value + my ($self, $value) = @_; + + my $attr = $self->associated_attribute; + + return '' unless $attr->has_type_constraint; + + # FIXME + # This sprintf is insanely annoying, we should + # fix it someday - SL + return sprintf <<'EOF', $value, $value, $value, $value, $value, $value, $value defined($type_constraint->(%s)) - || confess "Attribute (" . $attr->name . ") does not pass the type constraint (" - . $attr->type_constraint->name . ") with " + || confess "Attribute (" . $attr->name . ") does not pass the type constraint (" + . $attr->type_constraint->name . ") with " . (defined(%s) ? (Scalar::Util::blessed(%s) && overload::Overloaded(%s) ? overload::StrVal(%s) : %s) : "undef") if defined(%s); EOF } sub _inline_check_coercion { - my $attr = (shift)->associated_attribute; - - return '' unless $attr->should_coerce; + my $attr = (shift)->associated_attribute; + + return '' unless $attr->should_coerce; return 'my $val = $attr->type_constraint->coerce($_[1]);' } sub _inline_check_required { - my $attr = (shift)->associated_attribute; - - return '' unless $attr->is_required; + my $attr = (shift)->associated_attribute; + + return '' unless $attr->is_required; return 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";' } sub _inline_check_lazy { my $self = $_[0]; - my $attr = $self->associated_attribute; - - return '' unless $attr->is_lazy; - + my $attr = $self->associated_attribute; + + return '' unless $attr->is_lazy; + my $inv = '$_[0]'; - my $slot_access = $self->_inline_get($inv, $attr->name); - - if ($attr->has_type_constraint) { - # NOTE: - # this could probably be cleaned - # up and streamlined a little more - return 'unless (exists ' . $slot_access . ') {' . - ' if ($attr->has_default) {' . - ' my $default = $attr->default(' . $inv . ');' . - ($attr->should_coerce - ? '$default = $attr->type_constraint->coerce($default);' - : '') . + my $slot_access = $self->_inline_get($inv, $attr->name); + + if ($attr->has_type_constraint) { + # NOTE: + # this could probably be cleaned + # up and streamlined a little more + return 'unless (exists ' . $slot_access . ') {' . + ' if ($attr->has_default || $attr->has_builder ) {' . + ' my $default; '. + ' $default = $attr->default(' . $inv . ') if $attr->has_default;' . + ' if ( $attr->has_builder ) { '. + ' my $builder = $self->builder;'. + ' confess(blessed('.$inv.')." does not support builder method \'$builder\' for attribute \'" . $attr->name . "\'")'. + ' unless '.$inv.'->can($builder); '. + ' $default = '.$inv.'->$builder;'. + ' }'. + ($attr->should_coerce + ? '$default = $attr->type_constraint->coerce($default);' + : '') . ' (defined($type_constraint->($default)))' . - ' || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("' . - ' . $attr->type_constraint->name . ") with " . (defined($default) ? (Scalar::Util::blessed($default) && overload::Overloaded($default) ? overload::StrVal($default) : $default) : "undef")' . - ' if defined($default);' . - ' ' . $slot_access . ' = $default; ' . - ' }' . - ' else {' . + ' || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("' . + ' . $attr->type_constraint->name . ") with " . (defined($default) ? (Scalar::Util::blessed($default) && overload::Overloaded($default) ? overload::StrVal($default) : $default) : "undef")' . + ' if defined($default);' . + ' ' . $slot_access . ' = $default; ' . + ' }' . + ' else {' . ' ' . $slot_access . ' = undef;' . - ' }' . - '}'; - } - return $slot_access . ' = ($attr->has_default ? $attr->default(' . $inv . ') : undef)' - . 'unless exists ' . $slot_access . ';'; + ' }' . + '}'; + } + + return 'unless (exists ' . $slot_access . ') {' . + ' if ($attr->has_default) { ' . $slot_access . ' = $attr->default(' . $inv . '); }' . + ' elsif ($attr->has_builder) { my $builder = $attr->builder; ' . $slot_access . ' = ' . $inv . '->$builder; }' . + ' else { ' .$slot_access . ' = undef; } '. + '}'; } sub _inline_store { - my ($self, $instance, $value) = @_; - my $attr = $self->associated_attribute; + my ($self, $instance, $value) = @_; + my $attr = $self->associated_attribute; - my $mi = $attr->associated_class->get_meta_instance; - my $slot_name = sprintf "'%s'", $attr->slots; + my $mi = $attr->associated_class->get_meta_instance; + my $slot_name = sprintf "'%s'", $attr->slots; my $code = $mi->inline_set_slot_value($instance, $slot_name, $value) . ";"; - $code .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";" - if $attr->is_weak_ref; + $code .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";" + if $attr->is_weak_ref; return $code; } sub _inline_trigger { - my ($self, $instance, $value) = @_; - my $attr = $self->associated_attribute; - return '' unless $attr->has_trigger; - return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value); + my ($self, $instance, $value) = @_; + my $attr = $self->associated_attribute; + return '' unless $attr->has_trigger; + return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value); } sub _inline_get { - my ($self, $instance) = @_; - my $attr = $self->associated_attribute; + my ($self, $instance) = @_; + my $attr = $self->associated_attribute; - my $mi = $attr->associated_class->get_meta_instance; - my $slot_name = sprintf "'%s'", $attr->slots; + my $mi = $attr->associated_class->get_meta_instance; + my $slot_name = sprintf "'%s'", $attr->slots; return $mi->inline_get_slot_value($instance, $slot_name); } sub _inline_auto_deref { my ( $self, $ref_value ) = @_; - my $attr = $self->associated_attribute; + my $attr = $self->associated_attribute; return $ref_value unless $attr->should_auto_deref; @@ -218,10 +229,10 @@ sub _inline_auto_deref { my $sigil; if ($type_constraint->is_a_type_of('ArrayRef')) { $sigil = '@'; - } + } elsif ($type_constraint->is_a_type_of('HashRef')) { $sigil = '%'; - } + } else { confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'"; } @@ -241,10 +252,10 @@ Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors =head1 DESCRIPTION -This is a subclass of L and it's primary -responsibility is to generate the accessor methods for attributes. It +This is a subclass of L and it's primary +responsibility is to generate the accessor methods for attributes. It can handle both closure based accessors, as well as inlined source based -accessors. +accessors. This is a fairly new addition to the MOP, but this will play an important role in the optimization strategy we are currently following. @@ -269,7 +280,7 @@ role in the optimization strategy we are currently following. =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. diff --git a/t/020_attributes/012_misc_attribute_tests.t b/t/020_attributes/012_misc_attribute_tests.t index b123e0f..ead2979 100644 --- a/t/020_attributes/012_misc_attribute_tests.t +++ b/t/020_attributes/012_misc_attribute_tests.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 14; +use Test::More tests => 40; use Test::Exception; BEGIN { @@ -142,5 +142,74 @@ BEGIN { } +{ + { + package Test::Builder::Attribute; + use Moose; + + has 'foo' => ( required => 1, builder => 'build_foo', is => 'ro'); + sub build_foo { return "works" }; + } + + my $meta = Test::Builder::Attribute->meta; + my $foo_attr = $meta->get_attribute("foo"); + + ok($foo_attr->is_required, "foo is required"); + ok($foo_attr->has_builder, "foo has builder"); + is($foo_attr->builder, "build_foo", ".. and it's named build_foo"); + + my $instance = Test::Builder::Attribute->new; + is($instance->foo, 'works', "foo builder works"); +} + + + +{ + { + package Test::LazyBuild::Attribute; + use Moose; + + has 'foo' => ( lazy_build => 1, is => 'ro'); + has '_foo' => ( lazy_build => 1, is => 'ro'); + sub build_foo { return "works" }; + sub _build_foo { return "works too" }; + } + + my $meta = Test::LazyBuild::Attribute->meta; + my $foo_attr = $meta->get_attribute("foo"); + my $_foo_attr = $meta->get_attribute("_foo"); + + ok($foo_attr->is_lazy, "foo is lazy"); + ok($foo_attr->is_required, "foo is required"); + ok($foo_attr->is_lazy_build, "foo is lazy_build"); + + ok($foo_attr->has_clearer, "foo has clearer"); + is($foo_attr->clearer, "clear_foo", ".. and it's named clear_foo"); + + ok($foo_attr->has_builder, "foo has builder"); + is($foo_attr->builder, "build_foo", ".. and it's named build_foo"); + ok($foo_attr->has_predicate, "foo has predicate"); + is($foo_attr->predicate, "has_foo", ".. and it's named has_foo"); + + ok($_foo_attr->is_lazy, "_foo is lazy"); + ok($_foo_attr->is_required, "_foo is required"); + ok($_foo_attr->is_lazy_build, "_foo is lazy_build"); + + ok($_foo_attr->has_clearer, "_foo has clearer"); + is($_foo_attr->clearer, "_clear_foo", ".. and it's named _clear_foo"); + + ok($_foo_attr->has_builder, "_foo has builder"); + is($_foo_attr->builder, "_build_foo", ".. and it's named _build_foo"); + + ok($_foo_attr->has_predicate, "_foo has predicate"); + is($_foo_attr->predicate, "_has_foo", ".. and it's named _has_foo"); + + my $instance = Test::LazyBuild::Attribute->new; + ok(!$instance->has_foo, "noo foo value yet"); + ok(!$instance->_has_foo, "noo _foo value yet"); + is($instance->foo, 'works', "foo builder works"); + is($instance->_foo, 'works too', "foo builder works too"); + +}