| 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 => 133; |
| 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("Female\0NOT REALLY!"), "->isa is nul-clean."; |
| 63 | |
| 64 | ok $a->isa("Human"); |
| 65 | |
| 66 | ok ! $a->isa("Male"); |
| 67 | |
| 68 | ok ! $a->isa('Programmer'); |
| 69 | |
| 70 | ok $a->isa("HASH"); |
| 71 | |
| 72 | ok $a->can("eat"); |
| 73 | ok ! $a->can("eat\0Except not!"), "->can is nul-clean."; |
| 74 | ok ! $a->can("sleep"); |
| 75 | ok my $ref = $a->can("drink"); # returns a coderef |
| 76 | is $a->$ref("tea"), "drinking tea"; # ... which works |
| 77 | ok $ref = $a->can("sing"); |
| 78 | eval { $a->$ref() }; |
| 79 | ok $@; # ... but not if no actual subroutine |
| 80 | |
| 81 | ok (!Cedric->isa('Programmer')); |
| 82 | |
| 83 | ok (Cedric->isa('Human')); |
| 84 | |
| 85 | push(@Cedric::ISA,'Programmer'); |
| 86 | |
| 87 | ok (Cedric->isa('Programmer')); |
| 88 | |
| 89 | { |
| 90 | package Alice; |
| 91 | base::->import('Programmer'); |
| 92 | } |
| 93 | |
| 94 | ok $a->isa('Programmer'); |
| 95 | ok $a->isa("Female"); |
| 96 | |
| 97 | @Cedric::ISA = qw(Bob); |
| 98 | |
| 99 | ok (!Cedric->isa('Programmer')); |
| 100 | |
| 101 | my $b = 'abc'; |
| 102 | my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE); |
| 103 | my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} ); |
| 104 | for ($p=0; $p < @refs; $p++) { |
| 105 | for ($q=0; $q < @vals; $q++) { |
| 106 | is UNIVERSAL::isa($vals[$p], $refs[$q]), ($p==$q or $p+$q==1); |
| 107 | }; |
| 108 | }; |
| 109 | |
| 110 | ok ! UNIVERSAL::can(23, "can"); |
| 111 | |
| 112 | ok $a->can("VERSION"); |
| 113 | |
| 114 | ok $a->can("can"); |
| 115 | ok ! $a->can("export_tags"); # a method in Exporter |
| 116 | |
| 117 | cmp_ok eval { $a->VERSION }, '==', 2.718; |
| 118 | |
| 119 | ok ! (eval { $a->VERSION(2.719) }); |
| 120 | like $@, qr/^Alice version 2.719 required--this is only version 2.718 at /; |
| 121 | |
| 122 | ok (eval { $a->VERSION(2.718) }); |
| 123 | is $@, ''; |
| 124 | |
| 125 | ok ! (eval { $a->VERSION("version") }); |
| 126 | like $@, qr/^Invalid version format/; |
| 127 | |
| 128 | $aversion::VERSION = "version"; |
| 129 | ok ! (eval { aversion->VERSION(2.719) }); |
| 130 | like $@, qr/^Invalid version format/; |
| 131 | |
| 132 | my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; |
| 133 | ## The test for import here is *not* because we want to ensure that UNIVERSAL |
| 134 | ## can always import; it is an historical accident that UNIVERSAL can import. |
| 135 | if ('a' lt 'A') { |
| 136 | is $subs, "can import isa DOES VERSION"; |
| 137 | } else { |
| 138 | is $subs, "DOES VERSION can import isa"; |
| 139 | } |
| 140 | |
| 141 | ok $a->isa("UNIVERSAL"); |
| 142 | |
| 143 | ok ! UNIVERSAL::isa([], "UNIVERSAL"); |
| 144 | |
| 145 | ok ! UNIVERSAL::can({}, "can"); |
| 146 | |
| 147 | ok UNIVERSAL::isa(Alice => "UNIVERSAL"); |
| 148 | |
| 149 | cmp_ok UNIVERSAL::can(Alice => "can"), '==', \&UNIVERSAL::can; |
| 150 | |
| 151 | # now use UNIVERSAL.pm and see what changes |
| 152 | eval "use UNIVERSAL"; |
| 153 | |
| 154 | ok $a->isa("UNIVERSAL"); |
| 155 | |
| 156 | my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; |
| 157 | # XXX import being here is really a bug |
| 158 | if ('a' lt 'A') { |
| 159 | is $sub2, "can import isa DOES VERSION"; |
| 160 | } else { |
| 161 | is $sub2, "DOES VERSION can import isa"; |
| 162 | } |
| 163 | |
| 164 | eval 'sub UNIVERSAL::sleep {}'; |
| 165 | ok $a->can("sleep"); |
| 166 | |
| 167 | ok ! UNIVERSAL::can($b, "can"); |
| 168 | |
| 169 | ok ! $a->can("export_tags"); # a method in Exporter |
| 170 | |
| 171 | ok ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH'); |
| 172 | |
| 173 | { |
| 174 | package Pickup; |
| 175 | use UNIVERSAL qw( isa can VERSION ); |
| 176 | |
| 177 | ::ok isa "Pickup", UNIVERSAL; |
| 178 | ::cmp_ok can( "Pickup", "can" ), '==', \&UNIVERSAL::can; |
| 179 | ::ok VERSION "UNIVERSAL" ; |
| 180 | } |
| 181 | |
| 182 | { |
| 183 | # test isa() and can() on magic variables |
| 184 | "Human" =~ /(.*)/; |
| 185 | ok $1->isa("Human"); |
| 186 | ok $1->can("eat"); |
| 187 | package HumanTie; |
| 188 | sub TIESCALAR { bless {} } |
| 189 | sub FETCH { "Human" } |
| 190 | tie my($x), "HumanTie"; |
| 191 | ::ok $x->isa("Human"); |
| 192 | ::ok $x->can("eat"); |
| 193 | } |
| 194 | |
| 195 | # bugid 3284 |
| 196 | # a second call to isa('UNIVERSAL') when @ISA is null failed due to caching |
| 197 | |
| 198 | @X::ISA=(); |
| 199 | my $x = {}; bless $x, 'X'; |
| 200 | ok $x->isa('UNIVERSAL'); |
| 201 | ok $x->isa('UNIVERSAL'); |
| 202 | |
| 203 | |
| 204 | # Check that the "historical accident" of UNIVERSAL having an import() |
| 205 | # method doesn't effect anyone else. |
| 206 | eval { Some::Package->import("bar") }; |
| 207 | is $@, ''; |
| 208 | |
| 209 | |
| 210 | # This segfaulted in a blead. |
| 211 | fresh_perl_is('package Foo; Foo->VERSION; print "ok"', 'ok'); |
| 212 | |
| 213 | # So did this. |
| 214 | fresh_perl_is('$:; UNIVERSAL::isa(":","Unicode::String");print "ok"','ok'); |
| 215 | |
| 216 | package Foo; |
| 217 | |
| 218 | sub DOES { 1 } |
| 219 | |
| 220 | package Bar; |
| 221 | |
| 222 | @Bar::ISA = 'Foo'; |
| 223 | |
| 224 | package Baz; |
| 225 | |
| 226 | package main; |
| 227 | ok( Foo->DOES( 'bar' ), 'DOES() should call DOES() on class' ); |
| 228 | ok( Bar->DOES( 'Bar' ), '... and should fall back to isa()' ); |
| 229 | ok( Bar->DOES( 'Foo' ), '... even when inherited' ); |
| 230 | ok( Baz->DOES( 'Baz' ), '... even without inheriting any other DOES()' ); |
| 231 | ok( ! Baz->DOES( 'Foo' ), '... returning true or false appropriately' ); |
| 232 | |
| 233 | ok( ! "T"->DOES( "T\0" ), 'DOES() is nul-clean' ); |
| 234 | ok( ! Baz->DOES( "Baz\0Boy howdy" ), 'DOES() is nul-clean' ); |
| 235 | |
| 236 | package Pig; |
| 237 | package Bodine; |
| 238 | Bodine->isa('Pig'); |
| 239 | *isa = \&UNIVERSAL::isa; |
| 240 | eval { isa({}, 'HASH') }; |
| 241 | ::is($@, '', "*isa correctly found"); |
| 242 | |
| 243 | package main; |
| 244 | eval { UNIVERSAL::DOES([], "foo") }; |
| 245 | like( $@, qr/Can't call method "DOES" on unblessed reference/, |
| 246 | 'DOES call error message says DOES, not isa' ); |
| 247 | |
| 248 | # Tests for can seem to be split between here and method.t |
| 249 | # Add the verbatim perl code mentioned in the comments of |
| 250 | # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-05/msg01710.html |
| 251 | # but never actually tested. |
| 252 | is(UNIVERSAL->can("NoSuchPackage::foo"), undef); |
| 253 | |
| 254 | @splatt::ISA = 'zlopp'; |
| 255 | ok (splatt->isa('zlopp')); |
| 256 | ok (!splatt->isa('plop')); |
| 257 | |
| 258 | # This should reset the ->isa lookup cache |
| 259 | @splatt::ISA = 'plop'; |
| 260 | # And here is the new truth. |
| 261 | ok (!splatt->isa('zlopp')); |
| 262 | ok (splatt->isa('plop')); |
| 263 | |
| 264 | use warnings "deprecated"; |
| 265 | { |
| 266 | my $m; |
| 267 | local $SIG{__WARN__} = sub { $m = $_[0] }; |
| 268 | eval "use UNIVERSAL 'can'"; |
| 269 | like($m, qr/^UNIVERSAL->import is deprecated/, |
| 270 | "deprecation warning for UNIVERSAL->import('can')"); |
| 271 | |
| 272 | undef $m; |
| 273 | eval "use UNIVERSAL"; |
| 274 | is($m, undef, |
| 275 | "no deprecation warning for UNIVERSAL->import"); |
| 276 | } |
| 277 | |
| 278 | # Test: [perl #66112]: change @ISA inside sub isa |
| 279 | { |
| 280 | package RT66112::A; |
| 281 | |
| 282 | package RT66112::B; |
| 283 | |
| 284 | sub isa { |
| 285 | my $self = shift; |
| 286 | @ISA = qw/RT66112::A/; |
| 287 | return $self->SUPER::isa(@_); |
| 288 | } |
| 289 | |
| 290 | package RT66112::C; |
| 291 | |
| 292 | package RT66112::D; |
| 293 | |
| 294 | sub isa { |
| 295 | my $self = shift; |
| 296 | @RT66112::E::ISA = qw/RT66112::A/; |
| 297 | return $self->SUPER::isa(@_); |
| 298 | } |
| 299 | |
| 300 | package RT66112::E; |
| 301 | |
| 302 | package main; |
| 303 | |
| 304 | @RT66112::B::ISA = qw//; |
| 305 | @RT66112::C::ISA = qw/RT66112::B/; |
| 306 | @RT66112::T1::ISA = qw/RT66112::C/; |
| 307 | ok(RT66112::T1->isa('RT66112::C'), "modify \@ISA in isa (RT66112::T1 isa RT66112::C)"); |
| 308 | |
| 309 | @RT66112::B::ISA = qw//; |
| 310 | @RT66112::C::ISA = qw/RT66112::B/; |
| 311 | @RT66112::T2::ISA = qw/RT66112::C/; |
| 312 | ok(RT66112::T2->isa('RT66112::B'), "modify \@ISA in isa (RT66112::T2 isa RT66112::B)"); |
| 313 | |
| 314 | @RT66112::B::ISA = qw//; |
| 315 | @RT66112::C::ISA = qw/RT66112::B/; |
| 316 | @RT66112::T3::ISA = qw/RT66112::C/; |
| 317 | ok(RT66112::T3->isa('RT66112::A'), "modify \@ISA in isa (RT66112::T3 isa RT66112::A)") or require mro, diag "@{mro::get_linear_isa('RT66112::T3')}"; |
| 318 | |
| 319 | @RT66112::E::ISA = qw/RT66112::D/; |
| 320 | @RT66112::T4::ISA = qw/RT66112::E/; |
| 321 | ok(RT66112::T4->isa('RT66112::E'), "modify \@ISA in isa (RT66112::T4 isa RT66112::E)"); |
| 322 | |
| 323 | @RT66112::E::ISA = qw/RT66112::D/; |
| 324 | @RT66112::T5::ISA = qw/RT66112::E/; |
| 325 | ok(! RT66112::T5->isa('RT66112::D'), "modify \@ISA in isa (RT66112::T5 not isa RT66112::D)"); |
| 326 | |
| 327 | @RT66112::E::ISA = qw/RT66112::D/; |
| 328 | @RT66112::T6::ISA = qw/RT66112::E/; |
| 329 | ok(RT66112::T6->isa('RT66112::A'), "modify \@ISA in isa (RT66112::T6 isa RT66112::A)"); |
| 330 | } |