ext/B/t/terse.t

   1 #!./perl
   2
   3 BEGIN {
   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
  17 use Test::More tests => 16;
  18
  19 use_ok( 'B::Terse' );
  20
  21 # indent should return a string indented four spaces times the argument
  22 is( B::Terse::indent(2), ' ' x 8, 'indent with an argument' );
  23 is( B::Terse::indent(), '', 'indent with no argument' );
  24
  25 # this should fail without a reference
  26 eval { B::Terse::terse('scalar') };
  27 like( $@, qr/not a reference/, 'terse() fed bad parameters' );
  28
  29 # now point it at a sub and see what happens
  30 sub foo {}
  31
  32 my $sub;
  33 eval{ $sub = B::Terse::compile('', 'foo') };
  34 is( $@, '', 'compile()' );
  35 ok( defined &$sub, 'valid subref back from compile()' );
  36
  37 # and point it at a real sub and hope the returned ops look alright
  38 my $out = tie *STDOUT, 'TieOut';
  39 $sub = B::Terse::compile('', 'bar');
  40 $sub->();
  41
  42 # now build some regexes that should match the dumped ops
  43 my ($hex, $op) = ('\(0x[a-f0-9]+\)', '\s+\w+');
  44 my %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
  49 my @lines = split(/\n+/, $out->read);
  50 foreach (@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
  63 warn "# 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 #
  71 use vars qw( $a $b );
  72 sub 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
  98 my $path = join " ", map { qq["-I$_"] } @INC;
  99 $path = '-I::lib -MMac::err=unix' if $^O eq 'MacOS';
 100 my $redir = $^O eq 'MacOS' ? '' : "2>&1";
 101 my $items = qx{$^X $path "-MO=Terse" -le "print \\42" $redir};
 102 like( $items, qr/RV $hex \\42/, 'RV' );
 103
 104 package TieOut;
 105
 106 sub TIEHANDLE {
 107         bless( \(my $out), $_[0] );
 108 }
 109
 110 sub PRINT {
 111         my $self = shift;
 112         $$self .= join('', @_);
 113 }
 114
 115 sub PRINTF {
 116         my $self = shift;
 117         $$self .= sprintf(@_);
 118 }
 119
 120 sub read {
 121         my $self = shift;
 122         return substr($$self, 0, length($$self), '');
 123 }