Extra paranoia from Nicholas Clark.
[p5sagit/p5-mst-13.2.git] / ext / Opcode / Opcode.t
CommitLineData
76d62587 1#!./perl -w
2
3$|=1;
4
5BEGIN {
6 chdir 't' if -d 't';
20822f61 7 @INC = '../lib';
76d62587 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
a7adf1f0 80print length opmask() == int((opcodes()+7)/8) ? "ok $t\n" : "not ok $t\n"; $t++;
76d62587 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 }