From d8c5b3c5f8f46ae357e9c3ef6c3ccef73c567024 Mon Sep 17 00:00:00 2001
From: Nicholas Clark <nick@ccl4.org>
Date: Mon, 29 May 2006 22:58:46 +0000
Subject: 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
---
 t/op/caller.pl | 175 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 t/op/caller.t  | 174 +++-----------------------------------------------------
 2 files changed, 184 insertions(+), 165 deletions(-)
 create mode 100644 t/op/caller.pl

(limited to 't')

diff --git a/t/op/caller.pl b/t/op/caller.pl
new file mode 100644
index 0000000000..b0545f06bb
--- /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 c5bb84ea5d..4de1a191a8 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';
-- 
cgit v1.2.1