This will tell the class to not create this slot until absolutely nessecary.
If an attribute is marked as lazy it B<must> have a default supplied.
+=item I<auto_deref =E<gt> (1|0)>
+
+This tells the accessor whether to automatically de-reference the value returned.
+This is only legal if your C<isa> option is either an C<ArrayRef> or C<HashRef>.
+
=item I<trigger =E<gt> $code>
The trigger option is a CODE reference which will be called after the value of
=item Most Other Object Systems Emasculate
-=item My Overcraft Overfilled (with) Some Eels
-
=item Moose Often Ovulate Sorta Early
-=item Many Overloaded Object Systems Exists
-
=item Moose Offers Often Super Extensions
=item Meta Object Orientation Syntax Extensions
Moose::Cookbook::Recipe6 - The Moose::Role example
=head1 SYNOPSIS
-
+
package Eq;
use strict;
use warnings;
sub not_equal_to {
my ($self, $other) = @_;
- !$self->equal_to($other);
+ not $self->equal_to($other);
}
- package Ord;
+ package Comparable;
use strict;
use warnings;
use Moose::Role;
sub less_than_or_equal_to {
my ($self, $other) = @_;
$self->less_than($other) || $self->equal_to($other);
- }
+ }
+
+ package Printable;
+ use strict;
+ use warnings;
+ use Moose::Role;
+
+ requires 'to_string';
package US::Currency;
use strict;
use warnings;
use Moose;
- with 'Ord';
+ with 'Comparable', 'Printable';
- has 'amount' => (is => 'rw', isa => 'Int', default => 0);
+ has 'amount' => (is => 'rw', isa => 'Num', default => 0);
sub compare {
my ($self, $other) = @_;
$self->amount <=> $other->amount;
}
+ sub to_string {
+ my $self = shift;
+ sprintf '$%0.2f USD' => $self->amount
+ }
+
=head1 DESCRIPTION
Coming Soon.
if ref $val && $self->is_weak_ref;
}
+## Accessor inline subroutines
+
sub _inline_check_constraint {
my ($self, $value) = @_;
return '' unless $self->has_type_constraint;
EOF
}
+sub _inline_check_coercion {
+ my $self = shift;
+ return '' unless $self->should_coerce;
+ return 'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
+}
+
+sub _inline_check_required {
+ my $self = shift;
+ return '' unless $self->is_required;
+ return 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
+}
+
+sub _inline_check_lazy {
+ my $self = shift;
+ return '' unless $self->is_lazy;
+ return '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
+ . 'unless exists $_[0]->{$attr_name};';
+}
+
+
sub _inline_store {
my ($self, $instance, $value) = @_;
my $inv = '$_[0]';
my $code = 'sub { '
. 'if (scalar(@_) == 2) {'
- . ($attr->is_required ?
- 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
- : '')
- . ($attr->should_coerce ?
- 'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
- : '')
+ . $attr->_inline_check_required
+ . $attr->_inline_check_coercion
. $attr->_inline_check_constraint($value_name)
. $attr->_inline_store($inv, $value_name)
. $attr->_inline_trigger($inv, $value_name)
. ' }'
- . ($attr->is_lazy ?
- '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
- . 'unless exists $_[0]->{$attr_name};'
- : '')
+ . $attr->_inline_check_lazy
. 'return ' . $attr->_inline_auto_deref($attr->_inline_get($inv))
. ' }';
my $sub = eval $code;
- warn "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
return $sub;
}
my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
my $inv = '$_[0]';
my $code = 'sub { '
- . ($attr->is_required ?
- 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
- : '')
- . ($attr->should_coerce ?
- 'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
- : '')
+ . $attr->_inline_check_required
+ . $attr->_inline_check_coercion
. $attr->_inline_check_constraint($value_name)
. $attr->_inline_store($inv, $value_name)
. $attr->_inline_trigger($inv, $value_name)
}
sub generate_reader_method {
- my $self = shift;
- my $attr_name = $self->slots;
+ my $attr = shift;
+ my $attr_name = $attr->slots;
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};'
- : '')
- . 'return ' . $self->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
+ . $attr->_inline_check_lazy
+ . 'return ' . $attr->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
. '}';
my $sub = eval $code;
confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
=item B<new>
-=item B<clone_and_inherit_options>
-
=item B<initialize_instance_slot>
=item B<generate_accessor_method>
=over 4
+=item B<clone_and_inherit_options>
+
+This is to support the C<has '+foo'> feature, it clones an attribute
+from a superclass and allows a very specific set of changes to be made
+to the attribute.
+
=item B<has_type_constraint>
Returns true if this meta-attribute has a type constraint.
not only check it's local roles, but ask them as well in order to
cascade down the role hierarchy.
-=item B<add_attribute $attr_name, %params>
+=item B<add_attribute ($attr_name, %params|$params)>
-This method does the same thing as L<Class::MOP::Class/add_attribute>, but adds
-suport for delegation.
-
-=back
-
-=head1 INTERNAL METHODS
-
-=over 4
-
-=item compute_delegation
-
-=item generate_delegation_list
-
-=item generate_delgate_method
-
-=item get_delegatable_methods
-
-=item filter_delegations
+This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
+support for taking the C<$params> as a HASH ref.
=back
=head1 DESCRIPTION
-=head1 METHODS
+This is a stub mostly, but I know I will want to use it later on.
+
+See the L<Class::MOP::Instance> docs for details on the instance
+protocol.
=head1 BUGS
=item B<requires (@method_names)>
+Roles can require that certain methods are implemented by any class which
+C<does> the role.
+
=item B<excludes (@role_names)>
+Roles can C<exclude> other roles, in effect saying "I can never be combined
+with these C<@role_names>". This is a feature which should not be used
+lightly.
+
=back
=head1 CAVEATS
use Moose::Meta::TypeConstraint;
use Moose::Meta::TypeCoercion;
-use Sub::Exporter
- -setup => {
- exports => qw[type subtype as where message coerce from via find_type_constraint enum],
- groups => {
- default => [':all']
- }
+use Sub::Exporter -setup => {
+ exports => [qw/
+ type subtype as where message
+ coerce from via
+ enum
+ find_type_constraint
+ /],
+ groups => {
+ default => [':all']
}
-);
+};
{
my %TYPES;
use strict;
use warnings;
-use Test::More tests => 52;
+use Test::More tests => 62;
use Test::Exception;
BEGIN {
sub not_equal_to {
my ($self, $other) = @_;
- !$self->equal_to($other);
+ not $self->equal_to($other);
}
- package Ord;
+ package Comparable;
use strict;
use warnings;
use Moose::Role;
sub less_than_or_equal_to {
my ($self, $other) = @_;
$self->less_than($other) || $self->equal_to($other);
- }
+ }
+
+ package Printable;
+ use strict;
+ use warnings;
+ use Moose::Role;
+
+ requires 'to_string';
}
## Classes
use warnings;
use Moose;
- with 'Ord';
+ with 'Comparable', 'Printable';
has 'amount' => (is => 'rw', isa => 'Num', default => 0);
my ($self, $other) = @_;
$self->amount <=> $other->amount;
}
+
+ sub to_string {
+ my $self = shift;
+ sprintf '$%0.2f USD' => $self->amount
+ }
}
-ok(US::Currency->does('Ord'), '... US::Currency does Ord');
+ok(US::Currency->does('Comparable'), '... US::Currency does Comparable');
ok(US::Currency->does('Eq'), '... US::Currency does Eq');
+ok(US::Currency->does('Printable'), '... US::Currency does Printable');
my $hundred = US::Currency->new(amount => 100.00);
isa_ok($hundred, 'US::Currency');
can_ok($hundred, 'amount');
is($hundred->amount, 100, '... got the right amount');
-ok($hundred->does('Ord'), '... US::Currency does Ord');
+can_ok($hundred, 'to_string');
+is($hundred->to_string, '$100.00 USD', '... got the right stringified value');
+
+ok($hundred->does('Comparable'), '... US::Currency does Comparable');
ok($hundred->does('Eq'), '... US::Currency does Eq');
+ok($hundred->does('Printable'), '... US::Currency does Printable');
my $fifty = US::Currency->new(amount => 50.00);
isa_ok($fifty, 'US::Currency');
can_ok($fifty, 'amount');
is($fifty->amount, 50, '... got the right amount');
+can_ok($fifty, 'to_string');
+is($fifty->to_string, '$50.00 USD', '... got the right stringified value');
+
ok($hundred->greater_than($fifty), '... 100 gt 50');
ok($hundred->greater_than_or_equal_to($fifty), '... 100 ge 50');
ok(!$hundred->less_than($fifty), '... !100 lt 50');
ok($eq_meta->has_method('not_equal_to'), '... Eq has_method not_equal_to');
ok($eq_meta->requires_method('equal_to'), '... Eq requires_method not_equal_to');
-# Ord
+# Comparable
-my $ord_meta = Ord->meta;
-isa_ok($ord_meta, 'Moose::Meta::Role');
+my $comparable_meta = Comparable->meta;
+isa_ok($comparable_meta, 'Moose::Meta::Role');
-ok($ord_meta->does_role('Eq'), '... Ord does Eq');
+ok($comparable_meta->does_role('Eq'), '... Comparable does Eq');
foreach my $method_name (qw(
equal_to not_equal_to
greater_than greater_than_or_equal_to
less_than less_than_or_equal_to
)) {
- ok($ord_meta->has_method($method_name), '... Ord has_method ' . $method_name);
+ ok($comparable_meta->has_method($method_name), '... Comparable has_method ' . $method_name);
}
-ok($ord_meta->requires_method('compare'), '... Ord requires_method compare');
+ok($comparable_meta->requires_method('compare'), '... Comparable requires_method compare');
+
+# Printable
+
+my $printable_meta = Printable->meta;
+isa_ok($printable_meta, 'Moose::Meta::Role');
+
+ok($printable_meta->requires_method('to_string'), '... Printable requires_method to_string');
# US::Currency
my $currency_meta = US::Currency->meta;
isa_ok($currency_meta, 'Moose::Meta::Class');
-ok($currency_meta->does_role('Ord'), '... US::Currency does Ord');
+ok($currency_meta->does_role('Comparable'), '... US::Currency does Comparable');
ok($currency_meta->does_role('Eq'), '... US::Currency does Eq');
+ok($currency_meta->does_role('Printable'), '... US::Currency does Printable');
foreach my $method_name (qw(
amount
equal_to not_equal_to
compare
greater_than greater_than_or_equal_to
- less_than less_than_or_equal_to
+ less_than less_than_or_equal_to
+ to_string
)) {
ok($currency_meta->has_method($method_name), '... US::Currency has_method ' . $method_name);
}
default => sub { 10 }
);
};
- ::ok(!$@, '... created the lazy reader method okay');
+ ::ok(!$@, '... created the lazy reader method okay') or warn $@;
}
{
projects / gitmo/Moose.git / commitdiff