ext/B/t/terse.t

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