This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Comprehensive regression tests for Perl_refcounted_he_fetch().
authorNicholas Clark <nick@ccl4.org>
Mon, 29 May 2006 22:58:46 +0000 (22:58 +0000)
committerNicholas Clark <nick@ccl4.org>
Mon, 29 May 2006 22:58:46 +0000 (22:58 +0000)
Fix a bug due to the fact that Perl's typedef'd "bool" type isn't
actually boolean.

p4raw-id: //depot/perl@28335

MANIFEST
ext/XS/APItest/APItest.xs
ext/XS/APItest/t/op.t [new file with mode: 0644]
hv.c
t/op/caller.pl [new file with mode: 0644]
t/op/caller.t

index b527b9c..85b1492 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1221,6 +1221,7 @@ ext/XS/APItest/t/call.t           XS::APItest extension
 ext/XS/APItest/t/exception.t   XS::APItest extension
 ext/XS/APItest/t/hash.t                XS::APItest extension
 ext/XS/APItest/t/my_cxt.t      XS::APItest: test MY_CXT interface
+ext/XS/APItest/t/hash.t                XS::APItest: tests for OP related APIs
 ext/XS/APItest/t/printf.t      XS::APItest extension
 ext/XS/APItest/t/push.t                XS::APItest extension
 ext/XS/Typemap/Makefile.PL     XS::Typemap extension
@@ -3364,6 +3365,7 @@ t/op/auto.t                       See if autoincrement et all work
 t/op/avhv.t                    See if pseudo-hashes work
 t/op/bless.t                   See if bless works
 t/op/bop.t                     See if bitops work
+t/op/caller.pl                 Tests shared between caller.t and XS op.t
 t/op/caller.t                  See if caller() works
 t/op/chars.t                   See if character escapes work
 t/op/chdir.t                   See if chdir works
index ff0a8fb..bcf46ee 100644 (file)
@@ -240,6 +240,36 @@ test_share_unshare_pvn(input)
        unsharepvn(p, len, hash);
        OUTPUT:
        RETVAL
+
+bool
+refcounted_he_exists(key, level=0)
+       SV *key
+       IV level
+       CODE:
+       if (level) {
+           croak("level must be zero, not %"IVdf, level);
+       }
+       RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
+                                          key, NULL, 0, 0, 0)
+                 != &PL_sv_placeholder);
+       OUTPUT:
+       RETVAL
+
+
+SV *
+refcounted_he_fetch(key, level=0)
+       SV *key
+       IV level
+       CODE:
+       if (level) {
+           croak("level must be zero, not %"IVdf, level);
+       }
+       RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
+                                         NULL, 0, 0, 0);
+       SvREFCNT_inc(RETVAL);
+       OUTPUT:
+       RETVAL
+       
        
 =pod
 
diff --git a/ext/XS/APItest/t/op.t b/ext/XS/APItest/t/op.t
new file mode 100644 (file)
index 0000000..29a6409
--- /dev/null
@@ -0,0 +1,25 @@
+#!perl -w
+
+BEGIN {
+  chdir 't' if -d 't';
+  @INC = '../lib';
+  push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+  require Config; import Config;
+  if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+    # Look, I'm using this fully-qualified variable more than once!
+    my $arch = $MacPerl::Architecture;
+    print "1..0 # Skip: XS::APItest was not built\n";
+    exit 0;
+  }
+}
+
+use strict;
+use utf8;
+use Test::More 'no_plan';
+
+use_ok('XS::APItest');
+
+*hint_exists = *hint_exists = \&XS::APItest::Hash::refcounted_he_exists;
+*hint_fetch = *hint_fetch = \&XS::APItest::Hash::refcounted_he_fetch;
+
+require './op/caller.pl';
diff --git a/hv.c b/hv.c
index 750988c..eee7de0 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -2709,12 +2709,16 @@ Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv,
     /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness
        of your key has to exactly match that which is stored.  */
     SV *value = &PL_sv_placeholder;
+    bool is_utf8;
 
     if (keysv) {
        if (flags & HVhek_FREEKEY)
            Safefree(key);
        key = SvPV_const(keysv, klen);
        flags = 0;
+       is_utf8 = (SvUTF8(keysv) != 0);
+    } else {
+       is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
     }
 
     if (!hash) {
@@ -2733,6 +2737,8 @@ Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv,
            continue;
        if (memNE(REF_HE_KEY(chain),key,klen))
            continue;
+       if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8))
+           continue;
 #else
        if (hash != HEK_HASH(chain->refcounted_he_hek))
            continue;
@@ -2740,6 +2746,8 @@ Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv,
            continue;
        if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen))
            continue;
+       if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek))
+           continue;
 #endif
 
        value = sv_2mortal(refcounted_he_value(chain));
@@ -2775,7 +2783,7 @@ Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent,
     char flags;
     STRLEN key_offset;
     U32 hash;
-    bool is_utf8 = SvUTF8(key);
+    bool is_utf8 = SvUTF8(key) ? TRUE : FALSE;
 
     if (SvPOK(value)) {
        value_type = HVrhek_PV;
diff --git a/t/op/caller.pl b/t/op/caller.pl
new file mode 100644 (file)
index 0000000..b0545f0
--- /dev/null
@@ -0,0 +1,175 @@
+# tests shared between t/op/caller.t and ext/XS/APItest/t/op.t
+
+use strict;
+use warnings;
+
+sub dooot {
+    is(hint_fetch('dooot'), undef);
+    is(hint_fetch('thikoosh'), undef);
+    ok(!hint_exists('dooot'));
+    ok(!hint_exists('thikoosh'));
+    if ($::testing_caller) {
+       is(hint_fetch('dooot', 1), 54);
+    }
+    BEGIN {
+       $^H{dooot} = 42;
+    }
+    is(hint_fetch('dooot'), 6 * 7);
+    if ($::testing_caller) {
+       is(hint_fetch('dooot', 1), 54);
+    }
+
+    BEGIN {
+       $^H{dooot} = undef;
+    }
+    is(hint_fetch('dooot'), undef);
+    ok(hint_exists('dooot'));
+
+    BEGIN {
+       delete $^H{dooot};
+    }
+    is(hint_fetch('dooot'), undef);
+    ok(!hint_exists('dooot'));
+    if ($::testing_caller) {
+       is(hint_fetch('dooot', 1), 54);
+    }
+}
+{
+    is(hint_fetch('dooot'), undef);
+    is(hint_fetch('thikoosh'), undef);
+    BEGIN {
+       $^H{dooot} = 1;
+       $^H{thikoosh} = "SKREECH";
+    }
+    if ($::testing_caller) {
+       is(hint_fetch('dooot'), 1);
+    }
+    is(hint_fetch('thikoosh'), "SKREECH");
+
+    BEGIN {
+       $^H{dooot} = 42;
+    }
+    {
+       {
+           BEGIN {
+               $^H{dooot} = 6 * 9;
+           }
+           is(hint_fetch('dooot'), 54);
+           is(hint_fetch('thikoosh'), "SKREECH");
+           {
+               BEGIN {
+                   delete $^H{dooot};
+               }
+               is(hint_fetch('dooot'), undef);
+               ok(!hint_exists('dooot'));
+               is(hint_fetch('thikoosh'), "SKREECH");
+           }
+           dooot();
+       }
+       is(hint_fetch('dooot'), 6 * 7);
+       is(hint_fetch('thikoosh'), "SKREECH");
+    }
+    is(hint_fetch('dooot'), 6 * 7);
+    is(hint_fetch('thikoosh'), "SKREECH");
+}
+
+print "# which now works inside evals\n";
+
+{
+    BEGIN {
+       $^H{dooot} = 42;
+    }
+    is(hint_fetch('dooot'), 6 * 7);
+
+    eval "is(hint_fetch('dooot'), 6 * 7); 1" or die $@;
+
+    eval <<'EOE' or die $@;
+    is(hint_fetch('dooot'), 6 * 7);
+    eval "is(hint_fetch('dooot'), 6 * 7); 1" or die $@;
+    BEGIN {
+       $^H{dooot} = 54;
+    }
+    is(hint_fetch('dooot'), 54);
+    eval "is(hint_fetch('dooot'), 54); 1" or die $@;
+    eval 'BEGIN { $^H{dooot} = -1; }; 1' or die $@;
+    is(hint_fetch('dooot'), 54);
+    eval "is(hint_fetch('dooot'), 54); 1" or die $@;
+EOE
+}
+
+{
+    BEGIN {
+       $^H{dooot} = "FIP\0FOP\0FIDDIT\0FAP";
+    }
+    is(hint_fetch('dooot'), "FIP\0FOP\0FIDDIT\0FAP", "Can do embedded 0 bytes");
+
+    BEGIN {
+       $^H{dooot} = chr 256;
+    }
+    is(hint_fetch('dooot'), chr 256, "Can do Unicode");
+
+    BEGIN {
+       $^H{dooot} = -42;
+    }
+    is(hint_fetch('dooot'), -42, "Can do IVs");
+
+    BEGIN {
+       $^H{dooot} = ~0;
+    }
+    cmp_ok(hint_fetch('dooot'), '>', 42, "Can do UVs");
+}
+
+{
+    my ($k1, $k2, $k3, $k4);
+    BEGIN {
+       $k1 = chr 163;
+       $k2 = $k1;
+       $k3 = chr 256;
+       $k4 = $k3;
+       utf8::upgrade $k2;
+       utf8::encode $k4;
+
+       $^H{$k1} = 1;
+       $^H{$k2} = 2;
+       $^H{$k3} = 3;
+       $^H{$k4} = 4;
+    }
+
+       
+    is(hint_fetch($k1), 2, "UTF-8 or not, it's the same");
+    if ($::testing_caller) {
+       # Perl_refcounted_he_fetch() insists that you have the key correctly
+       # normalised for the way hashes store them. As this one isn't
+       # normalised down to bytes, it won't t work with
+       # Perl_refcounted_he_fetch()
+       is(hint_fetch($k2), 2, "UTF-8 or not, it's the same");
+    }
+    is(hint_fetch($k3), 3, "Octect sequences and UTF-8 are distinct");
+    is(hint_fetch($k4), 4, "Octect sequences and UTF-8 are distinct");
+}
+
+{
+    my ($k1, $k2, $k3);
+    BEGIN {
+       ($k1, $k2, $k3) = ("\0", "\0\0", "\0\0\0");
+       $^H{$k1} = 1;
+       $^H{$k2} = 2;
+       $^H{$k3} = 3;
+    }
+
+    is(hint_fetch($k1), 1, "Keys with the same hash value don't clash");
+    is(hint_fetch($k2), 2, "Keys with the same hash value don't clash");
+    is(hint_fetch($k3), 3, "Keys with the same hash value don't clash");
+
+    BEGIN {
+       $^H{$k1} = "a";
+       $^H{$k2} = "b";
+       $^H{$k3} = "c";
+    }
+
+    is(hint_fetch($k1), "a", "Keys with the same hash value don't clash");
+    is(hint_fetch($k2), "b", "Keys with the same hash value don't clash");
+    is(hint_fetch($k3), "c", "Keys with the same hash value don't clash");
+}
+
+1;
index c5bb84e..4de1a19 100644 (file)
@@ -5,7 +5,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
-    plan( tests => 77 );
+    plan( tests => 78 );
 }
 
 my @c;
@@ -118,176 +118,20 @@ is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^
 
 print "# caller can now return the compile time state of %^H\n";
 
-sub get_hash {
+sub hint_exists {
+    my $key = shift;
     my $level = shift;
     my @results = caller($level||0);
-    $results[10];
+    exists $results[10]->{$key};
 }
 
-sub get_dooot {
+sub hint_fetch {
+    my $key = shift;
     my $level = shift;
     my @results = caller($level||0);
-    $results[10]->{dooot};
+    $results[10]->{$key};
 }
 
-sub get_thikoosh {
-    my $level = shift;
-    my @results = caller($level||0);
-    $results[10]->{thikoosh};
-}
-
-sub dooot {
-    is(get_dooot(), undef);
-    is(get_thikoosh(), undef);
-    my $hash = get_hash();
-    ok(!exists $hash->{dooot});
-    ok(!exists $hash->{thikoosh});
-    is(get_dooot(1), 54);
-    BEGIN {
-       $^H{dooot} = 42;
-    }
-    is(get_dooot(), 6 * 7);
-    is(get_dooot(1), 54);
-
-    BEGIN {
-       $^H{dooot} = undef;
-    }
-    is(get_dooot(), undef);
-    $hash = get_hash();
-    ok(exists $hash->{dooot});
-
-    BEGIN {
-       delete $^H{dooot};
-    }
-    is(get_dooot(), undef);
-    $hash = get_hash();
-    ok(!exists $hash->{dooot});
-    is(get_dooot(1), 54);
-}
-{
-    is(get_dooot(), undef);
-    is(get_thikoosh(), undef);
-    BEGIN {
-       $^H{dooot} = 1;
-       $^H{thikoosh} = "SKREECH";
-    }
-    is(get_dooot(), 1);
-    is(get_thikoosh(), "SKREECH");
-
-    BEGIN {
-       $^H{dooot} = 42;
-    }
-    {
-       {
-           BEGIN {
-               $^H{dooot} = 6 * 9;
-           }
-           is(get_dooot(), 54);
-           is(get_thikoosh(), "SKREECH");
-           {
-               BEGIN {
-                   delete $^H{dooot};
-               }
-               is(get_dooot(), undef);
-               my $hash = get_hash();
-               ok(!exists $hash->{dooot});
-               is(get_thikoosh(), "SKREECH");
-           }
-           dooot();
-       }
-       is(get_dooot(), 6 * 7);
-       is(get_thikoosh(), "SKREECH");
-    }
-    is(get_dooot(), 6 * 7);
-    is(get_thikoosh(), "SKREECH");
-}
-
-print "# which now works inside evals\n";
+$::testing_caller = 1;
 
-{
-    BEGIN {
-       $^H{dooot} = 42;
-    }
-    is(get_dooot(), 6 * 7);
-
-    eval "is(get_dooot(), 6 * 7); 1" or die $@;
-
-    eval <<'EOE' or die $@;
-    is(get_dooot(), 6 * 7);
-    eval "is(get_dooot(), 6 * 7); 1" or die $@;
-    BEGIN {
-       $^H{dooot} = 54;
-    }
-    is(get_dooot(), 54);
-    eval "is(get_dooot(), 54); 1" or die $@;
-    eval 'BEGIN { $^H{dooot} = -1; }; 1' or die $@;
-    is(get_dooot(), 54);
-    eval "is(get_dooot(), 54); 1" or die $@;
-EOE
-}
-
-{
-    BEGIN {
-       $^H{dooot} = "FIP\0FOP\0FIDDIT\0FAP";
-    }
-    is(get_dooot(), "FIP\0FOP\0FIDDIT\0FAP", "Can do embedded 0 bytes");
-
-    BEGIN {
-       $^H{dooot} = chr 256;
-    }
-    is(get_dooot(), chr 256, "Can do Unicode");
-
-    BEGIN {
-       $^H{dooot} = -42;
-    }
-    is(get_dooot(), -42, "Can do IVs");
-
-    BEGIN {
-       $^H{dooot} = ~0;
-    }
-    cmp_ok(get_dooot(), '>', 42, "Can do UVs");
-}
-
-{
-    my ($k1, $k2, $k3);
-    BEGIN {
-       $k1 = chr 163;
-       $k2 = $k1;
-       $k3 = $k1;
-       utf8::upgrade $k2;
-       utf8::encode $k3;
-
-       $^H{$k1} = 1;
-       $^H{$k2} = 2;
-       $^H{$k3} = 3;
-    }
-
-       
-    is(get_hash()->{$k1}, 2, "UTF-8 or not, it's the same");
-    is(get_hash()->{$k2}, 2, "UTF-8 or not, it's the same");
-    is(get_hash()->{$k3}, 3, "Octect sequences and UTF-8 are distinct");
-}
-
-{
-    my ($k1, $k2, $k3);
-    BEGIN {
-       ($k1, $k2, $k3) = ("\0", "\0\0", "\0\0\0");
-       $^H{$k1} = 1;
-       $^H{$k2} = 2;
-       $^H{$k3} = 3;
-    }
-
-    is(get_hash()->{$k1}, 1, "Keys with the same hash value don't clash");
-    is(get_hash()->{$k2}, 2, "Keys with the same hash value don't clash");
-    is(get_hash()->{$k3}, 3, "Keys with the same hash value don't clash");
-
-    BEGIN {
-       $^H{$k1} = "a";
-       $^H{$k2} = "b";
-       $^H{$k3} = "c";
-    }
-
-    is(get_hash()->{$k1}, "a", "Keys with the same hash value don't clash");
-    is(get_hash()->{$k2}, "b", "Keys with the same hash value don't clash");
-    is(get_hash()->{$k3}, "c", "Keys with the same hash value don't clash");
-}
+do './op/caller.pl';