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
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
#!./perl
#
# check UNIVERSAL
#
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
$| = 1;
}
print "1..80\n";
$a = {};
bless $a, "Bob";
print "not " unless $a->isa("Bob");
print "ok 1\n";
package Human;
sub eat {}
package Female;
@ISA=qw(Human);
package Alice;
@ISA=qw(Bob Female);
sub drink {}
sub new { bless {} }
$Alice::VERSION = 2.718;
{
package Cedric;
our @ISA;
use base qw(Human);
}
{
package Programmer;
our $VERSION = 1.667;
sub write_perl { 1 }
}
package main;
my $i = 2;
sub test { print "not " unless shift; print "ok $i\n"; $i++; }
$a = new Alice;
test $a->isa("Alice");
test $a->isa("Bob");
test $a->isa("Female");
test $a->isa("Human");
test ! $a->isa("Male");
test ! $a->isa('Programmer');
test $a->can("drink");
test $a->can("eat");
test ! $a->can("sleep");
test (!Cedric->isa('Programmer'));
test (Cedric->isa('Human'));
push(@Cedric::ISA,'Programmer');
test (Cedric->isa('Programmer'));
{
package Alice;
base::->import('Programmer');
}
test $a->isa('Programmer');
test $a->isa("Female");
@Cedric::ISA = qw(Bob);
test (!Cedric->isa('Programmer'));
my $b = 'abc';
my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE);
my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} );
for ($p=0; $p < @refs; $p++) {
for ($q=0; $q < @vals; $q++) {
test UNIVERSAL::isa($vals[$p], $refs[$q]) eq ($p==$q or $p+$q==1);
};
};
test ! UNIVERSAL::can(23, "can");
test $a->can("VERSION");
test $a->can("can");
test ! $a->can("export_tags"); # a method in Exporter
test (eval { $a->VERSION }) == 2.718;
test ! (eval { $a->VERSION(2.719) }) &&
$@ =~ /^Alice version 2.71(?:9|8999\d+) required--this is only version 2.718 at /;
test (eval { $a->VERSION(2.718) }) && ! $@;
my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
if ('a' lt 'A') {
test $subs eq "can isa VERSION";
} else {
test $subs eq "VERSION can isa";
}
test $a->isa("UNIVERSAL");
# now use UNIVERSAL.pm and see what changes
eval "use UNIVERSAL";
test $a->isa("UNIVERSAL");
my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
# XXX import being here is really a bug
if ('a' lt 'A') {
test $sub2 eq "can import isa VERSION";
} else {
test $sub2 eq "VERSION can import isa";
}
eval 'sub UNIVERSAL::sleep {}';
test $a->can("sleep");
test ! UNIVERSAL::can($b, "can");
test ! $a->can("export_tags"); # a method in Exporter
test ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH');
|
