| 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 | } |