1#!./perl -w 2 3$|=1; 4 5BEGIN { 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 13use strict; 14use 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 36my @empty_l = opset_to_ops(empty_opset); 37is_deeply (\@empty_l, []); 38 39my @full_l1 = opset_to_ops(full_opset); 40is (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')); 50is_deeply(\@empty_l, []); 51 52my @full_l3 = opset_to_ops(opset(':all')); 53is_deeply(\@full_l1, \@full_l3); 54 55my $s1 = opset( 'padsv'); 56my $s2 = opset($s1, 'padav'); 57my $s3 = opset($s2, '!padav'); 58isnt($s1, $s2); 59is($s1, $s3); 60 61# --- define_optag 62 63is(eval { opset(':_tst_') }, undef); 64like($@, qr/Unknown operator tag ":_tst_"/); 65define_optag(":_tst_", opset(qw(padsv padav padhv))); 66isnt(eval { opset(':_tst_') }, undef); 67is($@, ''); 68 69# --- opdesc and opcodes 70 71is(opdesc("gv"), "glob value"); 72my @desc = opdesc(':_tst_','stub'); 73is_deeply(\@desc, ['private variable', 'private array', 'private hash', 'stub']); 74isnt(opcodes(), 0); 75 76# --- invert_opset 77 78$s1 = opset(qw(fileno padsv padav)); 79my @o1 = opset_to_ops(invert_opset($s1)); 80is(scalar @o1, opcodes-3); 81 82# --- opmask 83 84is(opmask(), empty_opset()); 85is(length opmask(), int((opcodes()+7)/8)); 86 87# --- verify_opset 88 89is(verify_opset($s1), 1); 90is(verify_opset(42), 0); 91 92# --- opmask_add 93 94opmask_add(opset(qw(fileno))); # add to global op_mask 95is(eval 'fileno STDOUT', undef); 96like($@, 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 105is(($s1 | $s2), opset($s1,$s2)); 106is(($s2 & $s3), opset($s2)); 107is(($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); 113my @o2 = opset_to_ops(invert_opset $s3); 114is_deeply(\@o1, \@o2); 115 116# --- test context of undocumented _safe_call_sv (used by Safe.pm) 117 118my %inc = %INC; 119my $expect; 120sub f { 121 %INC = %inc; 122 no warnings 'uninitialized'; 123 is wantarray, $expect, 124 sprintf "_safe_call_sv gives %s context", 125 qw[void scalar list][$expect + defined $expect] 126}; 127Opcode::_safe_call_sv("main", empty_opset, \&f); 128$expect = !1; 129$_ = Opcode::_safe_call_sv("main", empty_opset, \&f); 130$expect = !0; 131() = Opcode::_safe_call_sv("main", empty_opset, \&f); 132 133# --- finally, check some opname assertions 134 135foreach my $opname (@full_l1) { 136 unlike($opname, qr/\W/, "opname $opname has no non-'word' characters"); 137 unlike($opname, qr/^\d/, "opname $opname does not start with a digit"); 138} 139 140done_testing(); 141