Extra paranoia from Nicholas Clark.
[p5sagit/p5-mst-13.2.git] / ext / Opcode / Opcode.t
1 #!./perl -w
2
3 $|=1;
4
5 BEGIN {
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
15 use 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
21 use strict;
22
23 my $t = 1;
24 my $last_test; # initalised at end
25 print "1..$last_test\n";
26
27 my($s1, $s2, $s3);
28 my(@o1, @o2, @o3);
29
30 # --- opset_to_ops and opset
31
32 my @empty_l = opset_to_ops(empty_opset);
33 print @empty_l == 0 ?   "ok $t\n" : "not ok $t\n"; $t++;
34
35 my @full_l1  = opset_to_ops(full_opset);
36 print @full_l1 == opcodes() ? "ok $t\n" : "not ok $t\n"; $t++;
37 my @full_l2 = @full_l1; # = opcodes();  # XXX to be fixed
38 print "@full_l1" eq "@full_l2" ? "ok $t\n" : "not ok $t\n"; $t++;
39
40 @empty_l = opset_to_ops(opset(':none'));
41 print @empty_l == 0 ?   "ok $t\n" : "not ok $t\n"; $t++;
42
43 my @full_l3 = opset_to_ops(opset(':all'));
44 print  @full_l1  ==  @full_l3  ? "ok $t\n" : "not ok $t\n"; $t++;
45 print "@full_l1" eq "@full_l3" ? "ok $t\n" : "not ok $t\n"; $t++;
46
47 die $t unless $t == 7;
48 $s1 = opset(      'padsv');
49 $s2 = opset($s1,  'padav');
50 $s3 = opset($s2, '!padav');
51 print $s1 eq $s2 ? "not ok $t\n" : "ok $t\n"; ++$t;
52 print $s1 eq $s3 ? "ok $t\n" : "not ok $t\n"; ++$t;
53
54 # --- define_optag
55
56 print eval { opset(':_tst_') } ? "not ok $t\n" : "ok $t\n"; ++$t;
57 define_optag(":_tst_", opset(qw(padsv padav padhv)));
58 print eval { opset(':_tst_') } ? "ok $t\n" : "not ok $t\n"; ++$t;
59
60 # --- opdesc and opcodes
61
62 die $t unless $t == 11;
63 print opdesc("gv") eq "glob value" ? "ok $t\n" : "not ok $t\n"; $t++;
64 my @desc = opdesc(':_tst_','stub');
65 print "@desc" eq "private variable private array private hash stub"
66                                     ? "ok $t\n" : "not ok $t\n#@desc\n"; $t++;
67 print opcodes() ? "ok $t\n" : "not ok $t\n"; $t++;
68 print "ok $t\n"; ++$t;
69
70 # --- invert_opset
71
72 $s1 = opset(qw(fileno padsv padav));
73 @o2 = opset_to_ops(invert_opset($s1));
74 print @o2 == opcodes-3 ? "ok $t\n" : "not ok $t\n"; $t++;
75
76 # --- opmask
77
78 die $t unless $t == 16;
79 print opmask() eq empty_opset() ? "ok $t\n" : "not ok $t\n"; $t++;      # work
80 print length opmask() == int((opcodes()+7)/8) ? "ok $t\n" : "not ok $t\n"; $t++;
81
82 # --- verify_opset
83
84 print verify_opset($s1) && !verify_opset(42) ? "ok $t\n":"not ok $t\n"; $t++;
85
86 # --- opmask_add
87
88 opmask_add(opset(qw(fileno)));  # add to global op_mask
89 print eval 'fileno STDOUT' ? "not ok $t\n" : "ok $t\n"; $t++; # fail
90 print $@ =~ /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
99 print (($s1 | $s2) eq opset($s1,$s2) ? "ok $t\n":"not ok $t\n"); $t++;
100 print (($s2 & $s3) eq opset($s2)     ? "ok $t\n":"not ok $t\n"); $t++;
101 print (($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);
108 print "@o1" eq "@o2" ? "ok $t\n":"not ok $t\n"; $t++;
109
110 # --- finally, check some opname assertions
111
112 foreach(@full_l1) { die "bad opname: $_" if /\W/ or /^\d/ }
113
114 print "ok $last_test\n";
115 BEGIN { $last_test = 25 }