Small optimisations, by Brandon Black
[p5sagit/p5-mst-13.2.git] / t / op / universal.t
1 #!./perl
2 #
3 # check UNIVERSAL
4 #
5
6 BEGIN {
7     chdir 't' if -d 't';
8     @INC = '../lib';
9     $| = 1;
10     require "./test.pl";
11 }
12
13 plan tests => 111;
14
15 $a = {};
16 bless $a, "Bob";
17 ok $a->isa("Bob");
18
19 package Human;
20 sub eat {}
21
22 package Female;
23 @ISA=qw(Human);
24
25 package Alice;
26 @ISA=qw(Bob Female);
27 sub sing;
28 sub drink { return "drinking " . $_[1]  }
29 sub new { bless {} }
30
31 $Alice::VERSION = 2.718;
32
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
46 package main;
47
48
49
50 $a = new Alice;
51
52 ok $a->isa("Alice");
53 ok $a->isa("main::Alice");    # check that alternate class names work
54
55 ok(("main::Alice"->new)->isa("Alice"));
56
57 ok $a->isa("Bob");
58 ok $a->isa("main::Bob");
59
60 ok $a->isa("Female");
61
62 ok $a->isa("Human");
63
64 ok ! $a->isa("Male");
65
66 ok ! $a->isa('Programmer');
67
68 ok $a->isa("HASH");
69
70 ok $a->can("eat");
71 ok ! $a->can("sleep");
72 ok my $ref = $a->can("drink");        # returns a coderef
73 is $a->$ref("tea"), "drinking tea"; # ... which works
74 ok $ref = $a->can("sing");
75 eval { $a->$ref() };
76 ok $@;                                # ... but not if no actual subroutine
77
78 ok (!Cedric->isa('Programmer'));
79
80 ok (Cedric->isa('Human'));
81
82 push(@Cedric::ISA,'Programmer');
83
84 ok (Cedric->isa('Programmer'));
85
86 {
87     package Alice;
88     base::->import('Programmer');
89 }
90
91 ok $a->isa('Programmer');
92 ok $a->isa("Female");
93
94 @Cedric::ISA = qw(Bob);
95
96 ok (!Cedric->isa('Programmer'));
97
98 my $b = 'abc';
99 my @refs = qw(SCALAR SCALAR     LVALUE      GLOB ARRAY HASH CODE);
100 my @vals = (  \$b,   \3.14, \substr($b,1,1), \*b,  [],  {}, sub {} );
101 for ($p=0; $p < @refs; $p++) {
102     for ($q=0; $q < @vals; $q++) {
103         is UNIVERSAL::isa($vals[$p], $refs[$q]), ($p==$q or $p+$q==1);
104     };
105 };
106
107 ok ! UNIVERSAL::can(23, "can");
108
109 ok $a->can("VERSION");
110
111 ok $a->can("can");
112 ok ! $a->can("export_tags");    # a method in Exporter
113
114 cmp_ok eval { $a->VERSION }, '==', 2.718;
115
116 ok ! (eval { $a->VERSION(2.719) });
117 like $@, qr/^Alice version 2.719 required--this is only version 2.718 at /;
118
119 ok (eval { $a->VERSION(2.718) });
120 is $@, '';
121
122 my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
123 ## The test for import here is *not* because we want to ensure that UNIVERSAL
124 ## can always import; it is an historical accident that UNIVERSAL can import.
125 if ('a' lt 'A') {
126     is $subs, "can import isa DOES VERSION";
127 } else {
128     is $subs, "DOES VERSION can import isa";
129 }
130
131 ok $a->isa("UNIVERSAL");
132
133 ok ! UNIVERSAL::isa([], "UNIVERSAL");
134
135 ok ! UNIVERSAL::can({}, "can");
136
137 ok UNIVERSAL::isa(Alice => "UNIVERSAL");
138
139 cmp_ok UNIVERSAL::can(Alice => "can"), '==', \&UNIVERSAL::can;
140
141 # now use UNIVERSAL.pm and see what changes
142 eval "use UNIVERSAL";
143
144 ok $a->isa("UNIVERSAL");
145
146 my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
147 # XXX import being here is really a bug
148 if ('a' lt 'A') {
149     is $sub2, "can import isa DOES VERSION";
150 } else {
151     is $sub2, "DOES VERSION can import isa";
152 }
153
154 eval 'sub UNIVERSAL::sleep {}';
155 ok $a->can("sleep");
156
157 ok ! UNIVERSAL::can($b, "can");
158
159 ok ! $a->can("export_tags");    # a method in Exporter
160
161 ok ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH');
162
163 {
164     package Pickup;
165     use UNIVERSAL qw( isa can VERSION );
166
167     ::ok isa "Pickup", UNIVERSAL;
168     ::cmp_ok can( "Pickup", "can" ), '==', \&UNIVERSAL::can;
169     ::ok VERSION "UNIVERSAL" ;
170 }
171
172 {
173     # test isa() and can() on magic variables
174     "Human" =~ /(.*)/;
175     ok $1->isa("Human");
176     ok $1->can("eat");
177     package HumanTie;
178     sub TIESCALAR { bless {} }
179     sub FETCH { "Human" }
180     tie my($x), "HumanTie";
181     ::ok $x->isa("Human");
182     ::ok $x->can("eat");
183 }
184
185 # bugid 3284
186 # a second call to isa('UNIVERSAL') when @ISA is null failed due to caching
187
188 @X::ISA=();
189 my $x = {}; bless $x, 'X';
190 ok $x->isa('UNIVERSAL');
191 ok $x->isa('UNIVERSAL');
192
193
194 # Check that the "historical accident" of UNIVERSAL having an import()
195 # method doesn't effect anyone else.
196 eval { Some::Package->import("bar") };
197 is $@, '';
198
199
200 # This segfaulted in a blead.
201 fresh_perl_is('package Foo; Foo->VERSION;  print "ok"', 'ok');
202
203 package Foo;
204
205 sub DOES { 1 }
206
207 package Bar;
208
209 @Bar::ISA = 'Foo';
210
211 package Baz;
212
213 package main;
214 ok( Foo->DOES( 'bar' ), 'DOES() should call DOES() on class' );
215 ok( Bar->DOES( 'Bar' ), '... and should fall back to isa()' );
216 ok( Bar->DOES( 'Foo' ), '... even when inherited' );
217 ok( Baz->DOES( 'Baz' ), '... even without inheriting any other DOES()' );
218 ok( ! Baz->DOES( 'Foo' ), '... returning true or false appropriately' );
219
220 package Pig;
221 package Bodine;
222 Bodine->isa('Pig');
223 *isa = \&UNIVERSAL::isa;
224 eval { isa({}, 'HASH') };
225 ::is($@, '', "*isa correctly found");
226
227 package main;
228 eval { UNIVERSAL::DOES([], "foo") };
229 like( $@, qr/Can't call method "DOES" on unblessed reference/,
230     'DOES call error message says DOES, not isa' );