ext/B/t/terse.t

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