t/070_native_traits/103_custom_instance.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More;
   5 use Test::Fatal;
   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     ::is( ::exception {
  59         has array => (
  60             traits  => ['Array'],
  61             isa     => 'ArrayRef',
  62             default => sub { [] },
  63             handles => {
  64                 array_count              => 'count',
  65                 array_elements           => 'elements',
  66                 array_is_empty           => 'is_empty',
  67                 array_push               => 'push',
  68                 array_push_curried       => [ push => 42, 84 ],
  69                 array_unshift            => 'unshift',
  70                 array_unshift_curried    => [ unshift => 42, 84 ],
  71                 array_pop                => 'pop',
  72                 array_shift              => 'shift',
  73                 array_get                => 'get',
  74                 array_get_curried        => [ get => 1 ],
  75                 array_set                => 'set',
  76                 array_set_curried_1      => [ set => 1 ],
  77                 array_set_curried_2      => [ set => ( 1, 98 ) ],
  78                 array_accessor           => 'accessor',
  79                 array_accessor_curried_1 => [ accessor => 1 ],
  80                 array_accessor_curried_2 => [ accessor => ( 1, 90 ) ],
  81                 array_clear              => 'clear',
  82                 array_delete             => 'delete',
  83                 array_delete_curried     => [ delete => 1 ],
  84                 array_insert             => 'insert',
  85                 array_insert_curried     => [ insert => ( 1, 101 ) ],
  86                 array_splice             => 'splice',
  87                 array_splice_curried_1   => [ splice => 1 ],
  88                 array_splice_curried_2   => [ splice => 1, 2 ],
  89                 array_splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ],
  90                 array_sort               => 'sort',
  91                 array_sort_curried       =>
  92                     [ sort => ( sub { $_[1] <=> $_[0] } ) ],
  93                 array_sort_in_place      => 'sort_in_place',
  94                 array_sort_in_place_curried =>
  95                     [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ],
  96                 array_map                => 'map',
  97                 array_map_curried        => [ map => ( sub { $_ + 1 } ) ],
  98                 array_grep               => 'grep',
  99                 array_grep_curried       => [ grep => ( sub { $_ < 5 } ) ],
 100                 array_first              => 'first',
 101                 array_first_curried      => [ first => ( sub { $_ % 2 } ) ],
 102                 array_join               => 'join',
 103                 array_join_curried       => [ join => '-' ],
 104                 array_shuffle            => 'shuffle',
 105                 array_uniq               => 'uniq',
 106                 array_reduce             => 'reduce',
 107                 array_reduce_curried     =>
 108                     [ reduce => ( sub { $_[0] * $_[1] } ) ],
 109                 array_natatime           => 'natatime',
 110                 array_natatime_curried   => [ natatime => 2 ],
 111             },
 112         );
 113     }, undef, "native array trait inlines properly" );
 114
 115     ::is( ::exception {
 116         has bool => (
 117             traits  => ['Bool'],
 118             isa     => 'Bool',
 119             default => 0,
 120             handles => {
 121                 bool_illuminate  => 'set',
 122                 bool_darken      => 'unset',
 123                 bool_flip_switch => 'toggle',
 124                 bool_is_dark     => 'not',
 125             },
 126         );
 127     }, undef, "native bool trait inlines properly" );
 128
 129     ::is( ::exception {
 130         has code => (
 131             traits  => ['Code'],
 132             isa     => 'CodeRef',
 133             default => sub { sub { } },
 134             handles => {
 135                 code_execute        => 'execute',
 136                 code_execute_method => 'execute_method',
 137             },
 138         );
 139     }, undef, "native code trait inlines properly" );
 140
 141     ::is( ::exception {
 142         has counter => (
 143             traits  => ['Counter'],
 144             isa     => 'Int',
 145             default => 0,
 146             handles => {
 147                 inc_counter    => 'inc',
 148                 inc_counter_2  => [ inc => 2 ],
 149                 dec_counter    => 'dec',
 150                 dec_counter_2  => [ dec => 2 ],
 151                 reset_counter  => 'reset',
 152                 set_counter    => 'set',
 153                 set_counter_42 => [ set => 42 ],
 154             },
 155         );
 156     }, undef, "native counter trait inlines properly" );
 157
 158     ::is( ::exception {
 159         has hash => (
 160             traits  => ['Hash'],
 161             isa     => 'HashRef',
 162             default => sub { {} },
 163             handles => {
 164                 hash_option_accessor  => 'accessor',
 165                 hash_quantity         => [ accessor => 'quantity' ],
 166                 hash_clear_options    => 'clear',
 167                 hash_num_options      => 'count',
 168                 hash_delete_option    => 'delete',
 169                 hash_is_defined       => 'defined',
 170                 hash_options_elements => 'elements',
 171                 hash_has_option       => 'exists',
 172                 hash_get_option       => 'get',
 173                 hash_has_no_options   => 'is_empty',
 174                 hash_key_value        => 'kv',
 175                 hash_set_option       => 'set',
 176             },
 177         );
 178     }, undef, "native hash trait inlines properly" );
 179
 180     ::is( ::exception {
 181         has number => (
 182             traits  => ['Number'],
 183             isa     => 'Num',
 184             default => 0,
 185             handles => {
 186                 num_abs         => 'abs',
 187                 num_add         => 'add',
 188                 num_inc         => [ add => 1 ],
 189                 num_div         => 'div',
 190                 num_cut_in_half => [ div => 2 ],
 191                 num_mod         => 'mod',
 192                 num_odd         => [ mod => 2 ],
 193                 num_mul         => 'mul',
 194                 num_set         => 'set',
 195                 num_sub         => 'sub',
 196                 num_dec         => [ sub => 1 ],
 197             },
 198         );
 199     }, undef, "native number trait inlines properly" );
 200
 201     ::is( ::exception {
 202         has string => (
 203             traits  => ['String'],
 204             is      => 'ro',
 205             isa     => 'Str',
 206             default => '',
 207             handles => {
 208                 string_inc             => 'inc',
 209                 string_append          => 'append',
 210                 string_append_curried  => [ append => '!' ],
 211                 string_prepend         => 'prepend',
 212                 string_prepend_curried => [ prepend => '-' ],
 213                 string_replace         => 'replace',
 214                 string_replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ],
 215                 string_chop            => 'chop',
 216                 string_chomp           => 'chomp',
 217                 string_clear           => 'clear',
 218                 string_match           => 'match',
 219                 string_match_curried    => [ match  => qr/\D/ ],
 220                 string_length           => 'length',
 221                 string_substr           => 'substr',
 222                 string_substr_curried_1 => [ substr => (1) ],
 223                 string_substr_curried_2 => [ substr => ( 1, 3 ) ],
 224                 string_substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ],
 225             },
 226         );
 227     }, undef, "native string trait inlines properly" );
 228 }
 229
 230 with_immutable {
 231     {
 232         my $foo = Foo->new(string => 'a');
 233         is($foo->string, 'a');
 234         $foo->string_append('b');
 235         is($foo->string, 'ab');
 236     }
 237
 238     {
 239         my $foo = Foo->new(string => '');
 240         $foo->{string} = ValueContainer->new(value => 'a');
 241         is($foo->string, 'a');
 242         $foo->string_append('b');
 243         is($foo->string, 'ab');
 244     }
 245 } 'Foo';
 246
 247 done_testing;