ext/Opcode/t/Opcode.t

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