use strict;
use warnings;
-use Carp 'confess';
+use Carp 'confess';
+use Scalar::Util 'blessed', 'reftype';
our $VERSION = '0.01';
+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 name { $_[0]->{name} }
-sub has_accessor { (shift)->{accessor} ? 1 : 0 }
-sub accessor { (shift)->{accessor} }
+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 has_reader { (shift)->{reader} ? 1 : 0 }
-sub reader { (shift)->{reader} }
+sub accessor { $_[0]->{accessor} }
+sub reader { $_[0]->{reader} }
+sub writer { $_[0]->{writer} }
+sub predicate { $_[0]->{predicate} }
+sub init_arg { $_[0]->{init_arg} }
-sub has_writer { (shift)->{writer} ? 1 : 0 }
-sub writer { (shift)->{writer} }
+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 has_init_arg { (shift)->{init_arg} ? 1 : 0 }
-sub init_arg { (shift)->{init_arg} }
+{
+ # 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 has_default { (shift)->{default} ? 1 : 0 }
-sub default { (shift)->{default} }
+{
+ 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;
+ }
-sub generate_accessor {
- my $self = shift;
- # ...
}
+package Class::MOP::Attribute::Accessor;
+
+use strict;
+use warnings;
+
+use Class::MOP::Method;
+
+our $VERSION = '0.01';
+
+our @ISA = ('Class::MOP::Method');
+
1;
__END__
=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
=over 4
-=item B<generate_accessor>
+=item B<install_accessors ($class)>
+
+This allows the attribute to generate and install code for it's own
+accessor methods. This is called by C<Class::MOP::Class::add_attribute>.
+
+=item B<remove_accessors ($class)>
+
+This allows the attribute to remove the method for it's own
+accessor. This is called by C<Class::MOP::Class::remove_attribute>.
+
+=back
+
+=head2 Introspection
+
+=over 4
-This allows the attribute to generate code for it's own accessor
-methods. This is mostly part of an internal protocol between the class
-and it's own attributes, see the C<create_all_accessors> method above.
+=item B<meta>
=back
projects / gitmo/Class-MOP.git / blobdiff