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