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 Testcase1 { 16 method hello { return "hello, world"; } 17 18 method classname { return __CLASS__; } 19 } 20 21 my $obj = Testcase1->new; 22 isa_ok($obj, "Testcase1", '$obj'); 23 24 is($obj->hello, "hello, world", '$obj->hello'); 25 26 is($obj->classname, "Testcase1", '$obj->classname yields __CLASS__'); 27} 28 29# Classes are still regular packages 30{ 31 class Testcase2 { 32 my $ok = "OK"; 33 sub NotAMethod { return $ok } 34 } 35 36 is(Testcase2::NotAMethod(), "OK", 'Class can contain regular subs'); 37} 38 39# Classes accept full package names 40{ 41 class Testcase3::Foo { 42 method hello { return "This" } 43 } 44 is(Testcase3::Foo->new->hello, "This", 'Class supports fully-qualified package names'); 45} 46 47# Unit class 48{ 49 class Testcase4::A; 50 method m { return "unit-A" } 51 52 class Testcase4::B; 53 method m { return "unit-B" } 54 55 package main; 56 ok(eq_array([Testcase4::A->new->m, Testcase4::B->new->m], ["unit-A", "unit-B"]), 57 'Unit class syntax works'); 58} 59 60# Class {BLOCK} syntax parses like package 61{ 62 my $result = ""; 63 eval q{ 64 $result .= "a(" . __PACKAGE__ . "/" . eval("__PACKAGE__") . ")\n"; 65 class Testcase5 1.23 { 66 $result .= "b(" . __PACKAGE__ . "/" . eval("__PACKAGE__") . ")\n"; 67 } 68 $result .= "c(" . __PACKAGE__ . "/" . eval("__PACKAGE__") . ")\n"; 69 } or die $@; 70 is($result, "a(main/main)\nb(Testcase5/Testcase5)\nc(main/main)\n", 71 'class sets __PACKAGE__ correctly'); 72 is($Testcase5::VERSION, 1.23, 'class NAME VERSION { BLOCK } sets $VERSION'); 73} 74 75# Unit class syntax parses like package 76{ 77 my $result = ""; 78 eval q{ 79 $result .= "a(" . __PACKAGE__ . "/" . eval("__PACKAGE__") . ")\n"; 80 class Testcase6 4.56; 81 $result .= "b(" . __PACKAGE__ . "/" . eval("__PACKAGE__") . ")\n"; 82 package main; 83 $result .= "c(" . __PACKAGE__ . "/" . eval("__PACKAGE__") . ")\n"; 84 } or die $@; 85 is($result, "a(main/main)\nb(Testcase6/Testcase6)\nc(main/main)\n", 86 'class sets __PACKAGE__ correctly'); 87 is($Testcase6::VERSION, 4.56, 'class NAME VERSION; sets $VERSION'); 88} 89 90done_testing; 91