1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('../lib'); 7 require Config; 8} 9 10use v5.36; 11use feature 'class'; 12no warnings 'experimental::class'; 13 14{ 15 class Testcase1A { 16 field $inita = "base"; 17 method inita { return $inita; } 18 field $adja; 19 ADJUST { $adja = "base class" } 20 method adja { return $adja; } 21 22 method classname { return __CLASS__; } 23 } 24 25 class Testcase1B :isa(Testcase1A) { 26 field $initb = "derived"; 27 method initb { return $initb; } 28 field $adjb; 29 ADJUST { $adjb = "derived class" } 30 method adjb { return $adjb; } 31 } 32 33 my $obj = Testcase1B->new; 34 ok($obj isa Testcase1B, 'Object is its own class'); 35 ok($obj isa Testcase1A, 'Object is also its base class'); 36 37 ok(eq_array(\@Testcase1B::ISA, ["Testcase1A"]), '@Testcase1B::ISA is set correctly'); 38 39 is($obj->initb, "derived", 'Object has derived class initialised field'); 40 is($obj->adjb, "derived class", 'Object has derived class ADJUSTed field'); 41 42 can_ok($obj, "inita"); 43 is($obj->inita, "base", 'Object has base class initialised field'); 44 can_ok($obj, "adja"); 45 is($obj->adja, "base class", 'Object has base class ADJUSTed field'); 46 47 is($obj->classname, "Testcase1B", '__CLASS__ yields runtime instance class name'); 48 49 class Testcase1C :isa( Testcase1A ) { } 50 51 my $objc = Testcase1C->new; 52 ok($objc isa Testcase1A, ':isa attribute trims whitespace'); 53} 54 55{ 56 class Testcase2A 1.23 { } 57 58 class Testcase2B :isa(Testcase2A 1.0) { } # OK 59 60 ok(!defined eval "class Testcase2C :isa(Testcase2A 2.0) {}; 1", 61 ':isa() version test can throw'); 62 like($@, qr/^Testcase2A version 2\.0 required--this is only version 1\.23 at /, 63 'Exception thrown from :isa version test'); 64} 65 66{ 67 class Testcase3A { 68 field $x :param; 69 method x { return $x; } 70 } 71 72 class Testcase3B :isa(Testcase3A) {} 73 74 my $obj = Testcase3B->new(x => "X"); 75 is($obj->x, "X", 'Constructor params passed through to superclass'); 76} 77 78{ 79 class Testcase4A { } 80 81 class Testcase4B :isa(Testcase4A); 82 83 package main; 84 my $obj = Testcase4B->new; 85 ok($obj isa Testcase4A, 'Unit class syntax allows :isa'); 86} 87 88{ 89 class Testcase5A { 90 field $classname = __CLASS__; 91 method classname { return $classname } 92 } 93 94 class Testcase5B :isa(Testcase5A) { } 95 96 is(Testcase5B->new->classname, "Testcase5B", '__CLASS__ yields correct class name for subclass'); 97} 98 99{ 100 # https://github.com/Perl/perl5/issues/21332 101 use lib 'lib/class'; 102 ok(eval <<'EOS', "hierarchical base class loaded"); 103use A::B; 1041; 105EOS 106} 107 108{ 109 # https://github.com/Perl/perl5/issues/20891 110 class Testcase6A 1.23 {} 111 class Testcase6B 1.23 :isa(Testcase6A) {} 112 113 ok(Testcase6B->new isa Testcase6A, 'Testcase6B inherits Testcase6B'); 114 is(Testcase6B->VERSION, 1.23, 'Testcase6B sets VERSION'); 115} 116 117done_testing; 118