use warnings;
use Carp 'confess';
-use Scalar::Util 'blessed';
-
-use Class::MOP::Class;
-use Class::MOP::Method;
+use Scalar::Util 'blessed', 'reftype';
our $VERSION = '0.01';
-sub meta { Class::MOP::Class->initialize($_[0]) }
+sub meta {
+ require Class::MOP::Class;
+ Class::MOP::Class->initialize($_[0])
+}
+# NOTE: (meta-circularity)
+# This method will be replaces 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.
+# - Ain't meta-circularity grand? :)
sub new {
my $class = shift;
my $name = shift;
my %options = @_;
- (defined $name && $name ne '')
+ (defined $name && $name)
|| confess "You must provide a name for the attribute";
(!exists $options{reader} && !exists $options{writer})
|| confess "You cannot declare an accessor and reader and/or writer functions"
if exists $options{accessor};
bless {
- name => $name,
- accessor => $options{accessor},
- reader => $options{reader},
- writer => $options{writer},
- init_arg => $options{init_arg},
- default => $options{default}
+ name => $name,
+ accessor => $options{accessor},
+ reader => $options{reader},
+ writer => $options{writer},
+ predicate => $options{predicate},
+ init_arg => $options{init_arg},
+ default => $options{default}
} => $class;
}
-sub name { (shift)->{name} }
-
-sub has_accessor { (shift)->{accessor} ? 1 : 0 }
-sub accessor { (shift)->{accessor} }
-
-sub has_reader { (shift)->{reader} ? 1 : 0 }
-sub reader { (shift)->{reader} }
-
-sub has_writer { (shift)->{writer} ? 1 : 0 }
-sub writer { (shift)->{writer} }
-
-sub has_init_arg { (shift)->{init_arg} ? 1 : 0 }
-sub init_arg { (shift)->{init_arg} }
-
-sub has_default { (shift)->{default} ? 1 : 0 }
-sub default { (shift)->{default} }
+sub name { $_[0]->{name} }
+
+sub has_accessor { defined($_[0]->{accessor}) ? 1 : 0 }
+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_init_arg { defined($_[0]->{init_arg}) ? 1 : 0 }
+sub has_default { defined($_[0]->{default}) ? 1 : 0 }
+
+sub accessor { $_[0]->{accessor} }
+sub reader { $_[0]->{reader} }
+sub writer { $_[0]->{writer} }
+sub predicate { $_[0]->{predicate} }
+sub init_arg { $_[0]->{init_arg} }
+
+sub default {
+ my $self = shift;
+ if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') {
+ # if the default is a CODE ref, then
+ # we pass in the instance and default
+ # can return a value based on that
+ # instance. Somewhat crude, but works.
+ return $self->{default}->(shift);
+ }
+ $self->{default};
+}
-sub install_accessors {
- my ($self, $class) = @_;
- (blessed($class) && $class->isa('Class::MOP::Class'))
- || confess "You must pass a Class::MOP::Class instance (or a subclass)";
-
- if ($self->has_accessor()) {
- $class->add_method($self->accessor() => Class::MOP::Attribute::Accessor->wrap(sub {
- $_[0]->{$self->name} = $_[1] if scalar(@_) == 2;
- $_[0]->{$self->name};
- }));
- }
- else {
- if ($self->has_reader()) {
- $class->add_method($self->reader() => Class::MOP::Attribute::Accessor->wrap(sub {
- $_[0]->{$self->name};
- }));
- }
- if ($self->has_writer()) {
- $class->add_method($self->writer() => Class::MOP::Attribute::Accessor->wrap(sub {
- $_[0]->{$self->name} = $_[1];
+{
+ # this is just a utility routine to
+ # handle the details of accessors
+ my $_inspect_accessor = sub {
+ my ($attr_name, $type, $accessor) = @_;
+
+ my %ACCESSOR_TEMPLATES = (
+ 'accessor' => qq{sub {
+ \$_[0]->{'$attr_name'} = \$_[1] if scalar(\@_) == 2;
+ \$_[0]->{'$attr_name'};
+ }},
+ 'reader' => qq{sub {
+ \$_[0]->{'$attr_name'};
+ }},
+ 'writer' => qq{sub {
+ \$_[0]->{'$attr_name'} = \$_[1];
return;
- }));
+ }},
+ 'predicate' => qq{sub {
+ return defined \$_[0]->{'$attr_name'} ? 1 : 0;
+ }}
+ );
+
+ if (reftype($accessor) && reftype($accessor) eq 'HASH') {
+ my ($name, $method) = each %{$accessor};
+ return ($name, Class::MOP::Attribute::Accessor->wrap($method));
}
+ else {
+ my $method = eval $ACCESSOR_TEMPLATES{$type};
+ confess "Could not create the $type for $attr_name CODE(\n" . $ACCESSOR_TEMPLATES{$type} . "\n) : $@" if $@;
+ return ($accessor => Class::MOP::Attribute::Accessor->wrap($method));
+ }
+ };
+
+ sub install_accessors {
+ my ($self, $class) = @_;
+ (blessed($class) && $class->isa('Class::MOP::Class'))
+ || confess "You must pass a Class::MOP::Class instance (or a subclass)";
+ $class->add_method(
+ $_inspect_accessor->($self->name, 'accessor' => $self->accessor())
+ ) if $self->has_accessor();
+
+ $class->add_method(
+ $_inspect_accessor->($self->name, 'reader' => $self->reader())
+ ) if $self->has_reader();
+
+ $class->add_method(
+ $_inspect_accessor->($self->name, 'writer' => $self->writer())
+ ) if $self->has_writer();
+
+ $class->add_method(
+ $_inspect_accessor->($self->name, 'predicate' => $self->predicate())
+ ) if $self->has_predicate();
+ return;
}
+
}
-sub remove_accessors {
- my ($self, $class) = @_;
- (blessed($class) && $class->isa('Class::MOP::Class'))
- || confess "You must pass a Class::MOP::Class instance (or a subclass)";
-
- if ($self->has_accessor()) {
- my $method = $class->get_method($self->accessor);
- $class->remove_method($self->accessor)
+{
+ my $_remove_accessor = sub {
+ my ($accessor, $class) = @_;
+ if (reftype($accessor) && reftype($accessor) eq 'HASH') {
+ ($accessor) = keys %{$accessor};
+ }
+ my $method = $class->get_method($accessor);
+ $class->remove_method($accessor)
if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
+ };
+
+ sub remove_accessors {
+ my ($self, $class) = @_;
+ (blessed($class) && $class->isa('Class::MOP::Class'))
+ || confess "You must pass a Class::MOP::Class instance (or a subclass)";
+ $_remove_accessor->($self->accessor(), $class) if $self->has_accessor();
+ $_remove_accessor->($self->reader(), $class) if $self->has_reader();
+ $_remove_accessor->($self->writer(), $class) if $self->has_writer();
+ $_remove_accessor->($self->predicate(), $class) if $self->has_predicate();
+ return;
}
- else {
- if ($self->has_reader()) {
- my $method = $class->get_method($self->reader);
- $class->remove_method($self->reader)
- if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
- }
- if ($self->has_writer()) {
- my $method = $class->get_method($self->writer);
- $class->remove_method($self->writer)
- if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
- }
- }
+
}
package Class::MOP::Attribute::Accessor;
use strict;
use warnings;
+use Class::MOP::Method;
+
our $VERSION = '0.01';
our @ISA = ('Class::MOP::Method');
=item B<writer>
+=item B<predicate>
+
=item B<init_arg>
=item B<default>
Returns true if this attribute has a writer, and false otherwise
+=item B<has_predicate>
+
+Returns true if this attribute has a predicate, and false otherwise
+
=item B<has_init_arg>
Returns true if this attribute has a class intialization argument, and
projects / gitmo/Class-MOP.git / blobdiff