summaryrefslogtreecommitdiff
path: root/t/native_traits
diff options
context:
space:
mode:
Diffstat (limited to 't/native_traits')
-rw-r--r--t/native_traits/array_coerce.t235
-rw-r--r--t/native_traits/array_from_role.t44
-rw-r--r--t/native_traits/array_subtypes.t264
-rw-r--r--t/native_traits/array_trigger.t53
-rw-r--r--t/native_traits/collection_with_roles.t122
-rw-r--r--t/native_traits/custom_instance.t246
-rw-r--r--t/native_traits/hash_coerce.t148
-rw-r--r--t/native_traits/hash_subtypes.t204
-rw-r--r--t/native_traits/hash_trigger.t54
-rw-r--r--t/native_traits/remove_attribute.t48
-rw-r--r--t/native_traits/shallow_clone.t42
-rw-r--r--t/native_traits/trait_array.t740
-rw-r--r--t/native_traits/trait_bool.t101
-rw-r--r--t/native_traits/trait_code.t113
-rw-r--r--t/native_traits/trait_counter.t170
-rw-r--r--t/native_traits/trait_hash.t329
-rw-r--r--t/native_traits/trait_number.t161
-rw-r--r--t/native_traits/trait_string.t303
18 files changed, 3377 insertions, 0 deletions
diff --git a/t/native_traits/array_coerce.t b/t/native_traits/array_coerce.t
new file mode 100644
index 0000000..301fd01
--- /dev/null
+++ b/t/native_traits/array_coerce.t
@@ -0,0 +1,235 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+{
+
+ package Foo;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ subtype 'UCArray', as 'ArrayRef[Str]', where {
+ !grep {/[a-z]/} @{$_};
+ };
+
+ coerce 'UCArray', from 'ArrayRef[Str]', via {
+ [ map { uc $_ } @{$_} ];
+ };
+
+ has array => (
+ traits => ['Array'],
+ is => 'rw',
+ isa => 'UCArray',
+ coerce => 1,
+ handles => {
+ push_array => 'push',
+ set_array => 'set',
+ },
+ );
+
+ our @TriggerArgs;
+
+ has lazy => (
+ traits => ['Array'],
+ is => 'rw',
+ isa => 'UCArray',
+ coerce => 1,
+ lazy => 1,
+ default => sub { ['a'] },
+ handles => {
+ push_lazy => 'push',
+ set_lazy => 'set',
+ },
+ trigger => sub { @TriggerArgs = @_ },
+ clearer => 'clear_lazy',
+ );
+}
+
+my $foo = Foo->new;
+
+{
+ $foo->array( [qw( A B C )] );
+
+ $foo->push_array('d');
+
+ is_deeply(
+ $foo->array, [qw( A B C D )],
+ 'push coerces the array'
+ );
+
+ $foo->set_array( 1 => 'x' );
+
+ is_deeply(
+ $foo->array, [qw( A X C D )],
+ 'set coerces the array'
+ );
+}
+
+{
+ $foo->push_lazy('d');
+
+ is_deeply(
+ $foo->lazy, [qw( A D )],
+ 'push coerces the array - lazy'
+ );
+
+ is_deeply(
+ \@Foo::TriggerArgs,
+ [ $foo, [qw( A D )], ['A'] ],
+ 'trigger receives expected arguments'
+ );
+
+ $foo->set_lazy( 2 => 'f' );
+
+ is_deeply(
+ $foo->lazy, [qw( A D F )],
+ 'set coerces the array - lazy'
+ );
+
+ is_deeply(
+ \@Foo::TriggerArgs,
+ [ $foo, [qw( A D F )], [qw( A D )] ],
+ 'trigger receives expected arguments'
+ );
+}
+
+{
+ package Thing;
+ use Moose;
+
+ has thing => (
+ is => 'ro',
+ isa => 'Int',
+ );
+}
+
+{
+ package Bar;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ class_type 'Thing';
+
+ coerce 'Thing'
+ => from 'Int'
+ => via { Thing->new( thing => $_ ) };
+
+ subtype 'ArrayRefOfThings'
+ => as 'ArrayRef[Thing]';
+
+ coerce 'ArrayRefOfThings'
+ => from 'ArrayRef[Int]'
+ => via { [ map { Thing->new( thing => $_ ) } @{$_} ] };
+
+ coerce 'ArrayRefOfThings'
+ => from 'Int'
+ => via { [ Thing->new( thing => $_ ) ] };
+
+ has array => (
+ traits => ['Array'],
+ is => 'rw',
+ isa => 'ArrayRefOfThings',
+ coerce => 1,
+ handles => {
+ push_array => 'push',
+ unshift_array => 'unshift',
+ set_array => 'set',
+ insert_array => 'insert',
+ },
+ );
+}
+
+{
+ my $bar = Bar->new( array => [ 1, 2, 3 ] );
+
+ $bar->push_array( 4, 5 );
+
+ is_deeply(
+ [ map { $_->thing } @{ $bar->array } ],
+ [ 1, 2, 3, 4, 5 ],
+ 'push coerces new members'
+ );
+
+ $bar->unshift_array( -1, 0 );
+
+ is_deeply(
+ [ map { $_->thing } @{ $bar->array } ],
+ [ -1, 0, 1, 2, 3, 4, 5 ],
+ 'unshift coerces new members'
+ );
+
+ $bar->set_array( 3 => 9 );
+
+ is_deeply(
+ [ map { $_->thing } @{ $bar->array } ],
+ [ -1, 0, 1, 9, 3, 4, 5 ],
+ 'set coerces new members'
+ );
+
+ $bar->insert_array( 3 => 42 );
+
+ is_deeply(
+ [ map { $_->thing } @{ $bar->array } ],
+ [ -1, 0, 1, 42, 9, 3, 4, 5 ],
+ 'insert coerces new members'
+ );
+}
+
+{
+ package Baz;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ subtype 'SmallArrayRef'
+ => as 'ArrayRef'
+ => where { @{$_} <= 2 };
+
+ coerce 'SmallArrayRef'
+ => from 'ArrayRef'
+ => via { [ @{$_}[ -2, -1 ] ] };
+
+ has array => (
+ traits => ['Array'],
+ is => 'rw',
+ isa => 'SmallArrayRef',
+ coerce => 1,
+ handles => {
+ push_array => 'push',
+ set_array => 'set',
+ insert_array => 'insert',
+ },
+ );
+}
+
+{
+ my $baz = Baz->new( array => [ 1, 2, 3 ] );
+
+ is_deeply(
+ $baz->array, [ 2, 3 ],
+ 'coercion truncates array ref in constructor'
+ );
+
+ $baz->push_array(4);
+
+ is_deeply(
+ $baz->array, [ 3, 4 ],
+ 'coercion truncates array ref on push'
+ );
+
+ $baz->insert_array( 1 => 5 );
+
+ is_deeply(
+ $baz->array, [ 5, 4 ],
+ 'coercion truncates array ref on insert'
+ );
+
+ $baz->push_array( 7, 8, 9 );
+
+ is_deeply(
+ $baz->array, [ 8, 9 ],
+ 'coercion truncates array ref on push'
+ );
+}
+
+done_testing;
diff --git a/t/native_traits/array_from_role.t b/t/native_traits/array_from_role.t
new file mode 100644
index 0000000..21d0a06
--- /dev/null
+++ b/t/native_traits/array_from_role.t
@@ -0,0 +1,44 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+{
+ package Foo;
+ use Moose;
+
+ has 'bar' => ( is => 'rw' );
+
+ package Stuffed::Role;
+ use Moose::Role;
+
+ has 'options' => (
+ traits => ['Array'],
+ is => 'ro',
+ isa => 'ArrayRef[Foo]',
+ );
+
+ package Bulkie::Role;
+ use Moose::Role;
+
+ has 'stuff' => (
+ traits => ['Array'],
+ is => 'ro',
+ isa => 'ArrayRef',
+ handles => {
+ get_stuff => 'get',
+ }
+ );
+
+ package Stuff;
+ use Moose;
+
+ ::is( ::exception { with 'Stuffed::Role';
+ }, undef, '... this should work correctly' );
+
+ ::is( ::exception { with 'Bulkie::Role';
+ }, undef, '... this should work correctly' );
+}
+
+done_testing;
diff --git a/t/native_traits/array_subtypes.t b/t/native_traits/array_subtypes.t
new file mode 100644
index 0000000..d85c8f6
--- /dev/null
+++ b/t/native_traits/array_subtypes.t
@@ -0,0 +1,264 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+
+{
+ use Moose::Util::TypeConstraints;
+ use List::Util qw(sum);
+
+ subtype 'A1', as 'ArrayRef[Int]';
+ subtype 'A2', as 'ArrayRef', where { @$_ < 2 };
+ subtype 'A3', as 'ArrayRef[Int]', where { ( sum(@$_) || 0 ) < 5 };
+
+ subtype 'A5', as 'ArrayRef';
+ coerce 'A5', from 'Str', via { [ $_ ] };
+
+ no Moose::Util::TypeConstraints;
+}
+
+{
+ package Foo;
+ use Moose;
+
+ has array => (
+ traits => ['Array'],
+ is => 'rw',
+ isa => 'ArrayRef',
+ handles => {
+ push_array => 'push',
+ },
+ );
+
+ has array_int => (
+ traits => ['Array'],
+ is => 'rw',
+ isa => 'ArrayRef[Int]',
+ handles => {
+ push_array_int => 'push',
+ },
+ );
+
+ has a1 => (
+ traits => ['Array'],
+ is => 'rw',
+ isa => 'A1',
+ handles => {
+ push_a1 => 'push',
+ },
+ );
+
+ has a2 => (
+ traits => ['Array'],
+ is => 'rw',
+ isa => 'A2',
+ handles => {
+ push_a2 => 'push',
+ },
+ );
+
+ has a3 => (
+ traits => ['Array'],
+ is => 'rw',
+ isa => 'A3',
+ handles => {
+ push_a3 => 'push',
+ },
+ );
+
+ has a4 => (
+ traits => ['Array'],
+ is => 'rw',
+ isa => 'ArrayRef',
+ lazy => 1,
+ default => 'invalid',
+ clearer => '_clear_a4',
+ handles => {
+ get_a4 => 'get',
+ push_a4 => 'push',
+ accessor_a4 => 'accessor',
+ },
+ );
+
+ has a5 => (
+ traits => ['Array'],
+ is => 'rw',
+ isa => 'A5',
+ coerce => 1,
+ lazy => 1,
+ default => 'invalid',
+ clearer => '_clear_a5',
+ handles => {
+ get_a5 => 'get',
+ push_a5 => 'push',
+ accessor_a5 => 'accessor',
+ },
+ );
+}
+
+my $foo = Foo->new;
+
+{
+ $foo->array( [] );
+ is_deeply( $foo->array, [], "array - correct contents" );
+
+ $foo->push_array('foo');
+ is_deeply( $foo->array, ['foo'], "array - correct contents" );
+}
+
+{
+ $foo->array_int( [] );
+ is_deeply( $foo->array_int, [], "array_int - correct contents" );
+
+ isnt( exception { $foo->push_array_int('foo') }, undef, "array_int - can't push wrong type" );
+ is_deeply( $foo->array_int, [], "array_int - correct contents" );
+
+ $foo->push_array_int(1);
+ is_deeply( $foo->array_int, [1], "array_int - correct contents" );
+}
+
+{
+ isnt( exception { $foo->push_a1('foo') }, undef, "a1 - can't push onto undef" );
+
+ $foo->a1( [] );
+ is_deeply( $foo->a1, [], "a1 - correct contents" );
+
+ isnt( exception { $foo->push_a1('foo') }, undef, "a1 - can't push wrong type" );
+
+ is_deeply( $foo->a1, [], "a1 - correct contents" );
+
+ $foo->push_a1(1);
+ is_deeply( $foo->a1, [1], "a1 - correct contents" );
+}
+
+{
+ isnt( exception { $foo->push_a2('foo') }, undef, "a2 - can't push onto undef" );
+
+ $foo->a2( [] );
+ is_deeply( $foo->a2, [], "a2 - correct contents" );
+
+ $foo->push_a2('foo');
+ is_deeply( $foo->a2, ['foo'], "a2 - correct contents" );
+
+ isnt( exception { $foo->push_a2('bar') }, undef, "a2 - can't push more than one element" );
+
+ is_deeply( $foo->a2, ['foo'], "a2 - correct contents" );
+}
+
+{
+ isnt( exception { $foo->push_a3(1) }, undef, "a3 - can't push onto undef" );
+
+ $foo->a3( [] );
+ is_deeply( $foo->a3, [], "a3 - correct contents" );
+
+ isnt( exception { $foo->push_a3('foo') }, undef, "a3 - can't push non-int" );
+
+ isnt( exception { $foo->push_a3(100) }, undef, "a3 - can't violate overall type constraint" );
+
+ is_deeply( $foo->a3, [], "a3 - correct contents" );
+
+ $foo->push_a3(1);
+ is_deeply( $foo->a3, [1], "a3 - correct contents" );
+
+ isnt( exception { $foo->push_a3(100) }, undef, "a3 - can't violate overall type constraint" );
+
+ is_deeply( $foo->a3, [1], "a3 - correct contents" );
+
+ $foo->push_a3(3);
+ is_deeply( $foo->a3, [ 1, 3 ], "a3 - correct contents" );
+}
+
+{
+ my $expect
+ = qr/\QAttribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value \E.*invalid.*/;
+
+ like(
+ exception { $foo->accessor_a4(0); },
+ $expect,
+ 'invalid default is caught when trying to read via accessor'
+ );
+
+ like(
+ exception { $foo->accessor_a4( 0 => 42 ); },
+ $expect,
+ 'invalid default is caught when trying to write via accessor'
+ );
+
+ like(
+ exception { $foo->push_a4(42); },
+ $expect,
+ 'invalid default is caught when trying to push'
+ );
+
+ like(
+ exception { $foo->get_a4(42); },
+ $expect,
+ 'invalid default is caught when trying to get'
+ );
+}
+
+{
+ my $foo = Foo->new;
+
+ is(
+ $foo->accessor_a5(0), 'invalid',
+ 'lazy default is coerced when trying to read via accessor'
+ );
+
+ $foo->_clear_a5;
+
+ $foo->accessor_a5( 1 => 'thing' );
+
+ is_deeply(
+ $foo->a5,
+ [ 'invalid', 'thing' ],
+ 'lazy default is coerced when trying to write via accessor'
+ );
+
+ $foo->_clear_a5;
+
+ $foo->push_a5('thing');
+
+ is_deeply(
+ $foo->a5,
+ [ 'invalid', 'thing' ],
+ 'lazy default is coerced when trying to push'
+ );
+
+ $foo->_clear_a5;
+
+ is(
+ $foo->get_a5(0), 'invalid',
+ 'lazy default is coerced when trying to get'
+ );
+}
+
+{
+ package Bar;
+ use Moose;
+}
+
+{
+ package HasArray;
+ use Moose;
+
+ has objects => (
+ isa => 'ArrayRef[Foo]',
+ traits => ['Array'],
+ handles => {
+ push_objects => 'push',
+ },
+ );
+}
+
+{
+ my $ha = HasArray->new();
+
+ like(
+ exception { $ha->push_objects( Bar->new ) },
+ qr/\QValidation failed for 'Foo'/,
+ 'got expected error when pushing an object of the wrong class onto an array ref'
+ );
+}
+
+done_testing;
diff --git a/t/native_traits/array_trigger.t b/t/native_traits/array_trigger.t
new file mode 100644
index 0000000..419c303
--- /dev/null
+++ b/t/native_traits/array_trigger.t
@@ -0,0 +1,53 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+{
+ package Foo;
+ use Moose;
+
+ our @TriggerArgs;
+
+ has array => (
+ traits => ['Array'],
+ is => 'rw',
+ isa => 'ArrayRef',
+ handles => {
+ push_array => 'push',
+ set_array => 'set',
+ },
+ clearer => 'clear_array',
+ trigger => sub { @TriggerArgs = @_ },
+ );
+}
+
+my $foo = Foo->new;
+
+{
+ $foo->array( [ 1, 2, 3 ] );
+
+ is_deeply(
+ \@Foo::TriggerArgs,
+ [ $foo, [ 1, 2, 3 ] ],
+ 'trigger was called for normal writer'
+ );
+
+ $foo->push_array(5);
+
+ is_deeply(
+ \@Foo::TriggerArgs,
+ [ $foo, [ 1, 2, 3, 5 ], [ 1, 2, 3 ] ],
+ 'trigger was called on push'
+ );
+
+ $foo->set_array( 1, 42 );
+
+ is_deeply(
+ \@Foo::TriggerArgs,
+ [ $foo, [ 1, 42, 3, 5 ], [ 1, 2, 3, 5 ] ],
+ 'trigger was called on set'
+ );
+}
+
+done_testing;
diff --git a/t/native_traits/collection_with_roles.t b/t/native_traits/collection_with_roles.t
new file mode 100644
index 0000000..6d75675
--- /dev/null
+++ b/t/native_traits/collection_with_roles.t
@@ -0,0 +1,122 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+{
+ package Subject;
+
+ use Moose::Role;
+
+ has observers => (
+ traits => ['Array'],
+ is => 'ro',
+ isa => 'ArrayRef[Observer]',
+ auto_deref => 1,
+ default => sub { [] },
+ handles => {
+ 'add_observer' => 'push',
+ 'count_observers' => 'count',
+ },
+ );
+
+ sub notify {
+ my ($self) = @_;
+ foreach my $observer ( $self->observers() ) {
+ $observer->update($self);
+ }
+ }
+}
+
+{
+ package Observer;
+
+ use Moose::Role;
+
+ requires 'update';
+}
+
+{
+ package Counter;
+
+ use Moose;
+
+ with 'Subject';
+
+ has count => (
+ traits => ['Counter'],
+ is => 'ro',
+ isa => 'Int',
+ default => 0,
+ handles => {
+ inc_counter => 'inc',
+ dec_counter => 'dec',
+ },
+ );
+
+ after qw(inc_counter dec_counter) => sub {
+ my ($self) = @_;
+ $self->notify();
+ };
+}
+
+{
+
+ package Display;
+
+ use Test::More;
+
+ use Moose;
+
+ with 'Observer';
+
+ sub update {
+ my ( $self, $subject ) = @_;
+ like $subject->count, qr{^-?\d+$},
+ 'Observed number ' . $subject->count;
+ }
+}
+
+package main;
+
+my $count = Counter->new();
+
+ok( $count->can('add_observer'), 'add_observer method added' );
+
+ok( $count->can('count_observers'), 'count_observers method added' );
+
+ok( $count->can('inc_counter'), 'inc_counter method added' );
+
+ok( $count->can('dec_counter'), 'dec_counter method added' );
+
+$count->add_observer( Display->new() );
+
+is( $count->count_observers, 1, 'Only one observer' );
+
+is( $count->count, 0, 'Default to zero' );
+
+$count->inc_counter;
+
+is( $count->count, 1, 'Increment to one ' );
+
+$count->inc_counter for ( 1 .. 6 );
+
+is( $count->count, 7, 'Increment up to seven' );
+
+$count->dec_counter;
+
+is( $count->count, 6, 'Decrement to 6' );
+
+$count->dec_counter for ( 1 .. 5 );
+
+is( $count->count, 1, 'Decrement to 1' );
+
+$count->dec_counter for ( 1 .. 2 );
+
+is( $count->count, -1, 'Negative numbers' );
+
+$count->inc_counter;
+
+is( $count->count, 0, 'Back to zero' );
+
+done_testing;
diff --git a/t/native_traits/custom_instance.t b/t/native_traits/custom_instance.t
new file mode 100644
index 0000000..0b08339
--- /dev/null
+++ b/t/native_traits/custom_instance.t
@@ -0,0 +1,246 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+use Test::Moose;
+
+{
+ package ValueContainer;
+ use Moose;
+
+ has value => (
+ is => 'rw',
+ );
+}
+
+{
+ package Foo::Meta::Instance;
+ use Moose::Role;
+
+ around get_slot_value => sub {
+ my $orig = shift;
+ my $self = shift;
+ my ($instance, $slot_name) = @_;
+ my $value = $self->$orig(@_);
+ if ($value->isa('ValueContainer')) {
+ $value = $value->value;
+ }
+ return $value;
+ };
+
+ around inline_get_slot_value => sub {
+ my $orig = shift;
+ my $self = shift;
+ my $value = $self->$orig(@_);
+ return q[do {] . "\n"
+ . q[ my $value = ] . $value . q[;] . "\n"
+ . q[ if ($value->isa('ValueContainer')) {] . "\n"
+ . q[ $value = $value->value;] . "\n"
+ . q[ }] . "\n"
+ . q[ $value] . "\n"
+ . q[}];
+ };
+
+ sub inline_get_is_lvalue { 0 }
+}
+
+{
+ package Foo;
+ use Moose;
+ Moose::Util::MetaRole::apply_metaroles(
+ for => __PACKAGE__,
+ class_metaroles => {
+ instance => ['Foo::Meta::Instance'],
+ }
+ );
+
+ ::is( ::exception {
+ has array => (
+ traits => ['Array'],
+ isa => 'ArrayRef',
+ default => sub { [] },
+ handles => {
+ array_count => 'count',
+ array_elements => 'elements',
+ array_is_empty => 'is_empty',
+ array_push => 'push',
+ array_push_curried => [ push => 42, 84 ],
+ array_unshift => 'unshift',
+ array_unshift_curried => [ unshift => 42, 84 ],
+ array_pop => 'pop',
+ array_shift => 'shift',
+ array_get => 'get',
+ array_get_curried => [ get => 1 ],
+ array_set => 'set',
+ array_set_curried_1 => [ set => 1 ],
+ array_set_curried_2 => [ set => ( 1, 98 ) ],
+ array_accessor => 'accessor',
+ array_accessor_curried_1 => [ accessor => 1 ],
+ array_accessor_curried_2 => [ accessor => ( 1, 90 ) ],
+ array_clear => 'clear',
+ array_delete => 'delete',
+ array_delete_curried => [ delete => 1 ],
+ array_insert => 'insert',
+ array_insert_curried => [ insert => ( 1, 101 ) ],
+ array_splice => 'splice',
+ array_splice_curried_1 => [ splice => 1 ],
+ array_splice_curried_2 => [ splice => 1, 2 ],
+ array_splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ],
+ array_sort => 'sort',
+ array_sort_curried =>
+ [ sort => ( sub { $_[1] <=> $_[0] } ) ],
+ array_sort_in_place => 'sort_in_place',
+ array_sort_in_place_curried =>
+ [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ],
+ array_map => 'map',
+ array_map_curried => [ map => ( sub { $_ + 1 } ) ],
+ array_grep => 'grep',
+ array_grep_curried => [ grep => ( sub { $_ < 5 } ) ],
+ array_first => 'first',
+ array_first_curried => [ first => ( sub { $_ % 2 } ) ],
+ array_join => 'join',
+ array_join_curried => [ join => '-' ],
+ array_shuffle => 'shuffle',
+ array_uniq => 'uniq',
+ array_reduce => 'reduce',
+ array_reduce_curried =>
+ [ reduce => ( sub { $_[0] * $_[1] } ) ],
+ array_natatime => 'natatime',
+ array_natatime_curried => [ natatime => 2 ],
+ },
+ );
+ }, undef, "native array trait inlines properly" );
+
+ ::is( ::exception {
+ has bool => (
+ traits => ['Bool'],
+ isa => 'Bool',
+ default => 0,
+ handles => {
+ bool_illuminate => 'set',
+ bool_darken => 'unset',
+ bool_flip_switch => 'toggle',
+ bool_is_dark => 'not',
+ },
+ );
+ }, undef, "native bool trait inlines properly" );
+
+ ::is( ::exception {
+ has code => (
+ traits => ['Code'],
+ isa => 'CodeRef',
+ default => sub { sub { } },
+ handles => {
+ code_execute => 'execute',
+ code_execute_method => 'execute_method',
+ },
+ );
+ }, undef, "native code trait inlines properly" );
+
+ ::is( ::exception {
+ has counter => (
+ traits => ['Counter'],
+ isa => 'Int',
+ default => 0,
+ handles => {
+ inc_counter => 'inc',
+ inc_counter_2 => [ inc => 2 ],
+ dec_counter => 'dec',
+ dec_counter_2 => [ dec => 2 ],
+ reset_counter => 'reset',
+ set_counter => 'set',
+ set_counter_42 => [ set => 42 ],
+ },
+ );
+ }, undef, "native counter trait inlines properly" );
+
+ ::is( ::exception {
+ has hash => (
+ traits => ['Hash'],
+ isa => 'HashRef',
+ default => sub { {} },
+ handles => {
+ hash_option_accessor => 'accessor',
+ hash_quantity => [ accessor => 'quantity' ],
+ hash_clear_options => 'clear',
+ hash_num_options => 'count',
+ hash_delete_option => 'delete',
+ hash_is_defined => 'defined',
+ hash_options_elements => 'elements',
+ hash_has_option => 'exists',
+ hash_get_option => 'get',
+ hash_has_no_options => 'is_empty',
+ hash_key_value => 'kv',
+ hash_set_option => 'set',
+ },
+ );
+ }, undef, "native hash trait inlines properly" );
+
+ ::is( ::exception {
+ has number => (
+ traits => ['Number'],
+ isa => 'Num',
+ default => 0,
+ handles => {
+ num_abs => 'abs',
+ num_add => 'add',
+ num_inc => [ add => 1 ],
+ num_div => 'div',
+ num_cut_in_half => [ div => 2 ],
+ num_mod => 'mod',
+ num_odd => [ mod => 2 ],
+ num_mul => 'mul',
+ num_set => 'set',
+ num_sub => 'sub',
+ num_dec => [ sub => 1 ],
+ },
+ );
+ }, undef, "native number trait inlines properly" );
+
+ ::is( ::exception {
+ has string => (
+ traits => ['String'],
+ is => 'ro',
+ isa => 'Str',
+ default => '',
+ handles => {
+ string_inc => 'inc',
+ string_append => 'append',
+ string_append_curried => [ append => '!' ],
+ string_prepend => 'prepend',
+ string_prepend_curried => [ prepend => '-' ],
+ string_replace => 'replace',
+ string_replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ],
+ string_chop => 'chop',
+ string_chomp => 'chomp',
+ string_clear => 'clear',
+ string_match => 'match',
+ string_match_curried => [ match => qr/\D/ ],
+ string_length => 'length',
+ string_substr => 'substr',
+ string_substr_curried_1 => [ substr => (1) ],
+ string_substr_curried_2 => [ substr => ( 1, 3 ) ],
+ string_substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ],
+ },
+ );
+ }, undef, "native string trait inlines properly" );
+}
+
+with_immutable {
+ {
+ my $foo = Foo->new(string => 'a');
+ is($foo->string, 'a');
+ $foo->string_append('b');
+ is($foo->string, 'ab');
+ }
+
+ {
+ my $foo = Foo->new(string => '');
+ $foo->{string} = ValueContainer->new(value => 'a');
+ is($foo->string, 'a');
+ $foo->string_append('b');
+ is($foo->string, 'ab');
+ }
+} 'Foo';
+
+done_testing;
diff --git a/t/native_traits/hash_coerce.t b/t/native_traits/hash_coerce.t
new file mode 100644
index 0000000..23d4093
--- /dev/null
+++ b/t/native_traits/hash_coerce.t
@@ -0,0 +1,148 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+{
+
+ package Foo;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ subtype 'UCHash', as 'HashRef[Str]', where {
+ !grep {/[a-z]/} values %{$_};
+ };
+
+ coerce 'UCHash', from 'HashRef[Str]', via {
+ $_ = uc $_ for values %{$_};
+ $_;
+ };
+
+ has hash => (
+ traits => ['Hash'],
+ is => 'rw',
+ isa => 'UCHash',
+ coerce => 1,
+ handles => {
+ set_key => 'set',
+ },
+ );
+
+ our @TriggerArgs;
+
+ has lazy => (
+ traits => ['Hash'],
+ is => 'rw',
+ isa => 'UCHash',
+ coerce => 1,
+ lazy => 1,
+ default => sub { { x => 'a' } },
+ handles => {
+ set_lazy => 'set',
+ },
+ trigger => sub { @TriggerArgs = @_ },
+ clearer => 'clear_lazy',
+ );
+}
+
+my $foo = Foo->new;
+
+{
+ $foo->hash( { x => 'A', y => 'B' } );
+
+ $foo->set_key( z => 'c' );
+
+ is_deeply(
+ $foo->hash, { x => 'A', y => 'B', z => 'C' },
+ 'set coerces the hash'
+ );
+}
+
+{
+ $foo->set_lazy( y => 'b' );
+
+ is_deeply(
+ $foo->lazy, { x => 'A', y => 'B' },
+ 'set coerces the hash - lazy'
+ );
+
+ is_deeply(
+ \@Foo::TriggerArgs,
+ [ $foo, { x => 'A', y => 'B' }, { x => 'A' } ],
+ 'trigger receives expected arguments'
+ );
+}
+
+{
+ package Thing;
+ use Moose;
+
+ has thing => (
+ is => 'ro',
+ isa => 'Str',
+ );
+}
+
+{
+ package Bar;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ class_type 'Thing';
+
+ coerce 'Thing'
+ => from 'Str'
+ => via { Thing->new( thing => $_ ) };
+
+ subtype 'HashRefOfThings'
+ => as 'HashRef[Thing]';
+
+ coerce 'HashRefOfThings'
+ => from 'HashRef[Str]'
+ => via {
+ my %new;
+ for my $k ( keys %{$_} ) {
+ $new{$k} = Thing->new( thing => $_->{$k} );
+ }
+ return \%new;
+ };
+
+ coerce 'HashRefOfThings'
+ => from 'Str'
+ => via { [ Thing->new( thing => $_ ) ] };
+
+ has hash => (
+ traits => ['Hash'],
+ is => 'rw',
+ isa => 'HashRefOfThings',
+ coerce => 1,
+ handles => {
+ set_hash => 'set',
+ get_hash => 'get',
+ },
+ );
+}
+
+{
+ my $bar = Bar->new( hash => { foo => 1, bar => 2 } );
+
+ is(
+ $bar->get_hash('foo')->thing, 1,
+ 'constructor coerces hash reference'
+ );
+
+ $bar->set_hash( baz => 3, quux => 4 );
+
+ is(
+ $bar->get_hash('baz')->thing, 3,
+ 'set coerces new hash values'
+ );
+
+ is(
+ $bar->get_hash('quux')->thing, 4,
+ 'set coerces new hash values'
+ );
+}
+
+
+done_testing;
diff --git a/t/native_traits/hash_subtypes.t b/t/native_traits/hash_subtypes.t
new file mode 100644
index 0000000..ff7eb96
--- /dev/null
+++ b/t/native_traits/hash_subtypes.t
@@ -0,0 +1,204 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+{
+ use Moose::Util::TypeConstraints;
+ use List::Util qw( sum );
+
+ subtype 'H1', as 'HashRef[Int]';
+ subtype 'H2', as 'HashRef', where { scalar keys %{$_} < 2 };
+ subtype 'H3', as 'HashRef[Int]',
+ where { ( sum( values %{$_} ) || 0 ) < 5 };
+
+ subtype 'H5', as 'HashRef';
+ coerce 'H5', from 'Str', via { { key => $_ } };
+
+ no Moose::Util::TypeConstraints;
+}
+
+{
+
+ package Foo;
+ use Moose;
+
+ has hash_int => (
+ traits => ['Hash'],
+ is => 'rw',
+ isa => 'HashRef[Int]',
+ handles => {
+ set_hash_int => 'set',
+ },
+ );
+
+ has h1 => (
+ traits => ['Hash'],
+ is => 'rw',
+ isa => 'H1',
+ handles => {
+ set_h1 => 'set',
+ },
+ );
+
+ has h2 => (
+ traits => ['Hash'],
+ is => 'rw',
+ isa => 'H2',
+ handles => {
+ set_h2 => 'set',
+ },
+ );
+
+ has h3 => (
+ traits => ['Hash'],
+ is => 'rw',
+ isa => 'H3',
+ handles => {
+ set_h3 => 'set',
+ },
+ );
+
+ has h4 => (
+ traits => ['Hash'],
+ is => 'rw',
+ isa => 'HashRef',
+ lazy => 1,
+ default => 'invalid',
+ clearer => '_clear_h4',
+ handles => {
+ get_h4 => 'get',
+ accessor_h4 => 'accessor',
+ },
+ );
+
+ has h5 => (
+ traits => ['Hash'],
+ is => 'rw',
+ isa => 'H5',
+ coerce => 1,
+ lazy => 1,
+ default => 'invalid',
+ clearer => '_clear_h5',
+ handles => {
+ get_h5 => 'get',
+ accessor_h5 => 'accessor',
+ },
+ );
+}
+
+my $foo = Foo->new;
+
+{
+ $foo->hash_int( {} );
+ is_deeply( $foo->hash_int, {}, "hash_int - correct contents" );
+
+ isnt( exception { $foo->set_hash_int( x => 'foo' ) }, undef, "hash_int - can't set wrong type" );
+ is_deeply( $foo->hash_int, {}, "hash_int - correct contents" );
+
+ $foo->set_hash_int( x => 1 );
+ is_deeply( $foo->hash_int, { x => 1 }, "hash_int - correct contents" );
+}
+
+{
+ isnt( exception { $foo->set_h1('foo') }, undef, "h1 - can't set onto undef" );
+
+ $foo->h1( {} );
+ is_deeply( $foo->h1, {}, "h1 - correct contents" );
+
+ isnt( exception { $foo->set_h1( x => 'foo' ) }, undef, "h1 - can't set wrong type" );
+
+ is_deeply( $foo->h1, {}, "h1 - correct contents" );
+
+ $foo->set_h1( x => 1 );
+ is_deeply( $foo->h1, { x => 1 }, "h1 - correct contents" );
+}
+
+{
+ isnt( exception { $foo->set_h2('foo') }, undef, "h2 - can't set onto undef" );
+
+ $foo->h2( {} );
+ is_deeply( $foo->h2, {}, "h2 - correct contents" );
+
+ $foo->set_h2( x => 'foo' );
+ is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" );
+
+ isnt( exception { $foo->set_h2( y => 'bar' ) }, undef, "h2 - can't set more than one element" );
+
+ is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" );
+}
+
+{
+ isnt( exception { $foo->set_h3(1) }, undef, "h3 - can't set onto undef" );
+
+ $foo->h3( {} );
+ is_deeply( $foo->h3, {}, "h3 - correct contents" );
+
+ isnt( exception { $foo->set_h3( x => 'foo' ) }, undef, "h3 - can't set non-int" );
+
+ isnt( exception { $foo->set_h3( x => 100 ) }, undef, "h3 - can't violate overall type constraint" );
+
+ is_deeply( $foo->h3, {}, "h3 - correct contents" );
+
+ $foo->set_h3( x => 1 );
+ is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" );
+
+ isnt( exception { $foo->set_h3( x => 100 ) }, undef, "h3 - can't violate overall type constraint" );
+
+ is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" );
+
+ $foo->set_h3( y => 3 );
+ is_deeply( $foo->h3, { x => 1, y => 3 }, "h3 - correct contents" );
+}
+
+{
+ my $expect
+ = qr/\QAttribute (h4) does not pass the type constraint because: Validation failed for 'HashRef' with value \E.*invalid.*/;
+
+ like(
+ exception { $foo->accessor_h4('key'); },
+ $expect,
+ 'invalid default is caught when trying to read via accessor'
+ );
+
+ like(
+ exception { $foo->accessor_h4( size => 42 ); },
+ $expect,
+ 'invalid default is caught when trying to write via accessor'
+ );
+
+ like(
+ exception { $foo->get_h4(42); },
+ $expect,
+ 'invalid default is caught when trying to get'
+ );
+}
+
+{
+ my $foo = Foo->new;
+
+ is(
+ $foo->accessor_h5('key'), 'invalid',
+ 'lazy default is coerced when trying to read via accessor'
+ );
+
+ $foo->_clear_h5;
+
+ $foo->accessor_h5( size => 42 );
+
+ is_deeply(
+ $foo->h5,
+ { key => 'invalid', size => 42 },
+ 'lazy default is coerced when trying to write via accessor'
+ );
+
+ $foo->_clear_h5;
+
+ is(
+ $foo->get_h5('key'), 'invalid',
+ 'lazy default is coerced when trying to get'
+ );
+}
+
+done_testing;
diff --git a/t/native_traits/hash_trigger.t b/t/native_traits/hash_trigger.t
new file mode 100644
index 0000000..1618f3c
--- /dev/null
+++ b/t/native_traits/hash_trigger.t
@@ -0,0 +1,54 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+{
+
+ package Foo;
+ use Moose;
+
+ our @TriggerArgs;
+
+ has hash => (
+ traits => ['Hash'],
+ is => 'rw',
+ isa => 'HashRef',
+ handles => {
+ delete_key => 'delete',
+ set_key => 'set',
+ },
+ clearer => 'clear_key',
+ trigger => sub { @TriggerArgs = @_ },
+ );
+}
+
+my $foo = Foo->new;
+
+{
+ $foo->hash( { x => 1, y => 2 } );
+
+ is_deeply(
+ \@Foo::TriggerArgs,
+ [ $foo, { x => 1, y => 2 } ],
+ 'trigger was called for normal writer'
+ );
+
+ $foo->set_key( z => 5 );
+
+ is_deeply(
+ \@Foo::TriggerArgs,
+ [ $foo, { x => 1, y => 2, z => 5 }, { x => 1, y => 2 } ],
+ 'trigger was called on set'
+ );
+
+ $foo->delete_key('y');
+
+ is_deeply(
+ \@Foo::TriggerArgs,
+ [ $foo, { x => 1, z => 5 }, { x => 1, y => 2, z => 5 } ],
+ 'trigger was called on delete'
+ );
+}
+
+done_testing;
diff --git a/t/native_traits/remove_attribute.t b/t/native_traits/remove_attribute.t
new file mode 100644
index 0000000..f1c7cbe
--- /dev/null
+++ b/t/native_traits/remove_attribute.t
@@ -0,0 +1,48 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+{
+ package MyHomePage;
+ use Moose;
+
+ has 'counter' => (
+ traits => ['Counter'],
+ is => 'ro',
+ isa => 'Int',
+ default => 0,
+ handles => {
+ inc_counter => 'inc',
+ dec_counter => 'dec',
+ reset_counter => 'reset',
+ }
+ );
+}
+
+my $page = MyHomePage->new();
+isa_ok( $page, 'MyHomePage' );
+
+can_ok( $page, $_ ) for qw[
+ counter
+ dec_counter
+ inc_counter
+ reset_counter
+];
+
+is( exception {
+ $page->meta->remove_attribute('counter');
+}, undef, '... removed the counter attribute okay' );
+
+ok( !$page->meta->has_attribute('counter'),
+ '... no longer has the attribute' );
+
+ok( !$page->can($_), "... our class no longer has the $_ method" ) for qw[
+ counter
+ dec_counter
+ inc_counter
+ reset_counter
+];
+
+done_testing;
diff --git a/t/native_traits/shallow_clone.t b/t/native_traits/shallow_clone.t
new file mode 100644
index 0000000..6f25a3f
--- /dev/null
+++ b/t/native_traits/shallow_clone.t
@@ -0,0 +1,42 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Scalar::Util qw(refaddr);
+
+{
+ package Foo;
+ use Moose;
+
+ has 'array' => (
+ traits => ['Array'],
+ is => 'ro',
+ handles => { array_clone => 'shallow_clone' },
+ );
+
+ has 'hash' => (
+ traits => ['Hash'],
+ is => 'ro',
+ handles => { hash_clone => 'shallow_clone' },
+ );
+
+ no Moose;
+}
+
+my $array = [ 1, 2, 3 ];
+my $hash = { a => 1, b => 2 };
+
+my $obj = Foo->new({
+ array => $array,
+ hash => $hash,
+});
+
+my $array_clone = $obj->array_clone;
+my $hash_clone = $obj->hash_clone;
+
+isnt(refaddr($array), refaddr($array_clone), "array clone refers to new copy");
+is_deeply($array_clone, $array, "...but contents are the same");
+isnt(refaddr($hash), refaddr($hash_clone), "hash clone refers to new copy");
+is_deeply($hash_clone, $hash, "...but contents are the same");
+
+done_testing;
diff --git a/t/native_traits/trait_array.t b/t/native_traits/trait_array.t
new file mode 100644
index 0000000..0435583
--- /dev/null
+++ b/t/native_traits/trait_array.t
@@ -0,0 +1,740 @@
+use strict;
+use warnings;
+
+use lib 't/lib';
+
+use Moose ();
+use Moose::Util::TypeConstraints;
+use NoInlineAttribute;
+use Test::More;
+use Test::Fatal;
+use Test::Moose;
+
+{
+ my %handles = (
+ count => 'count',
+ elements => 'elements',
+ is_empty => 'is_empty',
+ push => 'push',
+ push_curried =>
+ [ push => 42, 84 ],
+ unshift => 'unshift',
+ unshift_curried =>
+ [ unshift => 42, 84 ],
+ pop => 'pop',
+ shift => 'shift',
+ get => 'get',
+ get_curried => [ get => 1 ],
+ set => 'set',
+ set_curried_1 => [ set => 1 ],
+ set_curried_2 => [ set => ( 1, 98 ) ],
+ accessor => 'accessor',
+ accessor_curried_1 => [ accessor => 1 ],
+ accessor_curried_2 => [ accessor => ( 1, 90 ) ],
+ clear => 'clear',
+ delete => 'delete',
+ delete_curried => [ delete => 1 ],
+ insert => 'insert',
+ insert_curried => [ insert => ( 1, 101 ) ],
+ splice => 'splice',
+ splice_curried_1 => [ splice => 1 ],
+ splice_curried_2 => [ splice => 1, 2 ],
+ splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ],
+ sort => 'sort',
+ sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ],
+ sort_in_place => 'sort_in_place',
+ sort_in_place_curried =>
+ [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ],
+ map => 'map',
+ map_curried => [ map => ( sub { $_ + 1 } ) ],
+ grep => 'grep',
+ grep_curried => [ grep => ( sub { $_ < 5 } ) ],
+ first => 'first',
+ first_curried => [ first => ( sub { $_ % 2 } ) ],
+ first_index => 'first_index',
+ first_index_curried => [ first_index => ( sub { $_ % 2 } ) ],
+ join => 'join',
+ join_curried => [ join => '-' ],
+ shuffle => 'shuffle',
+ uniq => 'uniq',
+ reduce => 'reduce',
+ reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ],
+ natatime => 'natatime',
+ natatime_curried => [ natatime => 2 ],
+ );
+
+ my $name = 'Foo1';
+
+ sub build_class {
+ my %attr = @_;
+
+ my $class = Moose::Meta::Class->create(
+ $name++,
+ superclasses => ['Moose::Object'],
+ );
+
+ my @traits = 'Array';
+ push @traits, 'NoInlineAttribute'
+ if delete $attr{no_inline};
+
+ $class->add_attribute(
+ _values => (
+ traits => \@traits,
+ is => 'rw',
+ isa => 'ArrayRef[Int]',
+ default => sub { [] },
+ handles => \%handles,
+ clearer => '_clear_values',
+ %attr,
+ ),
+ );
+
+ return ( $class->name, \%handles );
+ }
+}
+
+{
+ package Overloader;
+
+ use overload
+ '&{}' => sub { ${ $_[0] } },
+ bool => sub {1};
+
+ sub new {
+ bless \$_[1], $_[0];
+ }
+}
+
+{
+ package OverloadStr;
+ use overload
+ q{""} => sub { ${ $_[0] } },
+ fallback => 1;
+
+ sub new {
+ my $class = shift;
+ my $str = shift;
+ return bless \$str, $class;
+ }
+}
+
+{
+ run_tests(build_class);
+ run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) );
+ run_tests( build_class( trigger => sub { } ) );
+ run_tests( build_class( no_inline => 1 ) );
+
+ # Will force the inlining code to check the entire arrayref when it is modified.
+ subtype 'MyArrayRef', as 'ArrayRef', where { 1 };
+
+ run_tests( build_class( isa => 'MyArrayRef' ) );
+
+ coerce 'MyArrayRef', from 'ArrayRef', via { $_ };
+
+ run_tests( build_class( isa => 'MyArrayRef', coerce => 1 ) );
+}
+
+sub run_tests {
+ my ( $class, $handles ) = @_;
+
+ can_ok( $class, $_ ) for sort keys %{$handles};
+
+ with_immutable {
+ my $obj = $class->new( _values => [ 10, 12, 42 ] );
+
+ is_deeply(
+ $obj->_values, [ 10, 12, 42 ],
+ 'values can be set in constructor'
+ );
+
+ ok( !$obj->is_empty, 'values is not empty' );
+ is( $obj->count, 3, 'count returns 3' );
+
+ like( exception { $obj->count(22) }, qr/Cannot call count with any arguments/, 'throws an error when passing an argument passed to count' );
+
+ is( exception { $obj->push( 1, 2, 3 ) }, undef, 'pushed three new values and lived' );
+
+ is( exception { $obj->push() }, undef, 'call to push without arguments lives' );
+
+ is( exception {
+ is( $obj->unshift( 101, 22 ), 8,
+ 'unshift returns size of the new array' );
+ }, undef, 'unshifted two values and lived' );
+
+ is_deeply(
+ $obj->_values, [ 101, 22, 10, 12, 42, 1, 2, 3 ],
+ 'unshift changed the value of the array in the object'
+ );
+
+ is( exception { $obj->unshift() }, undef, 'call to unshift without arguments lives' );
+
+ is( $obj->pop, 3, 'pop returns the last value in the array' );
+
+ is_deeply(
+ $obj->_values, [ 101, 22, 10, 12, 42, 1, 2 ],
+ 'pop changed the value of the array in the object'
+ );
+
+ like( exception { $obj->pop(42) }, qr/Cannot call pop with any arguments/, 'call to pop with arguments dies' );
+
+ is( $obj->shift, 101, 'shift returns the first value' );
+
+ like( exception { $obj->shift(42) }, qr/Cannot call shift with any arguments/, 'call to shift with arguments dies' );
+
+ is_deeply(
+ $obj->_values, [ 22, 10, 12, 42, 1, 2 ],
+ 'shift changed the value of the array in the object'
+ );
+
+ is_deeply(
+ [ $obj->elements ], [ 22, 10, 12, 42, 1, 2 ],
+ 'call to elements returns values as a list'
+ );
+
+ is(scalar($obj->elements), 6, 'elements accessor in scalar context returns the number of elements in the list');
+
+ like( exception { $obj->elements(22) }, qr/Cannot call elements with any arguments/, 'throws an error when passing an argument passed to elements' );
+
+ $obj->_values( [ 1, 2, 3 ] );
+
+ is( $obj->get(0), 1, 'get values at index 0' );
+ is( $obj->get(1), 2, 'get values at index 1' );
+ is( $obj->get(2), 3, 'get values at index 2' );
+ is( $obj->get_curried, 2, 'get_curried returns value at index 1' );
+
+ like( exception { $obj->get() }, qr/Cannot call get without at least 1 argument/, 'throws an error when get is called without any arguments' );
+
+ like( exception { $obj->get( {} ) }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' );
+
+ like( exception { $obj->get(2.2) }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' );
+
+ like( exception { $obj->get('foo') }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' );
+
+ like( exception { $obj->get_curried(2) }, qr/Cannot call get with more than 1 argument/, 'throws an error when get_curried is called with an argument' );
+
+ is( exception {
+ is( $obj->set( 1, 100 ), 100, 'set returns new value' );
+ }, undef, 'set value at index 1 lives' );
+
+ is( $obj->get(1), 100, 'get value at index 1 returns new value' );
+
+
+ like( exception { $obj->set( 1, 99, 42 ) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set is called with three arguments' );
+
+ is( exception { $obj->set_curried_1(99) }, undef, 'set_curried_1 lives' );
+
+ is( $obj->get(1), 99, 'get value at index 1 returns new value' );
+
+ like( exception { $obj->set_curried_1( 99, 42 ) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set_curried_1 is called with two arguments' );
+
+ is( exception { $obj->set_curried_2 }, undef, 'set_curried_2 lives' );
+
+ is( $obj->get(1), 98, 'get value at index 1 returns new value' );
+
+ like( exception { $obj->set_curried_2(42) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set_curried_2 is called with one argument' );
+
+ is(
+ $obj->accessor(1), 98,
+ 'accessor with one argument returns value at index 1'
+ );
+
+ is( exception {
+ is( $obj->accessor( 1 => 97 ), 97, 'accessor returns new value' );
+ }, undef, 'accessor as writer lives' );
+
+ like(
+ exception {
+ $obj->accessor;
+ },
+ qr/Cannot call accessor without at least 1 argument/,
+ 'throws an error when accessor is called without arguments'
+ );
+
+ is(
+ $obj->get(1), 97,
+ 'accessor set value at index 1'
+ );
+
+ like( exception { $obj->accessor( 1, 96, 42 ) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor is called with three arguments' );
+
+ is(
+ $obj->accessor_curried_1, 97,
+ 'accessor_curried_1 returns expected value when called with no arguments'
+ );
+
+ is( exception { $obj->accessor_curried_1(95) }, undef, 'accessor_curried_1 as writer lives' );
+
+ is(
+ $obj->get(1), 95,
+ 'accessor_curried_1 set value at index 1'
+ );
+
+ like( exception { $obj->accessor_curried_1( 96, 42 ) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor_curried_1 is called with two arguments' );
+
+ is( exception { $obj->accessor_curried_2 }, undef, 'accessor_curried_2 as writer lives' );
+
+ is(
+ $obj->get(1), 90,
+ 'accessor_curried_2 set value at index 1'
+ );
+
+ like( exception { $obj->accessor_curried_2(42) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor_curried_2 is called with one argument' );
+
+ is( exception { $obj->clear }, undef, 'clear lives' );
+
+ ok( $obj->is_empty, 'values is empty after call to clear' );
+
+ is( exception {
+ is( $obj->shift, undef,
+ 'shift returns undef on an empty array' );
+ }, undef, 'shifted from an empty array and lived' );
+
+ $obj->set( 0 => 42 );
+
+ like( exception { $obj->clear(50) }, qr/Cannot call clear with any arguments/, 'throws an error when clear is called with an argument' );
+
+ ok(
+ !$obj->is_empty,
+ 'values is not empty after failed call to clear'
+ );
+
+ like( exception { $obj->is_empty(50) }, qr/Cannot call is_empty with any arguments/, 'throws an error when is_empty is called with an argument' );
+
+ $obj->clear;
+ is(
+ $obj->push( 1, 5, 10, 42 ), 4,
+ 'pushed 4 elements, got number of elements in the array back'
+ );
+
+ is( exception {
+ is( $obj->delete(2), 10, 'delete returns deleted value' );
+ }, undef, 'delete lives' );
+
+ is_deeply(
+ $obj->_values, [ 1, 5, 42 ],
+ 'delete removed the specified element'
+ );
+
+ like( exception { $obj->delete( 2, 3 ) }, qr/Cannot call delete with more than 1 argument/, 'throws an error when delete is called with two arguments' );
+
+ is( exception { $obj->delete_curried }, undef, 'delete_curried lives' );
+
+ is_deeply(
+ $obj->_values, [ 1, 42 ],
+ 'delete removed the specified element'
+ );
+
+ like( exception { $obj->delete_curried(2) }, qr/Cannot call delete with more than 1 argument/, 'throws an error when delete_curried is called with one argument' );
+
+ is( exception { $obj->insert( 1, 21 ) }, undef, 'insert lives' );
+
+ is_deeply(
+ $obj->_values, [ 1, 21, 42 ],
+ 'insert added the specified element'
+ );
+
+ like( exception { $obj->insert( 1, 22, 44 ) }, qr/Cannot call insert with more than 2 arguments/, 'throws an error when insert is called with three arguments' );
+
+ is( exception {
+ is_deeply(
+ [ $obj->splice( 1, 0, 2, 3 ) ],
+ [],
+ 'return value of splice is empty list when not removing elements'
+ );
+ }, undef, 'splice lives' );
+
+ is_deeply(
+ $obj->_values, [ 1, 2, 3, 21, 42 ],
+ 'splice added the specified elements'
+ );
+
+ is( exception {
+ is_deeply(
+ [ $obj->splice( 1, 2, 99 ) ],
+ [ 2, 3 ],
+ 'splice returns list of removed values'
+ );
+ }, undef, 'splice lives' );
+
+ is_deeply(
+ $obj->_values, [ 1, 99, 21, 42 ],
+ 'splice added the specified elements'
+ );
+
+ like( exception { $obj->splice() }, qr/Cannot call splice without at least 1 argument/, 'throws an error when splice is called with no arguments' );
+
+ like( exception { $obj->splice( 1, 'foo', ) }, qr/The length argument passed to splice must be an integer/, 'throws an error when splice is called with an invalid length' );
+
+ is( exception { $obj->splice_curried_1( 2, 101 ) }, undef, 'splice_curried_1 lives' );
+
+ is_deeply(
+ $obj->_values, [ 1, 101, 42 ],
+ 'splice added the specified elements'
+ );
+
+ is( exception { $obj->splice_curried_2(102) }, undef, 'splice_curried_2 lives' );
+
+ is_deeply(
+ $obj->_values, [ 1, 102 ],
+ 'splice added the specified elements'
+ );
+
+ is( exception { $obj->splice_curried_all }, undef, 'splice_curried_all lives' );
+
+ is_deeply(
+ $obj->_values, [ 1, 3, 4, 5 ],
+ 'splice added the specified elements'
+ );
+
+ is_deeply(
+ scalar $obj->splice( 1, 2 ),
+ 4,
+ 'splice in scalar context returns last element removed'
+ );
+
+ is_deeply(
+ scalar $obj->splice( 1, 0, 42 ),
+ undef,
+ 'splice in scalar context returns undef when no elements are removed'
+ );
+
+ $obj->_values( [ 3, 9, 5, 22, 11 ] );
+
+ is_deeply(
+ [ $obj->sort ], [ 11, 22, 3, 5, 9 ],
+ 'sort returns sorted values'
+ );
+
+ is(scalar($obj->sort), 5, 'sort accessor in scalar context returns the number of elements in the list');
+
+ is_deeply(
+ [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ],
+ 'sort returns values sorted by provided function'
+ );
+
+ is(scalar($obj->sort( sub { $_[0] <=> $_[1] } )), 5, 'sort accessor with sort sub in scalar context returns the number of elements in the list');
+
+ like( exception { $obj->sort(1) }, qr/The argument passed to sort must be a code reference/, 'throws an error when passing a non coderef to sort' );
+
+ like( exception {
+ $obj->sort( sub { }, 27 );
+ }, qr/Cannot call sort with more than 1 argument/, 'throws an error when passing two arguments to sort' );
+
+ $obj->_values( [ 3, 9, 5, 22, 11 ] );
+
+ $obj->sort_in_place;
+
+ is_deeply(
+ $obj->_values, [ 11, 22, 3, 5, 9 ],
+ 'sort_in_place sorts values'
+ );
+
+ $obj->sort_in_place( sub { $_[0] <=> $_[1] } );
+
+ is_deeply(
+ $obj->_values, [ 3, 5, 9, 11, 22 ],
+ 'sort_in_place with function sorts values'
+ );
+
+ like( exception {
+ $obj->sort_in_place( 27 );
+ }, qr/The argument passed to sort_in_place must be a code reference/, 'throws an error when passing a non coderef to sort_in_place' );
+
+ like( exception {
+ $obj->sort_in_place( sub { }, 27 );
+ }, qr/Cannot call sort_in_place with more than 1 argument/, 'throws an error when passing two arguments to sort_in_place' );
+
+ $obj->_values( [ 3, 9, 5, 22, 11 ] );
+
+ $obj->sort_in_place_curried;
+
+ is_deeply(
+ $obj->_values, [ 22, 11, 9, 5, 3 ],
+ 'sort_in_place_curried sorts values'
+ );
+
+ like( exception { $obj->sort_in_place_curried(27) }, qr/Cannot call sort_in_place with more than 1 argument/, 'throws an error when passing one argument passed to sort_in_place_curried' );
+
+ $obj->_values( [ 1 .. 5 ] );
+
+ is_deeply(
+ [ $obj->map( sub { $_ + 1 } ) ],
+ [ 2 .. 6 ],
+ 'map returns the expected values'
+ );
+
+ like( exception { $obj->map }, qr/Cannot call map without at least 1 argument/, 'throws an error when passing no arguments to map' );
+
+ like( exception {
+ $obj->map( sub { }, 2 );
+ }, qr/Cannot call map with more than 1 argument/, 'throws an error when passing two arguments to map' );
+
+ like( exception { $obj->map( {} ) }, qr/The argument passed to map must be a code reference/, 'throws an error when passing a non coderef to map' );
+
+ $obj->_values( [ 1 .. 5 ] );
+
+ is_deeply(
+ [ $obj->map_curried ],
+ [ 2 .. 6 ],
+ 'map_curried returns the expected values'
+ );
+
+ like( exception {
+ $obj->map_curried( sub { } );
+ }, qr/Cannot call map with more than 1 argument/, 'throws an error when passing one argument passed to map_curried' );
+
+ $obj->_values( [ 2 .. 9 ] );
+
+ is_deeply(
+ [ $obj->grep( sub { $_ < 5 } ) ],
+ [ 2 .. 4 ],
+ 'grep returns the expected values'
+ );
+
+ like( exception { $obj->grep }, qr/Cannot call grep without at least 1 argument/, 'throws an error when passing no arguments to grep' );
+
+ like( exception {
+ $obj->grep( sub { }, 2 );
+ }, qr/Cannot call grep with more than 1 argument/, 'throws an error when passing two arguments to grep' );
+
+ like( exception { $obj->grep( {} ) }, qr/The argument passed to grep must be a code reference/, 'throws an error when passing a non coderef to grep' );
+
+ my $overloader = Overloader->new( sub { $_ < 5 } );
+ is_deeply(
+ [ $obj->grep($overloader) ],
+ [ 2 .. 4 ],
+ 'grep works with obj that overload code dereferencing'
+ );
+
+ is_deeply(
+ [ $obj->grep_curried ],
+ [ 2 .. 4 ],
+ 'grep_curried returns the expected values'
+ );
+
+ like( exception {
+ $obj->grep_curried( sub { } );
+ }, qr/Cannot call grep with more than 1 argument/, 'throws an error when passing one argument passed to grep_curried' );
+
+ $obj->_values( [ 2, 4, 22, 99, 101, 6 ] );
+
+ is(
+ $obj->first( sub { $_ % 2 } ),
+ 99,
+ 'first returns expected value'
+ );
+
+ like( exception { $obj->first }, qr/Cannot call first without at least 1 argument/, 'throws an error when passing no arguments to first' );
+
+ like( exception {
+ $obj->first( sub { }, 2 );
+ }, qr/Cannot call first with more than 1 argument/, 'throws an error when passing two arguments to first' );
+
+ like( exception { $obj->first( {} ) }, qr/The argument passed to first must be a code reference/, 'throws an error when passing a non coderef to first' );
+
+ is(
+ $obj->first_curried,
+ 99,
+ 'first_curried returns expected value'
+ );
+
+ like( exception {
+ $obj->first_curried( sub { } );
+ }, qr/Cannot call first with more than 1 argument/, 'throws an error when passing one argument passed to first_curried' );
+
+
+ is(
+ $obj->first_index( sub { $_ % 2 } ),
+ 3,
+ 'first_index returns expected value'
+ );
+
+ like( exception { $obj->first_index }, qr/Cannot call first_index without at least 1 argument/, 'throws an error when passing no arguments to first_index' );
+
+ like( exception {
+ $obj->first_index( sub { }, 2 );
+ }, qr/Cannot call first_index with more than 1 argument/, 'throws an error when passing two arguments to first_index' );
+
+ like( exception { $obj->first_index( {} ) }, qr/The argument passed to first_index must be a code reference/, 'throws an error when passing a non coderef to first_index' );
+
+ is(
+ $obj->first_index_curried,
+ 3,
+ 'first_index_curried returns expected value'
+ );
+
+ like( exception {
+ $obj->first_index_curried( sub { } );
+ }, qr/Cannot call first_index with more than 1 argument/, 'throws an error when passing one argument passed to first_index_curried' );
+
+
+ $obj->_values( [ 1 .. 4 ] );
+
+ is(
+ $obj->join('-'), '1-2-3-4',
+ 'join returns expected result'
+ );
+
+ is(
+ $obj->join(q{}), '1234',
+ 'join returns expected result when joining with empty string'
+ );
+
+ is(
+ $obj->join( OverloadStr->new(q{}) ), '1234',
+ 'join returns expected result when joining with empty string'
+ );
+
+ like( exception { $obj->join }, qr/Cannot call join without at least 1 argument/, 'throws an error when passing no arguments to join' );
+
+ like( exception { $obj->join( '-', 2 ) }, qr/Cannot call join with more than 1 argument/, 'throws an error when passing two arguments to join' );
+
+ like( exception { $obj->join( {} ) }, qr/The argument passed to join must be a string/, 'throws an error when passing a non string to join' );
+
+ is_deeply(
+ [ sort $obj->shuffle ],
+ [ 1 .. 4 ],
+ 'shuffle returns all values (cannot check for a random order)'
+ );
+
+ like( exception { $obj->shuffle(2) }, qr/Cannot call shuffle with any arguments/, 'throws an error when passing an argument passed to shuffle' );
+
+ $obj->_values( [ 1 .. 4, 2, 5, 3, 7, 3, 3, 1 ] );
+
+ is_deeply(
+ [ $obj->uniq ],
+ [ 1 .. 4, 5, 7 ],
+ 'uniq returns expected values (in original order)'
+ );
+
+ like( exception { $obj->uniq(2) }, qr/Cannot call uniq with any arguments/, 'throws an error when passing an argument passed to uniq' );
+
+ $obj->_values( [ 1 .. 5 ] );
+
+ is(
+ $obj->reduce( sub { $_[0] * $_[1] } ),
+ 120,
+ 'reduce returns expected value'
+ );
+
+ like( exception { $obj->reduce }, qr/Cannot call reduce without at least 1 argument/, 'throws an error when passing no arguments to reduce' );
+
+ like( exception {
+ $obj->reduce( sub { }, 2 );
+ }, qr/Cannot call reduce with more than 1 argument/, 'throws an error when passing two arguments to reduce' );
+
+ like( exception { $obj->reduce( {} ) }, qr/The argument passed to reduce must be a code reference/, 'throws an error when passing a non coderef to reduce' );
+
+ is(
+ $obj->reduce_curried,
+ 120,
+ 'reduce_curried returns expected value'
+ );
+
+ like( exception {
+ $obj->reduce_curried( sub { } );
+ }, qr/Cannot call reduce with more than 1 argument/, 'throws an error when passing one argument passed to reduce_curried' );
+
+ $obj->_values( [ 1 .. 6 ] );
+
+ my $it = $obj->natatime(2);
+ my @nat;
+ while ( my @v = $it->() ) {
+ push @nat, \@v;
+ }
+
+ is_deeply(
+ [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
+ \@nat,
+ 'natatime returns expected iterator'
+ );
+
+ @nat = ();
+ $obj->natatime( 2, sub { push @nat, [@_] } );
+
+ is_deeply(
+ [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
+ \@nat,
+ 'natatime with function returns expected value'
+ );
+
+ like( exception { $obj->natatime( {} ) }, qr/The n value passed to natatime must be an integer/, 'throws an error when passing a non integer to natatime' );
+
+ like( exception { $obj->natatime( 2, {} ) }, qr/The second argument passed to natatime must be a code reference/, 'throws an error when passing a non code ref to natatime' );
+
+ $it = $obj->natatime_curried();
+ @nat = ();
+ while ( my @v = $it->() ) {
+ push @nat, \@v;
+ }
+
+ is_deeply(
+ [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
+ \@nat,
+ 'natatime_curried returns expected iterator'
+ );
+
+ @nat = ();
+ $obj->natatime_curried( sub { push @nat, [@_] } );
+
+ is_deeply(
+ [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
+ \@nat,
+ 'natatime_curried with function returns expected value'
+ );
+
+ like( exception { $obj->natatime_curried( {} ) }, qr/The second argument passed to natatime must be a code reference/, 'throws an error when passing a non code ref to natatime_curried' );
+
+ if ( $class->meta->get_attribute('_values')->is_lazy ) {
+ my $obj = $class->new;
+
+ is( $obj->count, 2, 'count is 2 (lazy init)' );
+
+ $obj->_clear_values;
+
+ is_deeply(
+ [ $obj->elements ], [ 42, 84 ],
+ 'elements contains default with lazy init'
+ );
+
+ $obj->_clear_values;
+
+ $obj->push(2);
+
+ is_deeply(
+ $obj->_values, [ 42, 84, 2 ],
+ 'push works with lazy init'
+ );
+
+ $obj->_clear_values;
+
+ $obj->unshift( 3, 4 );
+
+ is_deeply(
+ $obj->_values, [ 3, 4, 42, 84 ],
+ 'unshift works with lazy init'
+ );
+ }
+ }
+ $class;
+}
+
+{
+ my ( $class, $handles ) = build_class( isa => 'ArrayRef' );
+ my $obj = $class->new;
+ with_immutable {
+ is(
+ exception { $obj->accessor( 0, undef ) },
+ undef,
+ 'can use accessor to set value to undef'
+ );
+ is(
+ exception { $obj->accessor_curried_1(undef) },
+ undef,
+ 'can use curried accessor to set value to undef'
+ );
+ }
+ $class;
+}
+
+done_testing;
diff --git a/t/native_traits/trait_bool.t b/t/native_traits/trait_bool.t
new file mode 100644
index 0000000..7a416da
--- /dev/null
+++ b/t/native_traits/trait_bool.t
@@ -0,0 +1,101 @@
+use strict;
+use warnings;
+
+use lib 't/lib';
+
+use Moose ();
+use Moose::Util::TypeConstraints;
+use NoInlineAttribute;
+use Test::More;
+use Test::Fatal;
+use Test::Moose;
+
+{
+ my %handles = (
+ illuminate => 'set',
+ darken => 'unset',
+ flip_switch => 'toggle',
+ is_dark => 'not',
+ );
+
+ my $name = 'Foo1';
+
+ sub build_class {
+ my %attr = @_;
+
+ my $class = Moose::Meta::Class->create(
+ $name++,
+ superclasses => ['Moose::Object'],
+ );
+
+ my @traits = 'Bool';
+ push @traits, 'NoInlineAttribute'
+ if delete $attr{no_inline};
+
+ $class->add_attribute(
+ is_lit => (
+ traits => \@traits,
+ is => 'rw',
+ isa => 'Bool',
+ default => 0,
+ handles => \%handles,
+ clearer => '_clear_is_list',
+ %attr,
+ ),
+ );
+
+ return ( $class->name, \%handles );
+ }
+}
+
+{
+ run_tests(build_class);
+ run_tests( build_class( lazy => 1 ) );
+ run_tests( build_class( trigger => sub { } ) );
+ run_tests( build_class( no_inline => 1 ) );
+
+ # Will force the inlining code to check the entire hashref when it is modified.
+ subtype 'MyBool', as 'Bool', where { 1 };
+
+ run_tests( build_class( isa => 'MyBool' ) );
+
+ coerce 'MyBool', from 'Bool', via { $_ };
+
+ run_tests( build_class( isa => 'MyBool', coerce => 1 ) );
+}
+
+sub run_tests {
+ my ( $class, $handles ) = @_;
+
+ can_ok( $class, $_ ) for sort keys %{$handles};
+
+ with_immutable {
+ my $obj = $class->new;
+
+ ok( $obj->illuminate, 'set returns true' );
+ ok( $obj->is_lit, 'set is_lit to 1 using ->illuminate' );
+ ok( !$obj->is_dark, 'check if is_dark does the right thing' );
+
+ like( exception { $obj->illuminate(1) }, qr/Cannot call set with any arguments/, 'set throws an error when an argument is passed' );
+
+ ok( !$obj->darken, 'unset returns false' );
+ ok( !$obj->is_lit, 'set is_lit to 0 using ->darken' );
+ ok( $obj->is_dark, 'check if is_dark does the right thing' );
+
+ like( exception { $obj->darken(1) }, qr/Cannot call unset with any arguments/, 'unset throws an error when an argument is passed' );
+
+ ok( $obj->flip_switch, 'toggle returns new value' );
+ ok( $obj->is_lit, 'toggle is_lit back to 1 using ->flip_switch' );
+ ok( !$obj->is_dark, 'check if is_dark does the right thing' );
+
+ like( exception { $obj->flip_switch(1) }, qr/Cannot call toggle with any arguments/, 'toggle throws an error when an argument is passed' );
+
+ $obj->flip_switch;
+ ok( !$obj->is_lit,
+ 'toggle is_lit back to 0 again using ->flip_switch' );
+ ok( $obj->is_dark, 'check if is_dark does the right thing' );
+ }
+ $class;
+}
+
+done_testing;
diff --git a/t/native_traits/trait_code.t b/t/native_traits/trait_code.t
new file mode 100644
index 0000000..1590963
--- /dev/null
+++ b/t/native_traits/trait_code.t
@@ -0,0 +1,113 @@
+use strict;
+use warnings;
+
+use lib 't/lib';
+
+use Moose ();
+use NoInlineAttribute;
+use Test::More;
+use Test::Moose;
+
+{
+ my $name = 'Foo1';
+
+ sub build_class {
+ my ( $attr1, $attr2, $attr3, $no_inline ) = @_;
+
+ my $class = Moose::Meta::Class->create(
+ $name++,
+ superclasses => ['Moose::Object'],
+ );
+
+ my @traits = 'Code';
+ push @traits, 'NoInlineAttribute'
+ if $no_inline;
+
+ $class->add_attribute(
+ callback => (
+ traits => \@traits,
+ isa => 'CodeRef',
+ required => 1,
+ handles => { 'invoke_callback' => 'execute' },
+ %{ $attr1 || {} },
+ )
+ );
+
+ $class->add_attribute(
+ callback_method => (
+ traits => \@traits,
+ isa => 'CodeRef',
+ required => 1,
+ handles => { 'invoke_method_callback' => 'execute_method' },
+ %{ $attr2 || {} },
+ )
+ );
+
+ $class->add_attribute(
+ multiplier => (
+ traits => \@traits,
+ isa => 'CodeRef',
+ required => 1,
+ handles => { 'multiply' => 'execute' },
+ %{ $attr3 || {} },
+ )
+ );
+
+ return $class->name;
+ }
+}
+
+{
+ my $i;
+
+ my %subs = (
+ callback => sub { ++$i },
+ callback_method => sub { shift->multiply(@_) },
+ multiplier => sub { $_[0] * 2 },
+ );
+
+ run_tests( build_class, \$i, \%subs );
+
+ run_tests( build_class( undef, undef, undef, 1 ), \$i, \%subs );
+
+ run_tests(
+ build_class(
+ {
+ lazy => 1, default => sub { $subs{callback} }
+ }, {
+ lazy => 1, default => sub { $subs{callback_method} }
+ }, {
+ lazy => 1, default => sub { $subs{multiplier} }
+ },
+ ),
+ \$i,
+ );
+}
+
+sub run_tests {
+ my ( $class, $iref, @args ) = @_;
+
+ ok(
+ !$class->can($_),
+ "Code trait didn't create reader method for $_"
+ ) for qw(callback callback_method multiplier);
+
+ with_immutable {
+ ${$iref} = 0;
+ my $obj = $class->new(@args);
+
+ $obj->invoke_callback;
+
+ is( ${$iref}, 1, '$i is 1 after invoke_callback' );
+
+ is(
+ $obj->invoke_method_callback(3), 6,
+ 'invoke_method_callback calls multiply with @_'
+ );
+
+ is( $obj->multiply(3), 6, 'multiple double value' );
+ }
+ $class;
+}
+
+done_testing;
diff --git a/t/native_traits/trait_counter.t b/t/native_traits/trait_counter.t
new file mode 100644
index 0000000..9a9901c
--- /dev/null
+++ b/t/native_traits/trait_counter.t
@@ -0,0 +1,170 @@
+use strict;
+use warnings;
+
+use lib 't/lib';
+
+use Moose ();
+use Moose::Util::TypeConstraints;
+use NoInlineAttribute;
+use Test::Fatal;
+use Test::More;
+use Test::Moose;
+
+{
+ my %handles = (
+ inc_counter => 'inc',
+ inc_counter_2 => [ inc => 2 ],
+ dec_counter => 'dec',
+ dec_counter_2 => [ dec => 2 ],
+ reset_counter => 'reset',
+ set_counter => 'set',
+ set_counter_42 => [ set => 42 ],
+ );
+
+ my $name = 'Foo1';
+
+ sub build_class {
+ my %attr = @_;
+
+ my $class = Moose::Meta::Class->create(
+ $name++,
+ superclasses => ['Moose::Object'],
+ );
+
+ my @traits = 'Counter';
+ push @traits, 'NoInlineAttribute'
+ if delete $attr{no_inline};
+
+ $class->add_attribute(
+ counter => (
+ traits => \@traits,
+ is => 'ro',
+ isa => 'Int',
+ default => 0,
+ handles => \%handles,
+ clearer => '_clear_counter',
+ %attr,
+ ),
+ );
+
+ return ( $class->name, \%handles );
+ }
+}
+
+{
+ run_tests(build_class);
+ run_tests( build_class( lazy => 1 ) );
+ run_tests( build_class( trigger => sub { } ) );
+ run_tests( build_class( no_inline => 1 ) );
+
+ # Will force the inlining code to check the entire hashref when it is modified.
+ subtype 'MyInt', as 'Int', where { 1 };
+
+ run_tests( build_class( isa => 'MyInt' ) );
+
+ coerce 'MyInt', from 'Int', via { $_ };
+
+ run_tests( build_class( isa => 'MyInt', coerce => 1 ) );
+}
+
+sub run_tests {
+ my ( $class, $handles ) = @_;
+
+ can_ok( $class, $_ ) for sort keys %{$handles};
+
+ with_immutable {
+ my $obj = $class->new();
+
+ is( $obj->counter, 0, '... got the default value' );
+
+ is( $obj->inc_counter, 1, 'inc returns new value' );
+ is( $obj->counter, 1, '... got the incremented value' );
+
+ is( $obj->inc_counter, 2, 'inc returns new value' );
+ is( $obj->counter, 2, '... got the incremented value (again)' );
+
+ like( exception { $obj->inc_counter( 1, 2 ) }, qr/Cannot call inc with more than 1 argument/, 'inc throws an error when two arguments are passed' );
+
+ is( $obj->dec_counter, 1, 'dec returns new value' );
+ is( $obj->counter, 1, '... got the decremented value' );
+
+ like( exception { $obj->dec_counter( 1, 2 ) }, qr/Cannot call dec with more than 1 argument/, 'dec throws an error when two arguments are passed' );
+
+ is( $obj->reset_counter, 0, 'reset returns new value' );
+ is( $obj->counter, 0, '... got the original value' );
+
+ like( exception { $obj->reset_counter(2) }, qr/Cannot call reset with any arguments/, 'reset throws an error when an argument is passed' );
+
+ is( $obj->set_counter(5), 5, 'set returns new value' );
+ is( $obj->counter, 5, '... set the value' );
+
+ like( exception { $obj->set_counter( 1, 2 ) }, qr/Cannot call set with more than 1 argument/, 'set throws an error when two arguments are passed' );
+
+ $obj->inc_counter(2);
+ is( $obj->counter, 7, '... increment by arg' );
+
+ $obj->dec_counter(5);
+ is( $obj->counter, 2, '... decrement by arg' );
+
+ $obj->inc_counter_2;
+ is( $obj->counter, 4, '... curried increment' );
+
+ $obj->dec_counter_2;
+ is( $obj->counter, 2, '... curried deccrement' );
+
+ $obj->set_counter_42;
+ is( $obj->counter, 42, '... curried set' );
+
+ if ( $class->meta->get_attribute('counter')->is_lazy ) {
+ my $obj = $class->new;
+
+ $obj->inc_counter;
+ is( $obj->counter, 1, 'inc increments - with lazy default' );
+
+ $obj->_clear_counter;
+
+ $obj->dec_counter;
+ is( $obj->counter, -1, 'dec decrements - with lazy default' );
+ }
+ }
+ $class;
+}
+
+{
+ package WithBuilder;
+ use Moose;
+
+ has nonlazy => (
+ traits => ['Counter'],
+ is => 'rw',
+ isa => 'Int',
+ builder => '_builder',
+ handles => {
+ reset_nonlazy => 'reset',
+ },
+ );
+
+ has lazy => (
+ traits => ['Counter'],
+ is => 'rw',
+ isa => 'Int',
+ lazy => 1,
+ builder => '_builder',
+ handles => {
+ reset_lazy => 'reset',
+ },
+ );
+
+ sub _builder { 1 }
+}
+
+for my $attr ('lazy', 'nonlazy') {
+ my $obj = WithBuilder->new;
+ is($obj->$attr, 1, "built properly");
+ $obj->$attr(0);
+ is($obj->$attr, 0, "can be manually set");
+ $obj->${\"reset_$attr"};
+ is($obj->$attr, 1, "reset resets it to its default value");
+}
+
+done_testing;
diff --git a/t/native_traits/trait_hash.t b/t/native_traits/trait_hash.t
new file mode 100644
index 0000000..c957108
--- /dev/null
+++ b/t/native_traits/trait_hash.t
@@ -0,0 +1,329 @@
+use strict;
+use warnings;
+
+use lib 't/lib';
+
+use Moose ();
+use Moose::Util::TypeConstraints;
+use NoInlineAttribute;
+use Test::Fatal;
+use Test::More;
+use Test::Moose;
+
+{
+ my %handles = (
+ option_accessor => 'accessor',
+ quantity => [ accessor => 'quantity' ],
+ clear_options => 'clear',
+ num_options => 'count',
+ delete_option => 'delete',
+ is_defined => 'defined',
+ options_elements => 'elements',
+ has_option => 'exists',
+ get_option => 'get',
+ has_no_options => 'is_empty',
+ keys => 'keys',
+ values => 'values',
+ key_value => 'kv',
+ set_option => 'set',
+ );
+
+ my $name = 'Foo1';
+
+ sub build_class {
+ my %attr = @_;
+
+ my $class = Moose::Meta::Class->create(
+ $name++,
+ superclasses => ['Moose::Object'],
+ );
+
+ my @traits = 'Hash';
+ push @traits, 'NoInlineAttribute'
+ if delete $attr{no_inline};
+
+ $class->add_attribute(
+ options => (
+ traits => \@traits,
+ is => 'rw',
+ isa => 'HashRef[Str]',
+ default => sub { {} },
+ handles => \%handles,
+ clearer => '_clear_options',
+ %attr,
+ ),
+ );
+
+ return ( $class->name, \%handles );
+ }
+}
+
+{
+ run_tests(build_class);
+ run_tests( build_class( lazy => 1, default => sub { { x => 1 } } ) );
+ run_tests( build_class( trigger => sub { } ) );
+ run_tests( build_class( no_inline => 1 ) );
+
+ # Will force the inlining code to check the entire hashref when it is modified.
+ subtype 'MyHashRef', as 'HashRef[Str]', where { 1 };
+
+ run_tests( build_class( isa => 'MyHashRef' ) );
+
+ coerce 'MyHashRef', from 'HashRef', via { $_ };
+
+ run_tests( build_class( isa => 'MyHashRef', coerce => 1 ) );
+}
+
+sub run_tests {
+ my ( $class, $handles ) = @_;
+
+ can_ok( $class, $_ ) for sort keys %{$handles};
+
+ with_immutable {
+ my $obj = $class->new( options => {} );
+
+ ok( $obj->has_no_options, '... we have no options' );
+ is( $obj->num_options, 0, '... we have no options' );
+
+ is_deeply( $obj->options, {}, '... no options yet' );
+ ok( !$obj->has_option('foo'), '... we have no foo option' );
+
+ is( exception {
+ is(
+ $obj->set_option( foo => 'bar' ),
+ 'bar',
+ 'set return single new value in scalar context'
+ );
+ }, undef, '... set the option okay' );
+
+ like(
+ exception { $obj->set_option( foo => 'bar', 'baz' ) },
+ qr/You must pass an even number of arguments to set/,
+ 'exception with odd number of arguments'
+ );
+
+ like(
+ exception { $obj->set_option( undef, 'bar' ) },
+ qr/Hash keys passed to set must be defined/,
+ 'exception when using undef as a key'
+ );
+
+ ok( $obj->is_defined('foo'), '... foo is defined' );
+
+ ok( !$obj->has_no_options, '... we have options' );
+ is( $obj->num_options, 1, '... we have 1 option(s)' );
+ ok( $obj->has_option('foo'), '... we have a foo option' );
+ is_deeply( $obj->options, { foo => 'bar' }, '... got options now' );
+
+ is( exception {
+ $obj->set_option( bar => 'baz' );
+ }, undef, '... set the option okay' );
+
+ is( $obj->num_options, 2, '... we have 2 option(s)' );
+ is_deeply(
+ $obj->options, { foo => 'bar', bar => 'baz' },
+ '... got more options now'
+ );
+
+ is( $obj->get_option('foo'), 'bar', '... got the right option' );
+
+ is_deeply(
+ [ $obj->get_option(qw(foo bar)) ], [qw(bar baz)],
+ "get multiple options at once"
+ );
+
+ is(
+ scalar( $obj->get_option(qw( foo bar)) ), "baz",
+ '... got last option in scalar context'
+ );
+
+ is( exception {
+ $obj->set_option( oink => "blah", xxy => "flop" );
+ }, undef, '... set the option okay' );
+
+ is( $obj->num_options, 4, "4 options" );
+ is_deeply(
+ [ $obj->get_option(qw(foo bar oink xxy)) ],
+ [qw(bar baz blah flop)], "get multiple options at once"
+ );
+
+ is( exception {
+ is( scalar $obj->delete_option('bar'), 'baz',
+ 'delete returns deleted value' );
+ }, undef, '... deleted the option okay' );
+
+ is( exception {
+ is_deeply(
+ [ $obj->delete_option( 'oink', 'xxy' ) ],
+ [ 'blah', 'flop' ],
+ 'delete returns all deleted values in list context'
+ );
+ }, undef, '... deleted multiple option okay' );
+
+ is( $obj->num_options, 1, '... we have 1 option(s)' );
+ is_deeply(
+ $obj->options, { foo => 'bar' },
+ '... got more options now'
+ );
+
+ $obj->clear_options;
+
+ is_deeply( $obj->options, {}, "... cleared options" );
+
+ is( exception {
+ $obj->quantity(4);
+ }, undef, '... options added okay with defaults' );
+
+ is( $obj->quantity, 4, 'reader part of curried accessor works' );
+
+ is(
+ $obj->option_accessor('quantity'), 4,
+ 'accessor as reader'
+ );
+
+ is_deeply(
+ $obj->options, { quantity => 4 },
+ '... returns what we expect'
+ );
+
+ $obj->option_accessor( size => 42 );
+
+ like(
+ exception {
+ $obj->option_accessor;
+ },
+ qr/Cannot call accessor without at least 1 argument/,
+ 'error when calling accessor with no arguments'
+ );
+
+ like(
+ exception { $obj->option_accessor( undef, 'bar' ) },
+ qr/Hash keys passed to accessor must be defined/,
+ 'exception when using undef as a key'
+ );
+
+ is_deeply(
+ $obj->options, { quantity => 4, size => 42 },
+ 'accessor as writer'
+ );
+
+ is( exception {
+ $class->new( options => { foo => 'BAR' } );
+ }, undef, '... good constructor params' );
+
+ isnt( exception {
+ $obj->set_option( bar => {} );
+ }, undef, '... could not add a hash ref where an string is expected' );
+
+ isnt( exception {
+ $class->new( options => { foo => [] } );
+ }, undef, '... bad constructor params' );
+
+ $obj->options( {} );
+
+ is_deeply(
+ [ $obj->set_option( oink => "blah", xxy => "flop" ) ],
+ [ 'blah', 'flop' ],
+ 'set returns newly set values in order of keys provided'
+ );
+
+ is_deeply(
+ [ sort $obj->keys ],
+ [ 'oink', 'xxy' ],
+ 'keys returns expected keys'
+ );
+
+ is_deeply(
+ [ sort $obj->values ],
+ [ 'blah', 'flop' ],
+ 'values returns expected values'
+ );
+
+ my @key_value = sort { $a->[0] cmp $b->[0] } $obj->key_value;
+ is_deeply(
+ \@key_value,
+ [
+ sort { $a->[0] cmp $b->[0] }[ 'xxy', 'flop' ],
+ [ 'oink', 'blah' ]
+ ],
+ '... got the right key value pairs'
+ )
+ or do {
+ require Data::Dumper;
+ diag( Data::Dumper::Dumper( \@key_value ) );
+ };
+
+ my %options_elements = $obj->options_elements;
+ is_deeply(
+ \%options_elements, {
+ 'oink' => 'blah',
+ 'xxy' => 'flop'
+ },
+ '... got the right hash elements'
+ );
+
+ if ( $class->meta->get_attribute('options')->is_lazy ) {
+ my $obj = $class->new;
+
+ $obj->set_option( y => 2 );
+
+ is_deeply(
+ $obj->options, { x => 1, y => 2 },
+ 'set_option with lazy default'
+ );
+
+ $obj->_clear_options;
+
+ ok(
+ $obj->has_option('x'),
+ 'key for x exists - lazy default'
+ );
+
+ $obj->_clear_options;
+
+ ok(
+ $obj->is_defined('x'),
+ 'key for x is defined - lazy default'
+ );
+
+ $obj->_clear_options;
+
+ is_deeply(
+ [ $obj->key_value ],
+ [ [ x => 1 ] ],
+ 'kv returns lazy default'
+ );
+
+ $obj->_clear_options;
+
+ $obj->option_accessor( y => 2 );
+
+ is_deeply(
+ [ sort $obj->keys ],
+ [ 'x', 'y' ],
+ 'accessor triggers lazy default generator'
+ );
+ }
+ }
+ $class;
+}
+
+{
+ my ( $class, $handles ) = build_class( isa => 'HashRef' );
+ my $obj = $class->new;
+ with_immutable {
+ is(
+ exception { $obj->option_accessor( 'foo', undef ) },
+ undef,
+ 'can use accessor to set value to undef'
+ );
+ is(
+ exception { $obj->quantity(undef) },
+ undef,
+ 'can use accessor to set value to undef'
+ );
+ }
+ $class;
+}
+
+done_testing;
diff --git a/t/native_traits/trait_number.t b/t/native_traits/trait_number.t
new file mode 100644
index 0000000..addf4bf
--- /dev/null
+++ b/t/native_traits/trait_number.t
@@ -0,0 +1,161 @@
+use strict;
+use warnings;
+
+use lib 't/lib';
+
+use Moose ();
+use Moose::Util::TypeConstraints;
+use NoInlineAttribute;
+use Test::Fatal;
+use Test::More;
+use Test::Moose;
+
+{
+ my %handles = (
+ abs => 'abs',
+ add => 'add',
+ inc => [ add => 1 ],
+ div => 'div',
+ cut_in_half => [ div => 2 ],
+ mod => 'mod',
+ odd => [ mod => 2 ],
+ mul => 'mul',
+ set => 'set',
+ sub => 'sub',
+ dec => [ sub => 1 ],
+ );
+
+ my $name = 'Foo1';
+
+ sub build_class {
+ my %attr = @_;
+
+ my $class = Moose::Meta::Class->create(
+ $name++,
+ superclasses => ['Moose::Object'],
+ );
+
+ my @traits = 'Number';
+ push @traits, 'NoInlineAttribute'
+ if delete $attr{no_inline};
+
+ $class->add_attribute(
+ integer => (
+ traits => \@traits,
+ is => 'ro',
+ isa => 'Int',
+ default => 5,
+ handles => \%handles,
+ clearer => '_clear_integer',
+ %attr,
+ ),
+ );
+
+ return ( $class->name, \%handles );
+ }
+}
+
+{
+ run_tests(build_class);
+ run_tests( build_class( lazy => 1 ) );
+ run_tests( build_class( trigger => sub { } ) );
+ run_tests( build_class( no_inline => 1 ) );
+
+ # Will force the inlining code to check the entire hashref when it is modified.
+ subtype 'MyInt', as 'Int', where { 1 };
+
+ run_tests( build_class( isa => 'MyInt' ) );
+
+ coerce 'MyInt', from 'Int', via { $_ };
+
+ run_tests( build_class( isa => 'MyInt', coerce => 1 ) );
+}
+
+sub run_tests {
+ my ( $class, $handles ) = @_;
+
+ can_ok( $class, $_ ) for sort keys %{$handles};
+
+ with_immutable {
+ my $obj = $class->new;
+
+ is( $obj->integer, 5, 'Default to five' );
+
+ is( $obj->add(10), 15, 'add returns new value' );
+
+ is( $obj->integer, 15, 'Add ten for fithteen' );
+
+ like( exception { $obj->add( 10, 2 ) }, qr/Cannot call add with more than 1 argument/, 'add throws an error when 2 arguments are passed' );
+
+ is( $obj->sub(3), 12, 'sub returns new value' );
+
+ is( $obj->integer, 12, 'Subtract three for 12' );
+
+ like( exception { $obj->sub( 10, 2 ) }, qr/Cannot call sub with more than 1 argument/, 'sub throws an error when 2 arguments are passed' );
+
+ is( $obj->set(10), 10, 'set returns new value' );
+
+ is( $obj->integer, 10, 'Set to ten' );
+
+ like( exception { $obj->set( 10, 2 ) }, qr/Cannot call set with more than 1 argument/, 'set throws an error when 2 arguments are passed' );
+
+ is( $obj->div(2), 5, 'div returns new value' );
+
+ is( $obj->integer, 5, 'divide by 2' );
+
+ like( exception { $obj->div( 10, 2 ) }, qr/Cannot call div with more than 1 argument/, 'div throws an error when 2 arguments are passed' );
+
+ is( $obj->mul(2), 10, 'mul returns new value' );
+
+ is( $obj->integer, 10, 'multiplied by 2' );
+
+ like( exception { $obj->mul( 10, 2 ) }, qr/Cannot call mul with more than 1 argument/, 'mul throws an error when 2 arguments are passed' );
+
+ is( $obj->mod(2), 0, 'mod returns new value' );
+
+ is( $obj->integer, 0, 'Mod by 2' );
+
+ like( exception { $obj->mod( 10, 2 ) }, qr/Cannot call mod with more than 1 argument/, 'mod throws an error when 2 arguments are passed' );
+
+ $obj->set(7);
+
+ $obj->mod(5);
+
+ is( $obj->integer, 2, 'Mod by 5' );
+
+ $obj->set(-1);
+
+ is( $obj->abs, 1, 'abs returns new value' );
+
+ like( exception { $obj->abs(10) }, qr/Cannot call abs with any arguments/, 'abs throws an error when an argument is passed' );
+
+ is( $obj->integer, 1, 'abs 1' );
+
+ $obj->set(12);
+
+ $obj->inc;
+
+ is( $obj->integer, 13, 'inc 12' );
+
+ $obj->dec;
+
+ is( $obj->integer, 12, 'dec 13' );
+
+ if ( $class->meta->get_attribute('integer')->is_lazy ) {
+ my $obj = $class->new;
+
+ $obj->add(2);
+
+ is( $obj->integer, 7, 'add with lazy default' );
+
+ $obj->_clear_integer;
+
+ $obj->mod(2);
+
+ is( $obj->integer, 1, 'mod with lazy default' );
+ }
+ }
+ $class;
+}
+
+done_testing;
diff --git a/t/native_traits/trait_string.t b/t/native_traits/trait_string.t
new file mode 100644
index 0000000..7f834f5
--- /dev/null
+++ b/t/native_traits/trait_string.t
@@ -0,0 +1,303 @@
+use strict;
+use warnings;
+
+use lib 't/lib';
+
+use Moose ();
+use Moose::Util::TypeConstraints;
+use NoInlineAttribute;
+use Test::More;
+use Test::Fatal;
+use Test::Moose;
+
+{
+ my %handles = (
+ inc => 'inc',
+ append => 'append',
+ append_curried => [ append => '!' ],
+ prepend => 'prepend',
+ prepend_curried => [ prepend => '-' ],
+ replace => 'replace',
+ replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ],
+ chop => 'chop',
+ chomp => 'chomp',
+ clear => 'clear',
+ match => 'match',
+ match_curried => [ match => qr/\D/ ],
+ length => 'length',
+ substr => 'substr',
+ substr_curried_1 => [ substr => (1) ],
+ substr_curried_2 => [ substr => ( 1, 3 ) ],
+ substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ],
+ );
+
+ my $name = 'Foo1';
+
+ sub build_class {
+ my %attr = @_;
+
+ my $class = Moose::Meta::Class->create(
+ $name++,
+ superclasses => ['Moose::Object'],
+ );
+
+ my @traits = 'String';
+ push @traits, 'NoInlineAttribute'
+ if delete $attr{no_inline};
+
+ $class->add_attribute(
+ _string => (
+ traits => \@traits,
+ is => 'rw',
+ isa => 'Str',
+ default => q{},
+ handles => \%handles,
+ clearer => '_clear_string',
+ %attr,
+ ),
+ );
+
+ return ( $class->name, \%handles );
+ }
+}
+
+{
+ run_tests(build_class);
+ run_tests( build_class( lazy => 1, default => q{} ) );
+ run_tests( build_class( trigger => sub { } ) );
+ run_tests( build_class( no_inline => 1 ) );
+
+ # Will force the inlining code to check the entire hashref when it is modified.
+ subtype 'MyStr', as 'Str', where { 1 };
+
+ run_tests( build_class( isa => 'MyStr' ) );
+
+ coerce 'MyStr', from 'Str', via { $_ };
+
+ run_tests( build_class( isa => 'MyStr', coerce => 1 ) );
+}
+
+sub run_tests {
+ my ( $class, $handles ) = @_;
+
+ can_ok( $class, $_ ) for sort keys %{$handles};
+
+ with_immutable {
+ my $obj = $class->new();
+
+ is( $obj->length, 0, 'length returns zero' );
+
+ $obj->_string('a');
+ is( $obj->length, 1, 'length returns 1 for new string' );
+
+ like( exception { $obj->length(42) }, qr/Cannot call length with any arguments/, 'length throws an error when an argument is passed' );
+
+ is( $obj->inc, 'b', 'inc returns new value' );
+ is( $obj->_string, 'b', 'a becomes b after inc' );
+
+ like( exception { $obj->inc(42) }, qr/Cannot call inc with any arguments/, 'inc throws an error when an argument is passed' );
+
+ is( $obj->append('foo'), 'bfoo', 'append returns new value' );
+ is( $obj->_string, 'bfoo', 'appended to the string' );
+
+ like( exception { $obj->append( 'foo', 2 ) }, qr/Cannot call append with more than 1 argument/, 'append throws an error when two arguments are passed' );
+
+ $obj->append_curried;
+ is( $obj->_string, 'bfoo!', 'append_curried appended to the string' );
+
+ like( exception { $obj->append_curried('foo') }, qr/Cannot call append with more than 1 argument/, 'append_curried throws an error when two arguments are passed' );
+
+ $obj->_string("has nl$/");
+ is( $obj->chomp, 1, 'chomp returns number of characters removed' );
+ is( $obj->_string, 'has nl', 'chomped string' );
+
+ is( $obj->chomp, 0, 'chomp returns number of characters removed' );
+ is(
+ $obj->_string, 'has nl',
+ 'chomp is a no-op when string has no line ending'
+ );
+
+ like( exception { $obj->chomp(42) }, qr/Cannot call chomp with any arguments/, 'chomp throws an error when an argument is passed' );
+
+ is( $obj->chop, 'l', 'chop returns character removed' );
+ is( $obj->_string, 'has n', 'chopped string' );
+
+ like( exception { $obj->chop(42) }, qr/Cannot call chop with any arguments/, 'chop throws an error when an argument is passed' );
+
+ $obj->_string('x');
+ is( $obj->prepend('bar'), 'barx', 'prepend returns new value' );
+ is( $obj->_string, 'barx', 'prepended to string' );
+
+ $obj->prepend_curried;
+ is( $obj->_string, '-barx', 'prepend_curried prepended to string' );
+
+ is(
+ $obj->replace( qr/([ao])/, sub { uc($1) } ),
+ '-bArx',
+ 'replace returns new value'
+ );
+
+ is(
+ $obj->_string, '-bArx',
+ 'substitution using coderef for replacement'
+ );
+
+ $obj->replace( qr/A/, 'X' );
+ is(
+ $obj->_string, '-bXrx',
+ 'substitution using string as replacement'
+ );
+
+ $obj->_string('foo');
+ $obj->replace( qr/oo/, q{} );
+
+ is( $obj->_string, 'f',
+ 'replace accepts an empty string as second argument' );
+
+ $obj->replace( q{}, 'a' );
+
+ is( $obj->_string, 'af',
+ 'replace accepts an empty string as first argument' );
+
+ like( exception { $obj->replace( {}, 'x' ) }, qr/The first argument passed to replace must be a string or regexp reference/, 'replace throws an error when the first argument is not a string or regexp' );
+
+ like( exception { $obj->replace( qr/x/, {} ) }, qr/The second argument passed to replace must be a string or code reference/, 'replace throws an error when the first argument is not a string or regexp' );
+
+ $obj->_string('Moosex');
+ $obj->replace_curried;
+ is( $obj->_string, 'MooseX', 'capitalize last' );
+
+ $obj->_string('abcdef');
+
+ is_deeply(
+ [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ],
+ 'match -barx against /[aq]/ returns matches'
+ );
+
+ is_deeply(
+ [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ],
+ 'match -barx against /[aq]/ returns matches'
+ );
+
+ ok(
+ scalar $obj->match('b'),
+ 'match with string as argument returns true'
+ );
+
+ ok(
+ scalar $obj->match(q{}),
+ 'match with empty string as argument returns true'
+ );
+
+ like( exception { $obj->match }, qr/Cannot call match without at least 1 argument/, 'match throws an error when no arguments are passed' );
+
+ like( exception { $obj->match( {} ) }, qr/The argument passed to match must be a string or regexp reference/, 'match throws an error when an invalid argument is passed' );
+
+ $obj->_string('1234');
+ ok( !$obj->match_curried, 'match_curried returns false' );
+
+ $obj->_string('one two three four');
+ ok( $obj->match_curried, 'match curried returns true' );
+
+ $obj->clear;
+ is( $obj->_string, q{}, 'clear' );
+
+ like( exception { $obj->clear(42) }, qr/Cannot call clear with any arguments/, 'clear throws an error when an argument is passed' );
+
+ $obj->_string('some long string');
+ is(
+ $obj->substr(1), 'ome long string',
+ 'substr as getter with one argument'
+ );
+
+ $obj->_string('some long string');
+ is(
+ $obj->substr( 1, 3 ), 'ome',
+ 'substr as getter with two arguments'
+ );
+
+ is(
+ $obj->substr( 1, 3, 'ong' ),
+ 'ome',
+ 'substr as setter returns replaced string'
+ );
+
+ is(
+ $obj->_string, 'song long string',
+ 'substr as setter with three arguments'
+ );
+
+ $obj->substr( 1, 3, '' );
+
+ is(
+ $obj->_string, 's long string',
+ 'substr as setter with three arguments, replacment is empty string'
+ );
+
+ like( exception { $obj->substr }, qr/Cannot call substr without at least 1 argument/, 'substr throws an error when no argumemts are passed' );
+
+ like( exception { $obj->substr( 1, 2, 3, 4 ) }, qr/Cannot call substr with more than 3 arguments/, 'substr throws an error when four argumemts are passed' );
+
+ like( exception { $obj->substr( {} ) }, qr/The first argument passed to substr must be an integer/, 'substr throws an error when first argument is not an integer' );
+
+ like( exception { $obj->substr( 1, {} ) }, qr/The second argument passed to substr must be an integer/, 'substr throws an error when second argument is not an integer' );
+
+ like( exception { $obj->substr( 1, 2, {} ) }, qr/The third argument passed to substr must be a string/, 'substr throws an error when third argument is not a string' );
+
+ $obj->_string('some long string');
+
+ is(
+ $obj->substr_curried_1, 'ome long string',
+ 'substr_curried_1 returns expected value'
+ );
+
+ is(
+ $obj->substr_curried_1(3), 'ome',
+ 'substr_curried_1 with one argument returns expected value'
+ );
+
+ $obj->substr_curried_1( 3, 'ong' );
+
+ is(
+ $obj->_string, 'song long string',
+ 'substr_curried_1 as setter with two arguments'
+ );
+
+ $obj->_string('some long string');
+
+ is(
+ $obj->substr_curried_2, 'ome',
+ 'substr_curried_2 returns expected value'
+ );
+
+ $obj->substr_curried_2('ong');
+
+ is(
+ $obj->_string, 'song long string',
+ 'substr_curried_2 as setter with one arguments'
+ );
+
+ $obj->_string('some long string');
+
+ $obj->substr_curried_3;
+
+ is(
+ $obj->_string, 'song long string',
+ 'substr_curried_3 as setter'
+ );
+
+ if ( $class->meta->get_attribute('_string')->is_lazy ) {
+ my $obj = $class->new;
+
+ $obj->append('foo');
+
+ is(
+ $obj->_string, 'foo',
+ 'append with lazy default'
+ );
+ }
+ }
+ $class;
+}
+
+done_testing;
View Lorry Controller Status