use strict;
use warnings;
-our $VERSION = '0.01';
+use Scalar::Util 'weaken', 'reftype';
+use Carp 'confess';
+
+our $VERSION = '0.02';
use base 'Class::MOP::Attribute';
-Moose::Meta::Attribute->meta->add_around_method_modifier('new' => sub {
- my $cont = shift;
- my ($class, $attribute_name, %options) = @_;
-
- # extract the init_arg
- my ($init_arg) = ($attribute_name =~ /^[\$\@\%][\.\:](.*)$/);
-
- $cont->($class, $attribute_name, (init_arg => $init_arg, %options));
+__PACKAGE__->meta->add_attribute('coerce' => (reader => 'coerce'));
+__PACKAGE__->meta->add_attribute('weak_ref' => (reader => 'weak_ref'));
+__PACKAGE__->meta->add_attribute('type_constraint' => (
+ reader => 'type_constraint',
+ predicate => 'has_type_constraint',
+));
+
+sub has_coercion { (shift)->coerce() ? 1 : 0 }
+sub has_weak_ref { (shift)->weak_ref() ? 1 : 0 }
+
+__PACKAGE__->meta->add_before_method_modifier('new' => sub {
+ my (undef, undef, %options) = @_;
+ 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};
+ }
});
+sub generate_accessor_method {
+ my ($self, $attr_name) = @_;
+ if ($self->has_type_constraint) {
+ if ($self->has_weak_ref) {
+ return sub {
+ if (scalar(@_) == 2) {
+ (defined $self->type_constraint->check($_[1]))
+ || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
+ if defined $_[1];
+ $_[0]->{$attr_name} = $_[1];
+ weaken($_[0]->{$attr_name});
+ }
+ $_[0]->{$attr_name};
+ };
+ }
+ else {
+ if ($self->has_coercion) {
+ return sub {
+ if (scalar(@_) == 2) {
+ my $val = $self->type_constraint->coercion->coerce($_[1]);
+ (defined $self->type_constraint->check($val))
+ || confess "Attribute ($attr_name) does not pass the type contraint with '$val'"
+ if defined $val;
+ $_[0]->{$attr_name} = $val;
+ }
+ $_[0]->{$attr_name};
+ };
+ }
+ else {
+ return sub {
+ if (scalar(@_) == 2) {
+ (defined $self->type_constraint->check($_[1]))
+ || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
+ if defined $_[1];
+ $_[0]->{$attr_name} = $_[1];
+ }
+ $_[0]->{$attr_name};
+ };
+ }
+ }
+ }
+ else {
+ if ($self->has_weak_ref) {
+ return sub {
+ if (scalar(@_) == 2) {
+ $_[0]->{$attr_name} = $_[1];
+ weaken($_[0]->{$attr_name});
+ }
+ $_[0]->{$attr_name};
+ };
+ }
+ else {
+ sub {
+ $_[0]->{$attr_name} = $_[1] if scalar(@_) == 2;
+ $_[0]->{$attr_name};
+ };
+ }
+ }
+}
+
+sub generate_writer_method {
+ my ($self, $attr_name) = @_;
+ if ($self->has_type_constraint) {
+ if ($self->has_weak_ref) {
+ return sub {
+ (defined $self->type_constraint->check($_[1]))
+ || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
+ if defined $_[1];
+ $_[0]->{$attr_name} = $_[1];
+ weaken($_[0]->{$attr_name});
+ };
+ }
+ else {
+ if ($self->has_coercion) {
+ return sub {
+ my $val = $self->type_constraint->coercion->coerce($_[1]);
+ (defined $self->type_constraint->check($val))
+ || confess "Attribute ($attr_name) does not pass the type contraint with '$val'"
+ if defined $val;
+ $_[0]->{$attr_name} = $val;
+ };
+ }
+ else {
+ return sub {
+ (defined $self->type_constraint->check($_[1]))
+ || confess "Attribute ($attr_name) does not pass the type contraint with '$_[1]'"
+ if defined $_[1];
+ $_[0]->{$attr_name} = $_[1];
+ };
+ }
+ }
+ }
+ else {
+ if ($self->has_weak_ref) {
+ return sub {
+ $_[0]->{$attr_name} = $_[1];
+ weaken($_[0]->{$attr_name});
+ };
+ }
+ else {
+ return sub { $_[0]->{$attr_name} = $_[1] };
+ }
+ }
+}
1;
=head1 NAME
-Moose::Meta::Attribute -
+Moose::Meta::Attribute - The Moose attribute metaobject
=head1 SYNOPSIS
=head1 DESCRIPTION
+This is a subclass of L<Class::MOP::Attribute> with Moose specific
+extensions.
+
=head1 METHODS
=over 4
=item B<new>
+=item B<generate_accessor_method>
+
+=item B<generate_writer_method>
+
+=back
+
+=over 4
+
+=item B<has_type_constraint>
+
+=item B<type_constraint>
+
+=item B<has_weak_ref>
+
+=item B<weak_ref>
+
+=item B<coerce>
+
+=item B<has_coercion>
+
=back
=head1 BUGS
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
-=head1 CODE COVERAGE
-
-I use L<Devel::Cover> to test the code coverage of my tests, below is the
-L<Devel::Cover> report on this module's test suite.
-
-=head1 ACKNOWLEDGEMENTS
-
=head1 AUTHOR
Stevan Little E<lt>stevan@iinteractive.comE<gt>
projects / gitmo/Moose.git / blobdiff