use base 'Class::MOP::Attribute';
+__PACKAGE__->meta->add_attribute('required' => (reader => 'is_required' ));
+__PACKAGE__->meta->add_attribute('lazy' => (reader => 'is_lazy' ));
__PACKAGE__->meta->add_attribute('coerce' => (reader => 'should_coerce'));
__PACKAGE__->meta->add_attribute('weak_ref' => (reader => 'is_weak_ref' ));
__PACKAGE__->meta->add_attribute('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{lazy} && $options{lazy}) {
+ (exists $options{default})
+ || confess "You cannot have lazy attribute without specifying a default value for it";
+ }
});
sub generate_accessor_method {
my ($self, $attr_name) = @_;
- if ($self->has_type_constraint) {
- if ($self->is_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->should_coerce) {
- 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->is_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};
- };
- }
- }
+ my $value_name = $self->should_coerce ? '$val' : '$_[1]';
+ my $code = 'sub { '
+ . 'if (scalar(@_) == 2) {'
+ . ($self->is_required ?
+ 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
+ : '')
+ . ($self->should_coerce ?
+ 'my $val = $self->type_constraint->coercion->coerce($_[1]);'
+ : '')
+ . ($self->has_type_constraint ?
+ ('(defined $self->type_constraint->check(' . $value_name . '))'
+ . '|| confess "Attribute ($attr_name) does not pass the type contraint with \'' . $value_name . '\'"'
+ . 'if defined ' . $value_name . ';')
+ : '')
+ . '$_[0]->{$attr_name} = ' . $value_name . ';'
+ . ($self->is_weak_ref ?
+ 'weaken($_[0]->{$attr_name});'
+ : '')
+ . ' }'
+ . ($self->is_lazy ?
+ '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
+ . 'unless exists $_[0]->{$attr_name};'
+ : '')
+ . ' $_[0]->{$attr_name};'
+ . ' }';
+ my $sub = eval $code;
+ confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
+ return $sub;
}
sub generate_writer_method {
my ($self, $attr_name) = @_;
- if ($self->has_type_constraint) {
- if ($self->is_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->should_coerce) {
- 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->is_weak_ref) {
- return sub {
- $_[0]->{$attr_name} = $_[1];
- weaken($_[0]->{$attr_name});
- };
- }
- else {
- return sub { $_[0]->{$attr_name} = $_[1] };
- }
- }
+ my $value_name = $self->should_coerce ? '$val' : '$_[1]';
+ my $code = 'sub { '
+ . ($self->is_required ?
+ 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
+ : '')
+ . ($self->should_coerce ?
+ 'my $val = $self->type_constraint->coercion->coerce($_[1]);'
+ : '')
+ . ($self->has_type_constraint ?
+ ('(defined $self->type_constraint->check(' . $value_name . '))'
+ . '|| confess "Attribute ($attr_name) does not pass the type contraint with \'' . $value_name . '\'"'
+ . 'if defined ' . $value_name . ';')
+ : '')
+ . '$_[0]->{$attr_name} = ' . $value_name . ';'
+ . ($self->is_weak_ref ?
+ 'weaken($_[0]->{$attr_name});'
+ : '')
+ . ' }';
+ my $sub = eval $code;
+ confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
+ return $sub;
}
sub generate_reader_method {
my ($self, $attr_name) = @_;
- sub {
- confess "Cannot assign a value to a read-only accessor" if @_ > 1;
- $_[0]->{$attr_name}
- };
+ my $code = 'sub {'
+ . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
+ . ($self->is_lazy ?
+ '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
+ . 'unless exists $_[0]->{$attr_name};'
+ : '')
+ . '$_[0]->{$attr_name};'
+ . '}';
+ my $sub = eval $code;
+ confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
+ return $sub;
}
1;
Returns true of this meta-attribute produces a weak reference.
+=item B<is_required>
+
+Returns true of this meta-attribute is required to have a value.
+
+=item B<is_lazy>
+
+Returns true of this meta-attribute should be initialized lazily.
+
+NOTE: lazy attributes, B<must> have a C<default> field set.
+
=item B<should_coerce>
Returns true of this meta-attribute should perform type coercion.
my $init_arg = $attr->init_arg();
# try to fetch the init arg from the %params ...
my $val;
- $val = $params{$init_arg} if exists $params{$init_arg};
+ if (exists $params{$init_arg}) {
+ $val = $params{$init_arg};
+ }
+ else {
+ # skip it if it's lazy
+ next if $attr->is_lazy;
+ # and die if it is required
+ confess "Attribute (" . $attr->name . ") is required"
+ if $attr->is_required
+ }
# if nothing was in the %params, we can use the
# attribute's default value (if it has one)
if (!defined $val && $attr->has_default) {
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 14;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose');
+}
+
+{
+ package Foo;
+ use strict;
+ use warnings;
+ use Moose;
+
+ eval {
+ has 'foo' => (
+ reader => 'get_foo'
+ );
+ };
+ ::ok(!$@, '... created the reader method okay');
+
+ eval {
+ has 'lazy_foo' => (
+ reader => 'get_lazy_foo',
+ lazy => 1,
+ default => sub { 10 }
+ );
+ };
+ ::ok(!$@, '... created the lazy reader method okay');
+}
+
+{
+ my $foo = Foo->new;
+ isa_ok($foo, 'Foo');
+
+ can_ok($foo, 'get_foo');
+ is($foo->get_foo(), undef, '... got an undefined value');
+ dies_ok {
+ $foo->get_foo(100);
+ } '... get_foo is a read-only';
+
+ ok(!exists($foo->{lazy_foo}), '... no value in get_lazy_foo slot');
+
+ can_ok($foo, 'get_lazy_foo');
+ is($foo->get_lazy_foo(), 10, '... got an deferred value');
+ dies_ok {
+ $foo->get_lazy_foo(100);
+ } '... get_lazy_foo is a read-only';
+}
+
+{
+ my $foo = Foo->new(foo => 10, lazy_foo => 100);
+ isa_ok($foo, 'Foo');
+
+ is($foo->get_foo(), 10, '... got the correct value');
+ is($foo->get_lazy_foo(), 100, '... got the correct value');
+}
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 29;
+use Test::Exception;
+
+use Scalar::Util 'isweak';
+
+BEGIN {
+ use_ok('Moose');
+}
+
+{
+ package Foo;
+ use strict;
+ use warnings;
+ use Moose;
+
+ eval {
+ has 'foo' => (
+ reader => 'get_foo',
+ writer => 'set_foo',
+ );
+ };
+ ::ok(!$@, '... created the writer method okay');
+
+ eval {
+ has 'foo_required' => (
+ reader => 'get_foo_required',
+ writer => 'set_foo_required',
+ required => 1,
+ );
+ };
+ ::ok(!$@, '... created the required writer method okay');
+
+ eval {
+ has 'foo_int' => (
+ reader => 'get_foo_int',
+ writer => 'set_foo_int',
+ isa => 'Int',
+ );
+ };
+ ::ok(!$@, '... created the writer method with type constraint okay');
+
+ eval {
+ has 'foo_weak' => (
+ reader => 'get_foo_weak',
+ writer => 'set_foo_weak',
+ weak_ref => 1
+ );
+ };
+ ::ok(!$@, '... created the writer method with weak_ref okay');
+}
+
+{
+ my $foo = Foo->new(foo_required => 'required');
+ isa_ok($foo, 'Foo');
+
+ # regular writer
+
+ can_ok($foo, 'set_foo');
+ is($foo->get_foo(), undef, '... got an unset value');
+ lives_ok {
+ $foo->set_foo(100);
+ } '... set_foo wrote successfully';
+ is($foo->get_foo(), 100, '... got the correct set value');
+
+ ok(!isweak($foo->{foo}), '... it is not a weak reference');
+
+ # required writer
+
+ dies_ok {
+ Foo->new;
+ } '... cannot create without the required attribute';
+
+ can_ok($foo, 'set_foo_required');
+ is($foo->get_foo_required(), 'required', '... got an unset value');
+ lives_ok {
+ $foo->set_foo_required(100);
+ } '... set_foo_required wrote successfully';
+ is($foo->get_foo_required(), 100, '... got the correct set value');
+
+ dies_ok {
+ $foo->set_foo_required(undef);
+ } '... set_foo_required died successfully';
+
+ ok(!isweak($foo->{foo_required}), '... it is not a weak reference');
+
+ # with type constraint
+
+ can_ok($foo, 'set_foo_int');
+ is($foo->get_foo_int(), undef, '... got an unset value');
+ lives_ok {
+ $foo->set_foo_int(100);
+ } '... set_foo_int wrote successfully';
+ is($foo->get_foo_int(), 100, '... got the correct set value');
+
+ dies_ok {
+ $foo->set_foo_int("Foo");
+ } '... set_foo_int died successfully';
+
+ ok(!isweak($foo->{foo_int}), '... it is not a weak reference');
+
+ # with weak_ref
+
+ my $test = [];
+
+ can_ok($foo, 'set_foo_weak');
+ is($foo->get_foo_weak(), undef, '... got an unset value');
+ lives_ok {
+ $foo->set_foo_weak($test);
+ } '... set_foo_weak wrote successfully';
+ is($foo->get_foo_weak(), $test, '... got the correct set value');
+
+ ok(isweak($foo->{foo_weak}), '... it is a weak reference');
+}
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 33;
+use Test::Exception;
+
+use Scalar::Util 'isweak';
+
+BEGIN {
+ use_ok('Moose');
+}
+
+{
+ package Foo;
+ use strict;
+ use warnings;
+ use Moose;
+
+ eval {
+ has 'foo' => (
+ accessor => 'foo',
+ );
+ };
+ ::ok(!$@, '... created the accessor method okay');
+
+ eval {
+ has 'lazy_foo' => (
+ accessor => 'lazy_foo',
+ lazy => 1,
+ default => sub { 10 }
+ );
+ };
+ ::ok(!$@, '... created the lazy accessor method okay');
+
+
+ eval {
+ has 'foo_required' => (
+ accessor => 'foo_required',
+ required => 1,
+ );
+ };
+ ::ok(!$@, '... created the required accessor method okay');
+
+ eval {
+ has 'foo_int' => (
+ accessor => 'foo_int',
+ isa => 'Int',
+ );
+ };
+ ::ok(!$@, '... created the accessor method with type constraint okay');
+
+ eval {
+ has 'foo_weak' => (
+ accessor => 'foo_weak',
+ weak_ref => 1
+ );
+ };
+ ::ok(!$@, '... created the accessor method with weak_ref okay');
+}
+
+{
+ my $foo = Foo->new(foo_required => 'required');
+ isa_ok($foo, 'Foo');
+
+ # regular accessor
+
+ can_ok($foo, 'foo');
+ is($foo->foo(), undef, '... got an unset value');
+ lives_ok {
+ $foo->foo(100);
+ } '... foo wrote successfully';
+ is($foo->foo(), 100, '... got the correct set value');
+
+ ok(!isweak($foo->{foo}), '... it is not a weak reference');
+
+ # required writer
+
+ dies_ok {
+ Foo->new;
+ } '... cannot create without the required attribute';
+
+ can_ok($foo, 'foo_required');
+ is($foo->foo_required(), 'required', '... got an unset value');
+ lives_ok {
+ $foo->foo_required(100);
+ } '... foo_required wrote successfully';
+ is($foo->foo_required(), 100, '... got the correct set value');
+
+ dies_ok {
+ $foo->foo_required(undef);
+ } '... foo_required died successfully';
+
+ ok(!isweak($foo->{foo_required}), '... it is not a weak reference');
+
+ # lazy
+
+ ok(!exists($foo->{lazy_foo}), '... no value in lazy_foo slot');
+
+ can_ok($foo, 'lazy_foo');
+ is($foo->lazy_foo(), 10, '... got an deferred value');
+
+ # with type constraint
+
+ can_ok($foo, 'foo_int');
+ is($foo->foo_int(), undef, '... got an unset value');
+ lives_ok {
+ $foo->foo_int(100);
+ } '... foo_int wrote successfully';
+ is($foo->foo_int(), 100, '... got the correct set value');
+
+ dies_ok {
+ $foo->foo_int("Foo");
+ } '... foo_int died successfully';
+
+ ok(!isweak($foo->{foo_int}), '... it is not a weak reference');
+
+ # with weak_ref
+
+ my $test = [];
+
+ can_ok($foo, 'foo_weak');
+ is($foo->foo_weak(), undef, '... got an unset value');
+ lives_ok {
+ $foo->foo_weak($test);
+ } '... foo_weak wrote successfully';
+ is($foo->foo_weak(), $test, '... got the correct set value');
+
+ ok(isweak($foo->{foo_weak}), '... it is a weak reference');
+
+}
+
+
+
projects / gitmo/Moose.git / commitdiff