1N/A#!./perl
1N/A#
1N/A# check UNIVERSAL
1N/A#
1N/A
1N/ABEGIN {
1N/A chdir 't' if -d 't';
1N/A @INC = '../lib';
1N/A $| = 1;
1N/A}
1N/A
1N/Aprint "1..100\n";
1N/A
1N/A$a = {};
1N/Abless $a, "Bob";
1N/Aprint "not " unless $a->isa("Bob");
1N/Aprint "ok 1\n";
1N/A
1N/Apackage Human;
1N/Asub eat {}
1N/A
1N/Apackage Female;
1N/A@ISA=qw(Human);
1N/A
1N/Apackage Alice;
1N/A@ISA=qw(Bob Female);
1N/Asub sing;
1N/Asub drink { return "drinking " . $_[1] }
1N/Asub new { bless {} }
1N/A
1N/A$Alice::VERSION = 2.718;
1N/A
1N/A{
1N/A package Cedric;
1N/A our @ISA;
1N/A use base qw(Human);
1N/A}
1N/A
1N/A{
1N/A package Programmer;
1N/A our $VERSION = 1.667;
1N/A
1N/A sub write_perl { 1 }
1N/A}
1N/A
1N/Apackage main;
1N/A
1N/A{ my $i = 2;
1N/A sub test {
1N/A print "not " unless $_[0];
1N/A print "ok ", $i++;
1N/A print " # at ", (caller)[1], ", line ", (caller)[2] unless $_[0];
1N/A print "\n";
1N/A }
1N/A}
1N/A
1N/A$a = new Alice;
1N/A
1N/Atest $a->isa("Alice");
1N/Atest $a->isa("main::Alice"); # check that alternate class names work
1N/A
1N/Atest(("main::Alice"->new)->isa("Alice"));
1N/A
1N/Atest $a->isa("Bob");
1N/Atest $a->isa("main::Bob");
1N/A
1N/Atest $a->isa("Female");
1N/A
1N/Atest $a->isa("Human");
1N/A
1N/Atest ! $a->isa("Male");
1N/A
1N/Atest ! $a->isa('Programmer');
1N/A
1N/Atest $a->isa("HASH");
1N/A
1N/Atest $a->can("eat");
1N/Atest ! $a->can("sleep");
1N/Atest my $ref = $a->can("drink"); # returns a coderef
1N/Atest $a->$ref("tea") eq "drinking tea"; # ... which works
1N/Atest $ref = $a->can("sing");
1N/Aeval { $a->$ref() };
1N/Atest $@; # ... but not if no actual subroutine
1N/A
1N/Atest (!Cedric->isa('Programmer'));
1N/A
1N/Atest (Cedric->isa('Human'));
1N/A
1N/Apush(@Cedric::ISA,'Programmer');
1N/A
1N/Atest (Cedric->isa('Programmer'));
1N/A
1N/A{
1N/A package Alice;
1N/A base::->import('Programmer');
1N/A}
1N/A
1N/Atest $a->isa('Programmer');
1N/Atest $a->isa("Female");
1N/A
1N/A@Cedric::ISA = qw(Bob);
1N/A
1N/Atest (!Cedric->isa('Programmer'));
1N/A
1N/Amy $b = 'abc';
1N/Amy @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE);
1N/Amy @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} );
1N/Afor ($p=0; $p < @refs; $p++) {
1N/A for ($q=0; $q < @vals; $q++) {
1N/A test UNIVERSAL::isa($vals[$p], $refs[$q]) eq ($p==$q or $p+$q==1);
1N/A };
1N/A};
1N/A
1N/Atest ! UNIVERSAL::can(23, "can");
1N/A
1N/Atest $a->can("VERSION");
1N/A
1N/Atest $a->can("can");
1N/Atest ! $a->can("export_tags"); # a method in Exporter
1N/A
1N/Atest (eval { $a->VERSION }) == 2.718;
1N/A
1N/Atest ! (eval { $a->VERSION(2.719) }) &&
1N/A $@ =~ /^Alice version 2.71(?:9|8999\d+) required--this is only version 2.718 at /;
1N/A
1N/Atest (eval { $a->VERSION(2.718) }) && ! $@;
1N/A
1N/Amy $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
1N/A## The test for import here is *not* because we want to ensure that UNIVERSAL
1N/A## can always import; it is an historical accident that UNIVERSAL can import.
1N/Aif ('a' lt 'A') {
1N/A test $subs eq "can import isa VERSION";
1N/A} else {
1N/A test $subs eq "VERSION can import isa";
1N/A}
1N/A
1N/Atest $a->isa("UNIVERSAL");
1N/A
1N/Atest ! UNIVERSAL::isa([], "UNIVERSAL");
1N/A
1N/Atest ! UNIVERSAL::can({}, "can");
1N/A
1N/Atest UNIVERSAL::isa(Alice => "UNIVERSAL");
1N/A
1N/Atest UNIVERSAL::can(Alice => "can") == \&UNIVERSAL::can;
1N/A
1N/A# now use UNIVERSAL.pm and see what changes
1N/Aeval "use UNIVERSAL";
1N/A
1N/Atest $a->isa("UNIVERSAL");
1N/A
1N/Amy $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
1N/A# XXX import being here is really a bug
1N/Aif ('a' lt 'A') {
1N/A test $sub2 eq "can import isa VERSION";
1N/A} else {
1N/A test $sub2 eq "VERSION can import isa";
1N/A}
1N/A
1N/Aeval 'sub UNIVERSAL::sleep {}';
1N/Atest $a->can("sleep");
1N/A
1N/Atest ! UNIVERSAL::can($b, "can");
1N/A
1N/Atest ! $a->can("export_tags"); # a method in Exporter
1N/A
1N/Atest ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH');
1N/A
1N/A{
1N/A package Pickup;
1N/A use UNIVERSAL qw( isa can VERSION );
1N/A
1N/A main::test isa "Pickup", UNIVERSAL;
1N/A main::test can( "Pickup", "can" ) == \&UNIVERSAL::can;
1N/A main::test VERSION "UNIVERSAL" ;
1N/A}
1N/A
1N/A{
1N/A # test isa() and can() on magic variables
1N/A "Human" =~ /(.*)/;
1N/A test $1->isa("Human");
1N/A test $1->can("eat");
1N/A package HumanTie;
1N/A sub TIESCALAR { bless {} }
1N/A sub FETCH { "Human" }
1N/A tie my($x), "HumanTie";
1N/A ::test $x->isa("Human");
1N/A ::test $x->can("eat");
1N/A}
1N/A
1N/A# bugid 3284
1N/A# a second call to isa('UNIVERSAL') when @ISA is null failed due to caching
1N/A
1N/A@X::ISA=();
1N/Amy $x = {}; bless $x, 'X';
1N/Atest $x->isa('UNIVERSAL');
1N/Atest $x->isa('UNIVERSAL');