1N/A#!./perl -w
1N/A
1N/A$|=1;
1N/A
1N/ABEGIN {
1N/A chdir 't' if -d 't';
1N/A @INC = '../lib';
1N/A require Config; import Config;
1N/A if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
1N/A print "1..0\n";
1N/A exit 0;
1N/A }
1N/A}
1N/A
1N/Ause Opcode qw(
1N/A opcodes opdesc opmask verify_opset
1N/A opset opset_to_ops opset_to_hex invert_opset
1N/A opmask_add full_opset empty_opset define_optag
1N/A);
1N/A
1N/Ause strict;
1N/A
1N/Amy $t = 1;
1N/Amy $last_test; # initalised at end
1N/Aprint "1..$last_test\n";
1N/A
1N/Amy($s1, $s2, $s3);
1N/Amy(@o1, @o2, @o3);
1N/A
1N/A# --- opset_to_ops and opset
1N/A
1N/Amy @empty_l = opset_to_ops(empty_opset);
1N/Aprint @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++;
1N/A
1N/Amy @full_l1 = opset_to_ops(full_opset);
1N/Aprint @full_l1 == opcodes() ? "ok $t\n" : "not ok $t\n"; $t++;
1N/Amy @full_l2 = @full_l1; # = opcodes(); # XXX to be fixed
1N/Aprint "@full_l1" eq "@full_l2" ? "ok $t\n" : "not ok $t\n"; $t++;
1N/A
1N/A@empty_l = opset_to_ops(opset(':none'));
1N/Aprint @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++;
1N/A
1N/Amy @full_l3 = opset_to_ops(opset(':all'));
1N/Aprint @full_l1 == @full_l3 ? "ok $t\n" : "not ok $t\n"; $t++;
1N/Aprint "@full_l1" eq "@full_l3" ? "ok $t\n" : "not ok $t\n"; $t++;
1N/A
1N/Adie $t unless $t == 7;
1N/A$s1 = opset( 'padsv');
1N/A$s2 = opset($s1, 'padav');
1N/A$s3 = opset($s2, '!padav');
1N/Aprint $s1 eq $s2 ? "not ok $t\n" : "ok $t\n"; ++$t;
1N/Aprint $s1 eq $s3 ? "ok $t\n" : "not ok $t\n"; ++$t;
1N/A
1N/A# --- define_optag
1N/A
1N/Aprint eval { opset(':_tst_') } ? "not ok $t\n" : "ok $t\n"; ++$t;
1N/Adefine_optag(":_tst_", opset(qw(padsv padav padhv)));
1N/Aprint eval { opset(':_tst_') } ? "ok $t\n" : "not ok $t\n"; ++$t;
1N/A
1N/A# --- opdesc and opcodes
1N/A
1N/Adie $t unless $t == 11;
1N/Aprint opdesc("gv") eq "glob value" ? "ok $t\n" : "not ok $t\n"; $t++;
1N/Amy @desc = opdesc(':_tst_','stub');
1N/Aprint "@desc" eq "private variable private array private hash stub"
1N/A ? "ok $t\n" : "not ok $t\n#@desc\n"; $t++;
1N/Aprint opcodes() ? "ok $t\n" : "not ok $t\n"; $t++;
1N/Aprint "ok $t\n"; ++$t;
1N/A
1N/A# --- invert_opset
1N/A
1N/A$s1 = opset(qw(fileno padsv padav));
1N/A@o2 = opset_to_ops(invert_opset($s1));
1N/Aprint @o2 == opcodes-3 ? "ok $t\n" : "not ok $t\n"; $t++;
1N/A
1N/A# --- opmask
1N/A
1N/Adie $t unless $t == 16;
1N/Aprint opmask() eq empty_opset() ? "ok $t\n" : "not ok $t\n"; $t++; # work
1N/Aprint length opmask() == int((opcodes()+7)/8) ? "ok $t\n" : "not ok $t\n"; $t++;
1N/A
1N/A# --- verify_opset
1N/A
1N/Aprint verify_opset($s1) && !verify_opset(42) ? "ok $t\n":"not ok $t\n"; $t++;
1N/A
1N/A# --- opmask_add
1N/A
1N/Aopmask_add(opset(qw(fileno))); # add to global op_mask
1N/Aprint eval 'fileno STDOUT' ? "not ok $t\n" : "ok $t\n"; $t++; # fail
1N/Aprint $@ =~ /'fileno' trapped/ ? "ok $t\n" : "not ok $t\n# $@\n"; $t++;
1N/A
1N/A# --- check use of bit vector ops on opsets
1N/A
1N/A$s1 = opset('padsv');
1N/A$s2 = opset('padav');
1N/A$s3 = opset('padsv', 'padav', 'padhv');
1N/A
1N/A# Non-negated
1N/Aprint (($s1 | $s2) eq opset($s1,$s2) ? "ok $t\n":"not ok $t\n"); $t++;
1N/Aprint (($s2 & $s3) eq opset($s2) ? "ok $t\n":"not ok $t\n"); $t++;
1N/Aprint (($s2 ^ $s3) eq opset('padsv','padhv') ? "ok $t\n":"not ok $t\n"); $t++;
1N/A
1N/A# Negated, e.g., with possible extra bits in last byte beyond last op bit.
1N/A# The extra bits mean we can't just say ~mask eq invert_opset(mask).
1N/A
1N/A@o1 = opset_to_ops( ~ $s3);
1N/A@o2 = opset_to_ops(invert_opset $s3);
1N/Aprint "@o1" eq "@o2" ? "ok $t\n":"not ok $t\n"; $t++;
1N/A
1N/A# --- finally, check some opname assertions
1N/A
1N/Aforeach(@full_l1) { die "bad opname: $_" if /\W/ or /^\d/ }
1N/A
1N/Aprint "ok $last_test\n";
1N/ABEGIN { $last_test = 25 }