1*0Sstevel@tonic-gate#!./perl 2*0Sstevel@tonic-gate 3*0Sstevel@tonic-gateBEGIN { 4*0Sstevel@tonic-gate chdir 't' if -d 't'; 5*0Sstevel@tonic-gate @INC = '../lib'; 6*0Sstevel@tonic-gate} 7*0Sstevel@tonic-gate 8*0Sstevel@tonic-gateuse Test::More tests => 16; 9*0Sstevel@tonic-gate 10*0Sstevel@tonic-gateuse_ok( 'B::Terse' ); 11*0Sstevel@tonic-gate 12*0Sstevel@tonic-gate# indent should return a string indented four spaces times the argument 13*0Sstevel@tonic-gateis( B::Terse::indent(2), ' ' x 8, 'indent with an argument' ); 14*0Sstevel@tonic-gateis( B::Terse::indent(), '', 'indent with no argument' ); 15*0Sstevel@tonic-gate 16*0Sstevel@tonic-gate# this should fail without a reference 17*0Sstevel@tonic-gateeval { B::Terse::terse('scalar') }; 18*0Sstevel@tonic-gatelike( $@, qr/not a reference/, 'terse() fed bad parameters' ); 19*0Sstevel@tonic-gate 20*0Sstevel@tonic-gate# now point it at a sub and see what happens 21*0Sstevel@tonic-gatesub foo {} 22*0Sstevel@tonic-gate 23*0Sstevel@tonic-gatemy $sub; 24*0Sstevel@tonic-gateeval{ $sub = B::Terse::compile('', 'foo') }; 25*0Sstevel@tonic-gateis( $@, '', 'compile()' ); 26*0Sstevel@tonic-gateok( defined &$sub, 'valid subref back from compile()' ); 27*0Sstevel@tonic-gate 28*0Sstevel@tonic-gate# and point it at a real sub and hope the returned ops look alright 29*0Sstevel@tonic-gatemy $out = tie *STDOUT, 'TieOut'; 30*0Sstevel@tonic-gate$sub = B::Terse::compile('', 'bar'); 31*0Sstevel@tonic-gate$sub->(); 32*0Sstevel@tonic-gate 33*0Sstevel@tonic-gate# now build some regexes that should match the dumped ops 34*0Sstevel@tonic-gatemy ($hex, $op) = ('\(0x[a-f0-9]+\)', '\s+\w+'); 35*0Sstevel@tonic-gatemy %ops = map { $_ => qr/$_ $hex$op/ } 36*0Sstevel@tonic-gate qw ( OP COP LOOP PMOP UNOP BINOP LOGOP LISTOP PVOP ); 37*0Sstevel@tonic-gate 38*0Sstevel@tonic-gate# split up the output lines into individual ops (terse is, well, terse!) 39*0Sstevel@tonic-gate# use an array here so $_ is modifiable 40*0Sstevel@tonic-gatemy @lines = split(/\n+/, $out->read); 41*0Sstevel@tonic-gateforeach (@lines) { 42*0Sstevel@tonic-gate next unless /\S/; 43*0Sstevel@tonic-gate s/^\s+//; 44*0Sstevel@tonic-gate if (/^([A-Z]+)\s+/) { 45*0Sstevel@tonic-gate my $op = $1; 46*0Sstevel@tonic-gate next unless exists $ops{$op}; 47*0Sstevel@tonic-gate like( $_, $ops{$op}, "$op " ); 48*0Sstevel@tonic-gate delete $ops{$op}; 49*0Sstevel@tonic-gate s/$ops{$op}//; 50*0Sstevel@tonic-gate redo if $_; 51*0Sstevel@tonic-gate } 52*0Sstevel@tonic-gate} 53*0Sstevel@tonic-gate 54*0Sstevel@tonic-gatewarn "# didn't find " . join(' ', keys %ops) if keys %ops; 55*0Sstevel@tonic-gate 56*0Sstevel@tonic-gate# XXX: 57*0Sstevel@tonic-gate# this tries to get at all tersified optypes in B::Terse 58*0Sstevel@tonic-gate# if you can think of a way to produce AV, NULL, PADOP, or SPECIAL, 59*0Sstevel@tonic-gate# add it to the regex above too. (PADOPs are currently only produced 60*0Sstevel@tonic-gate# under ithreads, though). 61*0Sstevel@tonic-gate# 62*0Sstevel@tonic-gateuse vars qw( $a $b ); 63*0Sstevel@tonic-gatesub bar { 64*0Sstevel@tonic-gate # OP SVOP COP IV here or in sub definition 65*0Sstevel@tonic-gate my @bar = (1, 2, 3); 66*0Sstevel@tonic-gate 67*0Sstevel@tonic-gate # got a GV here 68*0Sstevel@tonic-gate my $foo = $a + $b; 69*0Sstevel@tonic-gate 70*0Sstevel@tonic-gate # NV here 71*0Sstevel@tonic-gate $a = 1.234; 72*0Sstevel@tonic-gate 73*0Sstevel@tonic-gate # this is awful, but it gives a PMOP 74*0Sstevel@tonic-gate my $boo = split('', $foo); 75*0Sstevel@tonic-gate 76*0Sstevel@tonic-gate # PVOP, LOOP 77*0Sstevel@tonic-gate LOOP: for (1 .. 10) { 78*0Sstevel@tonic-gate last LOOP if $_ % 2; 79*0Sstevel@tonic-gate } 80*0Sstevel@tonic-gate 81*0Sstevel@tonic-gate # make a PV 82*0Sstevel@tonic-gate $foo = "a string"; 83*0Sstevel@tonic-gate 84*0Sstevel@tonic-gate # make an OP_SUBSTCONT 85*0Sstevel@tonic-gate $foo =~ s/(a)/$1/; 86*0Sstevel@tonic-gate} 87*0Sstevel@tonic-gate 88*0Sstevel@tonic-gate# Schwern's example of finding an RV 89*0Sstevel@tonic-gatemy $path = join " ", map { qq["-I$_"] } @INC; 90*0Sstevel@tonic-gate$path = '-I::lib -MMac::err=unix' if $^O eq 'MacOS'; 91*0Sstevel@tonic-gatemy $redir = $^O eq 'MacOS' ? '' : "2>&1"; 92*0Sstevel@tonic-gatemy $items = qx{$^X $path "-MO=Terse" -le "print \\42" $redir}; 93*0Sstevel@tonic-gatelike( $items, qr/RV $hex \\42/, 'RV' ); 94*0Sstevel@tonic-gate 95*0Sstevel@tonic-gatepackage TieOut; 96*0Sstevel@tonic-gate 97*0Sstevel@tonic-gatesub TIEHANDLE { 98*0Sstevel@tonic-gate bless( \(my $out), $_[0] ); 99*0Sstevel@tonic-gate} 100*0Sstevel@tonic-gate 101*0Sstevel@tonic-gatesub PRINT { 102*0Sstevel@tonic-gate my $self = shift; 103*0Sstevel@tonic-gate $$self .= join('', @_); 104*0Sstevel@tonic-gate} 105*0Sstevel@tonic-gate 106*0Sstevel@tonic-gatesub PRINTF { 107*0Sstevel@tonic-gate my $self = shift; 108*0Sstevel@tonic-gate $$self .= sprintf(@_); 109*0Sstevel@tonic-gate} 110*0Sstevel@tonic-gate 111*0Sstevel@tonic-gatesub read { 112*0Sstevel@tonic-gate my $self = shift; 113*0Sstevel@tonic-gate return substr($$self, 0, length($$self), ''); 114*0Sstevel@tonic-gate} 115