ext/B/t/terse.t

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