t/op/caller.pl

   1 # tests shared between t/op/caller.t and ext/XS-APItest/t/op.t
   2
   3 use strict;
   4 use warnings;
   5
   6 sub dooot {
   7     is(hint_fetch('dooot'), undef);
   8     is(hint_fetch('thikoosh'), undef);
   9     ok(!hint_exists('dooot'));
  10     ok(!hint_exists('thikoosh'));
  11     if ($::testing_caller) {
  12         is(hint_fetch('dooot', 1), 54);
  13     }
  14     BEGIN {
  15         $^H{dooot} = 42;
  16     }
  17     is(hint_fetch('dooot'), 6 * 7);
  18     if ($::testing_caller) {
  19         is(hint_fetch('dooot', 1), 54);
  20     }
  21
  22     BEGIN {
  23         $^H{dooot} = undef;
  24     }
  25     is(hint_fetch('dooot'), undef);
  26     ok(hint_exists('dooot'));
  27
  28     BEGIN {
  29         delete $^H{dooot};
  30     }
  31     is(hint_fetch('dooot'), undef);
  32     ok(!hint_exists('dooot'));
  33     if ($::testing_caller) {
  34         is(hint_fetch('dooot', 1), 54);
  35     }
  36 }
  37 {
  38     is(hint_fetch('dooot'), undef);
  39     is(hint_fetch('thikoosh'), undef);
  40     BEGIN {
  41         $^H{dooot} = 1;
  42         $^H{thikoosh} = "SKREECH";
  43     }
  44     if ($::testing_caller) {
  45         is(hint_fetch('dooot'), 1);
  46     }
  47     is(hint_fetch('thikoosh'), "SKREECH");
  48
  49     BEGIN {
  50         $^H{dooot} = 42;
  51     }
  52     {
  53         {
  54             BEGIN {
  55                 $^H{dooot} = 6 * 9;
  56             }
  57             is(hint_fetch('dooot'), 54);
  58             is(hint_fetch('thikoosh'), "SKREECH");
  59             {
  60                 BEGIN {
  61                     delete $^H{dooot};
  62                 }
  63                 is(hint_fetch('dooot'), undef);
  64                 ok(!hint_exists('dooot'));
  65                 is(hint_fetch('thikoosh'), "SKREECH");
  66             }
  67             dooot();
  68         }
  69         is(hint_fetch('dooot'), 6 * 7);
  70         is(hint_fetch('thikoosh'), "SKREECH");
  71     }
  72     is(hint_fetch('dooot'), 6 * 7);
  73     is(hint_fetch('thikoosh'), "SKREECH");
  74 }
  75
  76 print "# which now works inside evals\n";
  77
  78 {
  79     BEGIN {
  80         $^H{dooot} = 42;
  81     }
  82     is(hint_fetch('dooot'), 6 * 7);
  83
  84     eval "is(hint_fetch('dooot'), 6 * 7); 1" or die $@;
  85
  86     eval <<'EOE' or die $@;
  87     is(hint_fetch('dooot'), 6 * 7);
  88     eval "is(hint_fetch('dooot'), 6 * 7); 1" or die $@;
  89     BEGIN {
  90         $^H{dooot} = 54;
  91     }
  92     is(hint_fetch('dooot'), 54);
  93     eval "is(hint_fetch('dooot'), 54); 1" or die $@;
  94     eval 'BEGIN { $^H{dooot} = -1; }; 1' or die $@;
  95     is(hint_fetch('dooot'), 54);
  96     eval "is(hint_fetch('dooot'), 54); 1" or die $@;
  97 EOE
  98 }
  99
 100 {
 101     BEGIN {
 102         $^H{dooot} = "FIP\0FOP\0FIDDIT\0FAP";
 103     }
 104     is(hint_fetch('dooot'), "FIP\0FOP\0FIDDIT\0FAP", "Can do embedded 0 bytes");
 105
 106     BEGIN {
 107         $^H{dooot} = chr 256;
 108     }
 109     is(hint_fetch('dooot'), chr 256, "Can do Unicode");
 110
 111     BEGIN {
 112         $^H{dooot} = -42;
 113     }
 114     is(hint_fetch('dooot'), -42, "Can do IVs");
 115
 116     BEGIN {
 117         $^H{dooot} = ~0;
 118     }
 119     cmp_ok(hint_fetch('dooot'), '>', 42, "Can do UVs");
 120 }
 121
 122 {
 123     my ($k1, $k2, $k3, $k4);
 124     BEGIN {
 125         $k1 = chr 163;
 126         $k2 = $k1;
 127         $k3 = chr 256;
 128         $k4 = $k3;
 129         utf8::upgrade $k2;
 130         utf8::encode $k4;
 131
 132         $^H{$k1} = 1;
 133         $^H{$k2} = 2;
 134         $^H{$k3} = 3;
 135         $^H{$k4} = 4;
 136     }
 137
 138
 139     is(hint_fetch($k1), 2, "UTF-8 or not, it's the same");
 140     if ($::testing_caller) {
 141         # Perl_refcounted_he_fetch() insists that you have the key correctly
 142         # normalised for the way hashes store them. As this one isn't
 143         # normalised down to bytes, it won't t work with
 144         # Perl_refcounted_he_fetch()
 145         is(hint_fetch($k2), 2, "UTF-8 or not, it's the same");
 146     }
 147     is(hint_fetch($k3), 3, "Octect sequences and UTF-8 are distinct");
 148     is(hint_fetch($k4), 4, "Octect sequences and UTF-8 are distinct");
 149 }
 150
 151 {
 152     my ($k1, $k2, $k3);
 153     BEGIN {
 154         ($k1, $k2, $k3) = ("\0", "\0\0", "\0\0\0");
 155         $^H{$k1} = 1;
 156         $^H{$k2} = 2;
 157         $^H{$k3} = 3;
 158     }
 159
 160     is(hint_fetch($k1), 1, "Keys with the same hash value don't clash");
 161     is(hint_fetch($k2), 2, "Keys with the same hash value don't clash");
 162     is(hint_fetch($k3), 3, "Keys with the same hash value don't clash");
 163
 164     BEGIN {
 165         $^H{$k1} = "a";
 166         $^H{$k2} = "b";
 167         $^H{$k3} = "c";
 168     }
 169
 170     is(hint_fetch($k1), "a", "Keys with the same hash value don't clash");
 171     is(hint_fetch($k2), "b", "Keys with the same hash value don't clash");
 172     is(hint_fetch($k3), "c", "Keys with the same hash value don't clash");
 173 }
 174
 175 1;