1#!perl -T 2 3use strict; 4use warnings; 5 6use Config qw/%Config/; 7 8use Test::More tests => (2 * 14 + 2) + 2 * (2 * 8 + 4) + 3 + 1; 9 10use Variable::Magic qw/wizard cast dispell MGf_COPY/; 11 12use lib 't/lib'; 13use Variable::Magic::TestWatcher; 14 15my $is_5130_release = ($] == 5.013 && !$Config{git_describe}) ? 1 : 0; 16 17my $wiz = init_watcher 18 [ qw/get set len clear free copy dup local fetch store exists delete/ ], 19 'scalar'; 20 21my $n = int rand 1000; 22my $a = $n; 23 24watch { cast $a, $wiz } { }, 'cast'; 25 26my $b; 27# $b has to be set inside the block for the test to pass on 5.8.3 and lower 28watch { $b = $a } { get => 1 }, 'assign to'; 29is $b, $n, 'scalar: assign to correctly'; 30 31$b = watch { "X${a}Y" } { get => 1 }, 'interpolate'; 32is $b, "X${n}Y", 'scalar: interpolate correctly'; 33 34$b = watch { \$a } { }, 'reference'; 35 36watch { $a = 123; () } { set => 1 }, 'assign to'; 37 38watch { ++$a; () } { get => 1, set => 1 }, 'increment'; 39 40watch { --$a; () } { get => 1, set => 1 }, 'decrement'; 41 42watch { $a *= 1.5; () } { get => 1, set => 1 }, 'multiply in place'; 43 44watch { $a /= 1.5; () } { get => 1, set => 1 }, 'divide in place'; 45 46watch { 47 my $b = $n; 48 watch { cast $b, $wiz } { }, 'cast 2'; 49} { free => 1 }, 'scope end'; 50 51watch { undef $a } { set => 1 }, 'undef'; 52 53watch { dispell $a, $wiz } { }, 'dispell'; 54 55# Array element 56 57my @a = (7, 8, 9); 58 59watch { cast $a[1], $wiz } { }, 'array element: cast'; 60 61watch { $a[1] = 6; () } { set => 1 }, 'array element: set'; 62 63$b = watch { $a[1] } { get => ($is_5130_release ? 2 : 1) },'array element: get'; 64is $b, 6, 'scalar: array element: get correctly'; 65 66watch { $a[0] = 5 } { }, 'array element: set other'; 67 68$b = watch { $a[2] } { }, 'array element: get other'; 69is $b, 9, 'scalar: array element: get other correctly'; 70 71$b = watch { exists $a[1] } { }, 'array element: exists'; 72is $b, 1, 'scalar: array element: exists correctly'; 73 74# $b has to be set inside the block for the test to pass on 5.8.3 and lower 75watch { $b = delete $a[1] } { get => 1, free => ($] > 5.008005 ? 1 : 0) }, 'array element: delete'; 76is $b, 6, 'scalar: array element: delete correctly'; 77 78watch { $a[1] = 4 } { }, 'array element: set after delete'; 79 80# Hash element 81 82my %h = (a => 7, b => 8); 83 84watch { cast $h{b}, $wiz } { }, 'hash element: cast'; 85 86watch { $h{b} = 6; () } { set => 1 }, 'hash element: set'; 87 88$b = watch { $h{b} } { get => ($is_5130_release ? 2 : 1) }, 'hash element: get'; 89is $b, 6, 'scalar: hash element: get correctly'; 90 91watch { $h{a} = 5 } { }, 'hash element: set other'; 92 93$b = watch { $h{a} } { }, 'hash element: get other'; 94is $b, 5, 'scalar: hash element: get other correctly'; 95 96$b = watch { exists $h{b} } { }, 'hash element: exists'; 97is $b, 1, 'scalar: hash element: exists correctly'; 98 99$b = watch { delete $h{b} } { get => 1, free => 1 }, 'hash element: delete'; 100is $b, 6, 'scalar: hash element: delete correctly'; 101 102watch { $h{b} = 4 } { }, 'hash element: set after delete'; 103 104SKIP: { 105 my $SKIP; 106 107 unless (MGf_COPY) { 108 $SKIP = 'No copy magic for this perl'; 109 } else { 110 eval "use Tie::Array"; 111 $SKIP = 'Tie::Array required to test clear magic on tied array values' if $@; 112 } 113 114 skip $SKIP => 3 if $SKIP; 115 diag "Using Tie::Array $Tie::Array::VERSION" if defined $Tie::Array::VERSION; 116 117 tie my @a, 'Tie::StdArray'; 118 $a[0] = $$; 119 120 eval { 121 cast @a, wizard copy => sub { cast $_[3], $wiz; () }; 122 }; 123 is $@, '', 'cast copy magic on tied array'; 124 125 watch { delete $a[0] } [ qw/get clear free/ ], 'delete from tied array'; 126} 127