From: Scott McWhirter Date: Fri, 26 Jun 2009 04:21:59 +0000 (+0100) Subject: Add split out Predicate method X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3a3cad303679bbf62b0a2371daf6a3000dcf9577;p=gitmo%2FClass-MOP.git Add split out Predicate method --- diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 0db5eb6..6e09afd 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -7,6 +7,7 @@ use warnings; use Class::MOP::Method::Accessor; use Class::MOP::Method::Reader; use Class::MOP::Method::Writer; +use Class::MOP::Method::Predicate; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; @@ -382,6 +383,7 @@ sub method_metaclasses { { reader => 'Class::MOP::Method::Reader', writer => 'Class::MOP::Method::Writer', + predicate => 'Class::MOP::Method::Predicate', } } diff --git a/lib/Class/MOP/Method/Predicate.pm b/lib/Class/MOP/Method/Predicate.pm new file mode 100644 index 0000000..74b1626 --- /dev/null +++ b/lib/Class/MOP/Method/Predicate.pm @@ -0,0 +1,170 @@ + +package Class::MOP::Method::Predicate; + +use strict; +use warnings; + +use Carp 'confess'; +use Scalar::Util 'blessed', 'weaken'; + +our $VERSION = '0.88'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Class::MOP::Method::Attribute'; + +sub _initialize_body { + my $self = shift; + + my $method_name = join "_" => ( + '_generate', + 'method', + ($self->is_inline ? 'inline' : ()) + ); + + $self->{'body'} = $self->$method_name(); +} + +## generators + +sub generate_method { + Carp::cluck('The generate_predicate_method method has been made private.' + . " The public version is deprecated and will be removed in a future release.\n"); + shift->_generate_method; +} + +sub _generate_method { + my $attr = (shift)->associated_attribute; + return sub { + $attr->has_value($_[0]) + }; +} + +## Inline methods + +sub generate_method_inline { + Carp::cluck('The generate_predicate_method_inline method has been made private.' + . " The public version is deprecated and will be removed in a future release.\n"); + shift->_generate_predicate_method_inline; +} + +sub _generate_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + my $attr_name = $attr->name; + my $meta_instance = $attr->associated_class->instance_metaclass; + + my ( $code, $e ) = $self->_eval_closure( + {}, + 'sub {' + . $meta_instance->inline_is_slot_initialized('$_[0]', $attr_name) + . '}' + ); + confess "Could not generate inline predicate because : $e" if $e; + + return $code; +} + +1; + +# XXX - UPDATE DOCS +__END__ + +=pod + +=head1 NAME + +Class::MOP::Method::Predicate - Method Meta Object for accessors + +=head1 SYNOPSIS + + use Class::MOP::Method::Accessor; + + my $reader = Class::MOP::Method::Accessor->new( + attribute => $attribute, + is_inline => 1, + accessor_type => 'reader', + ); + + $reader->body->execute($instance); # call the reader method + +=head1 DESCRIPTION + +This is a subclass of which is used by +C to generate accessor code. It handles +generation of readers, writers, predicates and clearers. For each type +of method, it can either create a subroutine reference, or actually +inline code by generating a string and C'ing it. + +=head1 METHODS + +=over 4 + +=item B<< Class::MOP::Method::Accessor->new(%options) >> + +This returns a new C based on the +C<%options> provided. + +=over 4 + +=item * attribute + +This is the C for which accessors are being +generated. This option is required. + +=item * accessor_type + +This is a string which should be one of "reader", "writer", +"accessor", "predicate", or "clearer". This is the type of method +being generated. This option is required. + +=item * is_inline + +This indicates whether or not the accessor should be inlined. This +defaults to false. + +=item * name + +The method name (without a package name). This is required. + +=item * package_name + +The package name for the method. This is required. + +=back + +=item B<< $metamethod->accessor_type >> + +Returns the accessor type which was passed to C. + +=item B<< $metamethod->is_inline >> + +Returns a boolean indicating whether or not the accessor is inlined. + +=item B<< $metamethod->associated_attribute >> + +This returns the L object which was passed to +C. + +=item B<< $metamethod->body >> + +The method itself is I when the accessor object is +constructed. + +=back + +=head1 AUTHORS + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2009 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. + +=cut +