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