ext/Hash-Util-FieldHash/t/05_perlhook.t

   1 #!perl
   2 use strict; use warnings;
   3 use Test::More;
   4 my $n_tests;
   5
   6 use Hash::Util::FieldHash;
   7 use Scalar::Util qw( weaken);
   8
   9 # The functions in Hash::Util::FieldHash
  10 # _test_uvar_get, _test_uvar_get and _test_uvar_both
  11
  12 # _test_uvar_get( $anyref, \ $counter) makes the referent of $anyref
  13 # "uvar"-magical with get magic only.  $counter is reset if the magic
  14 # could be established.  $counter will be incremented each time the
  15 # magic "get" function is called.
  16
  17 # _test_uvar_set does the same for "set" magic.  _test_uvar_both
  18 # sets both magic functions identically.  Both use the same counter.
  19
  20 # magical weak ref (patch to sv.c)
  21 {
  22     my( $magref, $counter);
  23
  24     $counter = 123;
  25     Hash::Util::FieldHash::_test_uvar_set( \ $magref, \ $counter);
  26     is( $counter, 0, "got magical scalar");
  27
  28     my $ref = [];
  29     $magref = $ref;
  30     is( $counter, 1, "store triggers magic");
  31
  32     weaken $magref;
  33     is( $counter, 1, "weaken doesn't trigger magic");
  34
  35     { my $x = $magref }
  36     is( $counter, 1, "read doesn't trigger magic");
  37
  38     undef $ref;
  39     is( $counter, 2, "ref expiry triggers magic (weakref patch worked)");
  40
  41     is( $magref, undef, "weak ref works normally");
  42
  43     # same, but overwrite weakref before expiry
  44     $counter = 0;
  45     weaken( $magref = $ref = []);
  46     is( $counter, 1, "setup for overwrite");
  47
  48     $magref = my $other_ref = [];
  49     is( $counter, 2, "overwrite triggers");
  50
  51     undef $ref;
  52     is( $counter, 2, "ref expiry doesn't trigger after overwrite");
  53
  54     is( $magref, $other_ref, "weak ref doesn't kill overwritten value");
  55
  56     BEGIN { $n_tests += 10 }
  57 }
  58
  59 # magical hash (patches to mg.c and hv.c)
  60 {
  61     # the hook is only sensitive if the set function is NULL
  62     my ( %h, $counter);
  63     $counter = 123;
  64     Hash::Util::FieldHash::_test_uvar_get( \ %h, \ $counter);
  65     is( $counter, 0, "got magical hash");
  66
  67     %h = ( abc => 123);
  68     is( $counter, 1, "list assign triggers");
  69
  70
  71     my $x = keys %h;
  72     is( $counter, 1, "scalar keys doesn't trigger");
  73     is( $x, 1, "there is one key");
  74
  75     my (@x) = keys %h;
  76     is( $counter, 1, "list keys doesn't trigger");
  77     is( "@x", "abc", "key is correct");
  78
  79     $x = values %h;
  80     is( $counter, 1, "scalar values doesn't trigger");
  81     is( $x, 1, "the value is correct");
  82
  83     (@x) = values %h;
  84     is( $counter, 1, "list values doesn't trigger");
  85     is( "@x", "123", "the value is correct");
  86
  87     $x = each %h;
  88     is( $counter, 1, "scalar each doesn't trigger");
  89     is( $x, "abc", "the return is correct");
  90
  91     $x = each %h;
  92     is( $counter, 1, "scalar each doesn't trigger");
  93     is( $x, undef, "the return is correct");
  94
  95     (@x) = each %h;
  96     is( $counter, 1, "list each doesn't trigger");
  97     is( "@x", "abc 123", "the return is correct");
  98
  99     $x = %h;
 100     is( $counter, 1, "hash in scalar context doesn't trigger");
 101     like( $x, qr!^\d+/\d+$!, "correct result");
 102
 103     (@x) = %h;
 104     is( $counter, 1, "hash in list context doesn't trigger");
 105     is( "@x", "abc 123", "correct result");
 106
 107
 108     $h{ def} = 456;
 109     is( $counter, 2, "lvalue assign triggers");
 110
 111     (@x) = sort %h;
 112     is( $counter, 2, "hash in list context doesn't trigger");
 113     is( "@x", "123 456 abc def", "correct result");
 114
 115     exists $h{ def};
 116     is( $counter, 3, "good exists triggers");
 117
 118     exists $h{ xyz};
 119     is( $counter, 4, "bad exists triggers");
 120
 121     delete $h{ def};
 122     is( $counter, 5, "good delete triggers");
 123
 124     (@x) = sort %h;
 125     is( $counter, 5, "hash in list context doesn't trigger");
 126     is( "@x", "123 abc", "correct result");
 127
 128     delete $h{ xyz};
 129     is( $counter, 6, "bad delete triggers");
 130
 131     (@x) = sort %h;
 132     is( $counter, 6, "hash in list context doesn't trigger");
 133     is( "@x", "123 abc", "correct result");
 134
 135     $x = $h{ abc};
 136     is( $counter, 7, "good read triggers");
 137
 138     $x = $h{ xyz};
 139     is( $counter, 8, "bad read triggers");
 140
 141     (@x) = sort %h;
 142     is( $counter, 8, "hash in list context doesn't trigger");
 143     is( "@x", "123 abc", "correct result");
 144
 145
 146     bless \ %h;
 147     is( $counter, 8, "bless doesn't trigger");
 148
 149     bless \ %h, 'xyz';
 150     is( $counter, 8, "bless doesn't trigger");
 151
 152     # see that normal set magic doesn't trigger (identity condition)
 153     my %i;
 154     Hash::Util::FieldHash::_test_uvar_set( \ %i, \ $counter);
 155     is( $counter, 0, "got magical hash");
 156
 157     %i = ( abc => 123);
 158     $i{ def} = 456;
 159     exists $i{ def};
 160     exists $i{ xyz};
 161     delete $i{ def};
 162     delete $i{ xyz};
 163     $x = $i{ abc};
 164     $x = $i{ xyz};
 165     $x = keys %i;
 166     () = keys %i;
 167     $x = values %i;
 168     () = values %i;
 169     $x = each %i;
 170     () = each %i;
 171
 172     is( $counter, 0, "normal set magic never triggers");
 173
 174     bless \ %i, 'abc';
 175     is( $counter, 1, "...except with bless");
 176
 177     # see that magic with both set and get doesn't trigger
 178     $counter = 123;
 179     my %j;
 180     Hash::Util::FieldHash::_test_uvar_same( \ %j, \ $counter);
 181     is( $counter, 0, "got magical hash");
 182
 183     %j = ( abc => 123);
 184     $j{ def} = 456;
 185     exists $j{ def};
 186     exists $j{ xyz};
 187     delete $j{ def};
 188     delete $j{ xyz};
 189     $x = $j{ abc};
 190     $x = $j{ xyz};
 191     $x = keys %j;
 192     () = keys %j;
 193     $x = values %j;
 194     () = values %j;
 195     $x = each %j;
 196     () = each %j;
 197
 198     is( $counter, 0, "get/set magic never triggers");
 199
 200     bless \ %j, 'abc';
 201     is( $counter, 1, "...except for bless");
 202
 203     BEGIN { $n_tests += 43 }
 204 }
 205
 206 BEGIN { plan tests => $n_tests }
 207