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