From: Nicholas Clark <nick@ccl4.org>
Date: Mon, 29 May 2006 22:58:46 +0000 (+0000)
Subject: Comprehensive regression tests for Perl_refcounted_he_fetch().
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d8c5b3c5f8f46ae357e9c3ef6c3ccef73c567024;p=p5sagit%2Fp5-mst-13.2.git

Comprehensive regression tests for Perl_refcounted_he_fetch().
Fix a bug due to the fact that Perl's typedef'd "bool" type isn't
actually boolean.

p4raw-id: //depot/perl@28335
---

diff --git a/MANIFEST b/MANIFEST
index b527b9c..85b1492 100644
--- 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
diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs
index ff0a8fb..bcf46ee 100644
--- a/ext/XS/APItest/APItest.xs
+++ b/ext/XS/APItest/APItest.xs
@@ -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
index 0000000..29a6409
--- /dev/null
+++ b/ext/XS/APItest/t/op.t
@@ -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
--- 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
index 0000000..b0545f0
--- /dev/null
+++ b/t/op/caller.pl
@@ -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;
diff --git a/t/op/caller.t b/t/op/caller.t
index c5bb84e..4de1a19 100644
--- a/t/op/caller.t
+++ b/t/op/caller.t
@@ -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';