contrib/perl5/t/lib/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 }