Commit | Line | Data |
44a8e56a |
1 | #!./perl |
2 | # |
3 | # check UNIVERSAL |
4 | # |
5 | |
e09f3e01 |
6 | BEGIN { |
7 | chdir 't' if -d 't'; |
20822f61 |
8 | @INC = '../lib'; |
46e4b22b |
9 | $| = 1; |
e09f3e01 |
10 | } |
11 | |
22b06de7 |
12 | print "1..87\n"; |
44a8e56a |
13 | |
14 | $a = {}; |
15 | bless $a, "Bob"; |
ff0cee69 |
16 | print "not " unless $a->isa("Bob"); |
17 | print "ok 1\n"; |
44a8e56a |
18 | |
ff0cee69 |
19 | package Human; |
20 | sub eat {} |
44a8e56a |
21 | |
ff0cee69 |
22 | package Female; |
23 | @ISA=qw(Human); |
44a8e56a |
24 | |
ff0cee69 |
25 | package Alice; |
26 | @ISA=qw(Bob Female); |
39d11b7f |
27 | sub sing; |
28 | sub drink { return "drinking " . $_[1] } |
ff0cee69 |
29 | sub new { bless {} } |
44a8e56a |
30 | |
e09f3e01 |
31 | $Alice::VERSION = 2.718; |
32 | |
46e4b22b |
33 | { |
34 | package Cedric; |
35 | our @ISA; |
36 | use base qw(Human); |
37 | } |
38 | |
39 | { |
40 | package Programmer; |
41 | our $VERSION = 1.667; |
42 | |
43 | sub write_perl { 1 } |
44 | } |
45 | |
44a8e56a |
46 | package main; |
e09f3e01 |
47 | |
39d11b7f |
48 | { my $i = 2; |
49 | sub test { print "not " unless shift; print "ok $i\n"; $i++; } |
50 | } |
e09f3e01 |
51 | |
ff0cee69 |
52 | $a = new Alice; |
44a8e56a |
53 | |
e09f3e01 |
54 | test $a->isa("Alice"); |
44a8e56a |
55 | |
e09f3e01 |
56 | test $a->isa("Bob"); |
57 | |
58 | test $a->isa("Female"); |
59 | |
60 | test $a->isa("Human"); |
61 | |
62 | test ! $a->isa("Male"); |
63 | |
46e4b22b |
64 | test ! $a->isa('Programmer'); |
65 | |
e09f3e01 |
66 | test $a->can("eat"); |
e09f3e01 |
67 | test ! $a->can("sleep"); |
39d11b7f |
68 | test my $ref = $a->can("drink"); # returns a coderef |
69 | test $a->$ref("tea") eq "drinking tea"; # ... which works |
70 | test $ref = $a->can("sing"); |
444e39b5 |
71 | eval { $a->$ref() }; |
39d11b7f |
72 | test $@; # ... but not if no actual subroutine |
e09f3e01 |
73 | |
46e4b22b |
74 | test (!Cedric->isa('Programmer')); |
75 | |
76 | test (Cedric->isa('Human')); |
77 | |
78 | push(@Cedric::ISA,'Programmer'); |
79 | |
80 | test (Cedric->isa('Programmer')); |
81 | |
82 | { |
83 | package Alice; |
84 | base::->import('Programmer'); |
85 | } |
86 | |
87 | test $a->isa('Programmer'); |
88 | test $a->isa("Female"); |
89 | |
90 | @Cedric::ISA = qw(Bob); |
91 | |
92 | test (!Cedric->isa('Programmer')); |
93 | |
e09f3e01 |
94 | my $b = 'abc'; |
95 | my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE); |
96 | my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} ); |
97 | for ($p=0; $p < @refs; $p++) { |
98 | for ($q=0; $q < @vals; $q++) { |
99 | test UNIVERSAL::isa($vals[$p], $refs[$q]) eq ($p==$q or $p+$q==1); |
100 | }; |
101 | }; |
102 | |
103 | test ! UNIVERSAL::can(23, "can"); |
104 | |
105 | test $a->can("VERSION"); |
106 | |
107 | test $a->can("can"); |
84902520 |
108 | test ! $a->can("export_tags"); # a method in Exporter |
e09f3e01 |
109 | |
110 | test (eval { $a->VERSION }) == 2.718; |
111 | |
112 | test ! (eval { $a->VERSION(2.719) }) && |
ae165b0c |
113 | $@ =~ /^Alice version 2.71(?:9|8999\d+) required--this is only version 2.718 at /; |
44a8e56a |
114 | |
e09f3e01 |
115 | test (eval { $a->VERSION(2.718) }) && ! $@; |
ff0cee69 |
116 | |
e09f3e01 |
117 | my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; |
9d116dd7 |
118 | if ('a' lt 'A') { |
119 | test $subs eq "can isa VERSION"; |
120 | } else { |
121 | test $subs eq "VERSION can isa"; |
122 | } |
ff0cee69 |
123 | |
e09f3e01 |
124 | test $a->isa("UNIVERSAL"); |
ff0cee69 |
125 | |
b4c2bf25 |
126 | test ! UNIVERSAL::isa([], "UNIVERSAL"); |
127 | |
128 | test ! UNIVERSAL::can({}, "can"); |
129 | |
130 | test UNIVERSAL::isa(Alice => "UNIVERSAL"); |
131 | |
132 | test UNIVERSAL::can(Alice => "can") == \&UNIVERSAL::can; |
133 | |
84902520 |
134 | # now use UNIVERSAL.pm and see what changes |
e09f3e01 |
135 | eval "use UNIVERSAL"; |
ff0cee69 |
136 | |
e09f3e01 |
137 | test $a->isa("UNIVERSAL"); |
44a8e56a |
138 | |
46e4b22b |
139 | my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; |
84902520 |
140 | # XXX import being here is really a bug |
9d116dd7 |
141 | if ('a' lt 'A') { |
142 | test $sub2 eq "can import isa VERSION"; |
143 | } else { |
144 | test $sub2 eq "VERSION can import isa"; |
145 | } |
44a8e56a |
146 | |
e09f3e01 |
147 | eval 'sub UNIVERSAL::sleep {}'; |
148 | test $a->can("sleep"); |
44a8e56a |
149 | |
e09f3e01 |
150 | test ! UNIVERSAL::can($b, "can"); |
84902520 |
151 | |
152 | test ! $a->can("export_tags"); # a method in Exporter |
83f7a2bc |
153 | |
154 | test ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH'); |