1use strict; 2use warnings; 3use Test::More; 4 5use XS::APItest; 6 7our $sv = 'Moo'; 8my $foo = 'affe'; 9my $bar = 'tiger'; 10 11ok !mg_find_foo($sv), 'no foo magic yet'; 12ok !mg_find_bar($sv), 'no bar magic yet'; 13 14sv_magic_foo($sv, $foo); 15is mg_find_foo($sv), $foo, 'foo magic attached'; 16ok !mg_find_bar($sv), '... but still no bar magic'; 17 18{ 19 local $sv = 'Emu'; 20 sv_magic_foo($sv, $foo); 21 is mg_find_foo($sv), $foo, 'foo magic attached to localized value'; 22 ok !mg_find_bar($sv), '... but still no bar magic to localized value'; 23} 24 25sv_magic_bar($sv, $bar); 26is mg_find_foo($sv), $foo, 'foo magic still attached'; 27is mg_find_bar($sv), $bar, '... and bar magic is there too'; 28 29sv_unmagic_foo($sv); 30ok !mg_find_foo($sv), 'foo magic removed'; 31is mg_find_bar($sv), $bar, '... but bar magic is still there'; 32 33sv_unmagic_bar($sv); 34ok !mg_find_foo($sv), 'foo magic still removed'; 35ok !mg_find_bar($sv), '... and bar magic is removed too'; 36 37sv_magic_baz($sv, $bar); 38is mg_find_baz($sv), $bar, 'baz magic attached'; 39ok !mg_find_bar($sv), ''; 40{ 41 local $sv = 'Emu'; 42 ok !mg_find_baz($sv), ''; 43} 44 45is(test_get_vtbl(), 0, 'get_vtbl(-1) returns NULL'); 46 47eval { sv_magic(\!0, $foo) }; 48is $@, "", 'PERL_MAGIC_ext is permitted on read-only things'; 49 50# assigning to an array/hash with only set magic should call that magic 51 52{ 53 my (@a, %h, $i); 54 55 sv_magic_myset(\@a, $i); 56 sv_magic_myset(\%h, $i); 57 58 $i = 0; 59 @a = (1,2); 60 is($i, 2, "array with set magic"); 61 62 $i = 0; 63 @a = (); 64 is($i, 0, "array () with set magic"); 65 66 { 67 local $TODO = "HVs don't call set magic - not sure if should"; 68 69 $i = 0; 70 %h = qw(a 1 b 2); 71 is($i, 4, "hash with set magic"); 72 } 73 74 $i = 0; 75 %h = qw(); 76 is($i, 0, "hash () with set magic"); 77} 78 79{ 80 # check if set magic triggered by av_store() via aassign results in 81 # unreferenced scalars being freed. IOW, results in a double store 82 # without a corresponding refcount bump. If things work properly this 83 # should not warn. If there is an issue it will. 84 my @warn; 85 local $SIG{__WARN__}= sub { push @warn, $_[0] }; 86 { 87 my (@a, $i); 88 sv_magic_myset_dies(\@a, $i); 89 eval { 90 $i = 0; 91 @a = (1); 92 }; 93 } 94 is(0+@warn, 0, 95 "If AV set magic dies via aassign it should not warn about double free"); 96 @warn = (); 97 { 98 my (@a, $i, $j); 99 sv_magic_myset_dies(\@a, $i); 100 eval { 101 $j = "blorp"; 102 my_av_store(\@a,0,$j); 103 }; 104 105 # Evaluate this boolean as a separate statement, so the two 106 # temporary \ refs are freed before we start comparing reference 107 # counts 108 my $is_same_SV = \$a[0] == \$j; 109 110 if ($is_same_SV) { 111 # in this case we expect to have 2 refcounts, 112 # one from $a[0] and one from $j itself. 113 is( sv_refcnt($j), 2, 114 "\$a[0] is \$j, so refcount(\$j) should be 2"); 115 } else { 116 # Note this branch isn't exercised. Whether by design 117 # or not. I leave it here because it is a possible valid 118 # outcome. It is marked TODO so if we start going down 119 # this path we do so knowingly. 120 diag "av_store has changed behavior - please review this test"; 121 TODO:{ 122 local $TODO = "av_store bug stores even if it dies during magic"; 123 # in this case we expect to have only 1 refcount, 124 # from $j itself. 125 is( sv_refcnt($j), 1, 126 "\$a[0] is not \$j, so refcount(\$j) should be 1"); 127 } 128 } 129 } 130 is(0+@warn, 0, 131 "AV set magic that dies via av_store should not warn about double free"); 132} 133 134done_testing; 135