Avoid overflow warning in chop.t.

[perl5.git] / t / op / caller.pl

# 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;