1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
#!perl
use strict;
use warnings;
use Test::More;
our $TESTS;
# # ok( not( defined undef ), 'undef is undefined' );
# # ok( defined 1, '1 is defined' );
# # ok( defined '...', '"..." is defined' );
# # ok( defined [], '[] is defined' );
# #
# # sub X1::defined {1}
# # sub X2::defined {0}
# # ok( defined( bless [], 'X1' ), 'X1 is defined because ->defined is true' );
# # ok( not( defined bless [], 'X2' ),
# # 'X2 is not defined because ->defined is false' );
# #
# # sub Y::defined { }
# # ok( not( defined bless [], 'Y' ),
# # 'Y is not defined because ->defined returned empty' );
# #
# # sub Z::defined { return ( 0, 0 ) }
# # ok( not( defined bless [], 'Z' ), q[Z returned (0,0) so it is undefined] );
# #
# # ok( defined( bless [], 'A' ), 'A has no ->defined method so it is fine' );
#
TODO: {
# This test must occur before UNIVERSAL::ref is compiled.
BEGIN { $TESTS += 1 }
local $TODO = q[Impossible using current technology.];
# Fixing this requires peeking at the optrees being used by yylex
# that haven't been fed to newATTRSUB yet. Is there some ultra
# sneaky way to get access to these ops uh... without going
# through a CV's ROOT?
package main;
is( ref( bless [], 'PAST' ), 'lie', 'I even fix the past' );
package PAST;
use UNIVERSAL::ref;
sub ref {'lie'}
}
{
BEGIN { $TESTS += 1 }
package LIAR;
use UNIVERSAL::ref;
sub ref {'lie'}
package main;
# Validate that ref() lies for us.
is( CORE::ref( bless [], 'LIAR' ), 'lie', 'Lying 101' );
}
SKIP: {
BEGIN { $TESTS += 1 }
eval q[use Data::Dumper 'Dumper'];
skip( q[Don't have Data::Dumper], 1 )
if not defined &Dumper;
like( Dumper( bless [], 'LIAR' ), qr/LIAR/,
'Data::Dumper is unpeturbed' );
}
SKIP: {
BEGIN { $TESTS += 1 }
eval q[use Data::Dump::Streamer 'Dump'];
skip( q[Don't have Data::Dump::Streamer], 1 )
if not defined &Dump;
like( Dump( bless [], 'LIAR' )->Out,
qr/LIAR/, 'Data::Dump::Streamer is ok' );
}
{
BEGIN { $TESTS += 3 }
# Validate that ref() works as normal for non-hooked things.
is( ref(''), '', 'Ordinary things are ordinary 1' );
is( ref( [] ), 'ARRAY', 'Ordinary things are ordinary 2' );
is( ref( bless [], 'A1' ), 'A1', 'Ordinary things are ordinary 3' );
}
{
BEGIN { $TESTS += 2 }
package DELUSION;
use UNIVERSAL::ref;
sub ref {'blah blah blah'}
sub myself { CORE::ref $_[0] }
package main;
is( ref( bless( [], 'DELUSION' ) ), 'blah blah blah', 'Self delusion 1' );
is( bless( [], 'DELUSION' )->myself, 'DELUSION', 'Self delusion 2' );
}
{
BEGIN { $TESTS += 2 }
package OVERLOADED;
sub ref { warn; 'NOT-OVERLOADED' }
use overload 'bool' => sub () {'FALSE'};
use UNIVERSAL::ref;
package main;
my $obj = bless [], 'OVERLOADED';
ok( overload::Overloaded($obj),
'Overloaded objects still look overloaded' );
like(
overload::StrVal($obj),
qr/\A\QOVERLOADED=ARRAY(0x\E[\da-fA-F]+\)\z/,
'Overloaded objects stringify normally too'
);
}
BEGIN { plan('no_plan') }
|
