1#!./perl -w 2 3$|=1; 4 5BEGIN { 6 chdir 't' if -d 't'; 7 @INC = '../lib'; 8 require Config; import Config; 9 if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { 10 print "1..0\n"; 11 exit 0; 12 } 13} 14 15use Opcode qw( 16 opcodes opdesc opmask verify_opset 17 opset opset_to_ops opset_to_hex invert_opset 18 opmask_add full_opset empty_opset define_optag 19); 20 21use strict; 22 23my $t = 1; 24my $last_test; # initalised at end 25print "1..$last_test\n"; 26 27my($s1, $s2, $s3); 28my(@o1, @o2, @o3); 29 30# --- opset_to_ops and opset 31 32my @empty_l = opset_to_ops(empty_opset); 33print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++; 34 35my @full_l1 = opset_to_ops(full_opset); 36print @full_l1 == opcodes() ? "ok $t\n" : "not ok $t\n"; $t++; 37my @full_l2 = @full_l1; # = opcodes(); # XXX to be fixed 38print "@full_l1" eq "@full_l2" ? "ok $t\n" : "not ok $t\n"; $t++; 39 40@empty_l = opset_to_ops(opset(':none')); 41print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++; 42 43my @full_l3 = opset_to_ops(opset(':all')); 44print @full_l1 == @full_l3 ? "ok $t\n" : "not ok $t\n"; $t++; 45print "@full_l1" eq "@full_l3" ? "ok $t\n" : "not ok $t\n"; $t++; 46 47die $t unless $t == 7; 48$s1 = opset( 'padsv'); 49$s2 = opset($s1, 'padav'); 50$s3 = opset($s2, '!padav'); 51print $s1 eq $s2 ? "not ok $t\n" : "ok $t\n"; ++$t; 52print $s1 eq $s3 ? "ok $t\n" : "not ok $t\n"; ++$t; 53 54# --- define_optag 55 56print eval { opset(':_tst_') } ? "not ok $t\n" : "ok $t\n"; ++$t; 57define_optag(":_tst_", opset(qw(padsv padav padhv))); 58print eval { opset(':_tst_') } ? "ok $t\n" : "not ok $t\n"; ++$t; 59 60# --- opdesc and opcodes 61 62die $t unless $t == 11; 63print opdesc("gv") eq "glob value" ? "ok $t\n" : "not ok $t\n"; $t++; 64my @desc = opdesc(':_tst_','stub'); 65print "@desc" eq "private variable private array private hash stub" 66 ? "ok $t\n" : "not ok $t\n#@desc\n"; $t++; 67print opcodes() ? "ok $t\n" : "not ok $t\n"; $t++; 68print "ok $t\n"; ++$t; 69 70# --- invert_opset 71 72$s1 = opset(qw(fileno padsv padav)); 73@o2 = opset_to_ops(invert_opset($s1)); 74print @o2 == opcodes-3 ? "ok $t\n" : "not ok $t\n"; $t++; 75 76# --- opmask 77 78die $t unless $t == 16; 79print opmask() eq empty_opset() ? "ok $t\n" : "not ok $t\n"; $t++; # work 80print length opmask() == int((opcodes()+7)/8) ? "ok $t\n" : "not ok $t\n"; $t++; 81 82# --- verify_opset 83 84print verify_opset($s1) && !verify_opset(42) ? "ok $t\n":"not ok $t\n"; $t++; 85 86# --- opmask_add 87 88opmask_add(opset(qw(fileno))); # add to global op_mask 89print eval 'fileno STDOUT' ? "not ok $t\n" : "ok $t\n"; $t++; # fail 90print $@ =~ /'fileno' trapped/ ? "ok $t\n" : "not ok $t\n# $@\n"; $t++; 91 92# --- check use of bit vector ops on opsets 93 94$s1 = opset('padsv'); 95$s2 = opset('padav'); 96$s3 = opset('padsv', 'padav', 'padhv'); 97 98# Non-negated 99print (($s1 | $s2) eq opset($s1,$s2) ? "ok $t\n":"not ok $t\n"); $t++; 100print (($s2 & $s3) eq opset($s2) ? "ok $t\n":"not ok $t\n"); $t++; 101print (($s2 ^ $s3) eq opset('padsv','padhv') ? "ok $t\n":"not ok $t\n"); $t++; 102 103# Negated, e.g., with possible extra bits in last byte beyond last op bit. 104# The extra bits mean we can't just say ~mask eq invert_opset(mask). 105 106@o1 = opset_to_ops( ~ $s3); 107@o2 = opset_to_ops(invert_opset $s3); 108print "@o1" eq "@o2" ? "ok $t\n":"not ok $t\n"; $t++; 109 110# --- finally, check some opname assertions 111 112foreach(@full_l1) { die "bad opname: $_" if /\W/ or /^\d/ } 113 114print "ok $last_test\n"; 115BEGIN { $last_test = 25 } 116