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

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