Commit | Line | Data |
0cfc2850 |
1 | #!/usr/bin/env perl |
2 | use strict; |
3 | use warnings; |
4 | use Test::More; |
5 | use Test::Exception; |
6 | use Test::Moose; |
7 | |
8 | { |
9 | package ValueContainer; |
10 | use Moose; |
11 | |
12 | has value => ( |
13 | is => 'rw', |
14 | ); |
15 | } |
16 | |
17 | { |
18 | package Foo::Meta::Instance; |
19 | use Moose::Role; |
20 | |
21 | around get_slot_value => sub { |
22 | my $orig = shift; |
23 | my $self = shift; |
24 | my ($instance, $slot_name) = @_; |
25 | my $value = $self->$orig(@_); |
26 | if ($value->isa('ValueContainer')) { |
27 | $value = $value->value; |
28 | } |
29 | return $value; |
30 | }; |
31 | |
32 | around inline_get_slot_value => sub { |
33 | my $orig = shift; |
34 | my $self = shift; |
35 | my $value = $self->$orig(@_); |
36 | return q[do {] . "\n" |
37 | . q[ my $value = ] . $value . q[;] . "\n" |
38 | . q[ if ($value->isa('ValueContainer')) {] . "\n" |
39 | . q[ $value = $value->value;] . "\n" |
40 | . q[ }] . "\n" |
41 | . q[ $value] . "\n" |
42 | . q[}]; |
43 | }; |
44 | |
45 | sub inline_get_is_lvalue { 0 } |
46 | } |
47 | |
48 | { |
49 | package Foo; |
50 | use Moose; |
51 | Moose::Util::MetaRole::apply_metaroles( |
52 | for => __PACKAGE__, |
53 | class_metaroles => { |
54 | instance => ['Foo::Meta::Instance'], |
55 | } |
56 | ); |
57 | |
58 | ::lives_ok { |
59 | has foo => ( |
60 | traits => ['String'], |
61 | is => 'ro', |
62 | isa => 'Str', |
63 | default => '', |
64 | handles => { |
65 | append_foo => 'append', |
66 | }, |
67 | ); |
68 | } |
69 | } |
70 | |
71 | with_immutable { |
72 | { |
73 | my $foo = Foo->new(foo => 'a'); |
74 | is($foo->foo, 'a'); |
75 | $foo->append_foo('b'); |
76 | is($foo->foo, 'ab'); |
77 | } |
78 | |
79 | { |
80 | my $foo = Foo->new(foo => ''); |
81 | $foo->{foo} = ValueContainer->new(value => 'a'); |
82 | is($foo->foo, 'a'); |
83 | $foo->append_foo('b'); |
84 | is($foo->foo, 'ab'); |
85 | } |
86 | } 'Foo'; |
87 | |
88 | done_testing; |