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