1#!./perl
2
3BEGIN {
4    unless (-d 'blib') {
5	chdir 't' if -d 't';
6	@INC = '../lib';
7	require Config; import Config;
8	keys %Config; # Silence warning
9	if ($Config{extensions} !~ /\bList\/Util\b/) {
10	    print "1..0 # Skip: List::Util was not built\n";
11	    exit 0;
12	}
13    }
14}
15
16
17use Test::More tests => 32;
18
19use Scalar::Util qw(refaddr);
20use vars qw($t $y $x *F $v $r);
21use Symbol qw(gensym);
22
23# Ensure we do not trigger and tied methods
24tie *F, 'MyTie';
25
26my $i = 1;
27foreach $v (undef, 10, 'string') {
28  is(refaddr($v), undef, "not " . (defined($v) ? "'$v'" : "undef"));
29}
30
31foreach $r ({}, \$t, [], \*F, sub {}) {
32  my $n = "$r";
33  $n =~ /0x(\w+)/;
34  my $addr = do { local $^W; hex $1 };
35  my $before = ref($r);
36  is( refaddr($r), $addr, $n);
37  is( ref($r), $before, $n);
38
39  my $obj = bless $r, 'FooBar';
40  is( refaddr($r), $addr, "blessed with overload $n");
41  is( ref($r), 'FooBar', $n);
42}
43
44{
45  my $z = '77';
46  my $y = \$z;
47  my $a = '78';
48  my $b = \$a;
49  tie my %x, 'Hash3', {};
50  $x{$y} = 22;
51  $x{$b} = 23;
52  my $xy = $x{$y};
53  my $xb = $x{$b};
54  ok(ref($x{$y}));
55  ok(ref($x{$b}));
56  ok(refaddr($xy) == refaddr($y));
57  ok(refaddr($xb) == refaddr($b));
58  ok(refaddr($x{$y}));
59  ok(refaddr($x{$b}));
60}
61{
62  my $z = bless {}, '0';
63  ok(refaddr($z));
64  @{"0::ISA"} = qw(FooBar);
65  my $a = {};
66  my $r = refaddr($a);
67  $z = bless $a, '0';
68  ok(refaddr($z) > 10);
69  is(refaddr($z),$r,"foo");
70}
71
72package FooBar;
73
74use overload  '0+' => sub { 10 },
75		'+' => sub { 10 + $_[1] },
76		'""' => sub { "10" };
77
78package MyTie;
79
80sub TIEHANDLE { bless {} }
81sub DESTROY {}
82
83sub AUTOLOAD {
84  warn "$AUTOLOAD called";
85  exit 1; # May be in an eval
86}
87
88package Hash3;
89
90use Scalar::Util qw(refaddr);
91
92sub TIEHASH
93{
94	my $pkg = shift;
95	return bless [ @_ ], $pkg;
96}
97sub FETCH
98{
99	my $self = shift;
100	my $key = shift;
101	my ($underlying) = @$self;
102	return $underlying->{refaddr($key)};
103}
104sub STORE
105{
106	my $self = shift;
107	my $key = shift;
108	my $value = shift;
109	my ($underlying) = @$self;
110	return ($underlying->{refaddr($key)} = $key);
111}
112