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