Commit | Line | Data |
3a5d7bb8 |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | } |
7 | |
31b49ad4 |
8 | use Test::More tests => 16; |
3a5d7bb8 |
9 | |
10 | use_ok( 'B::Terse' ); |
11 | |
12 | # indent should return a string indented four spaces times the argument |
1212f7d8 |
13 | is( B::Terse::indent(2), ' ' x 8, 'indent with an argument' ); |
14 | is( B::Terse::indent(), '', 'indent with no argument' ); |
3a5d7bb8 |
15 | |
16 | # this should fail without a reference |
17 | eval { B::Terse::terse('scalar') }; |
1212f7d8 |
18 | like( $@, qr/not a reference/, 'terse() fed bad parameters' ); |
3a5d7bb8 |
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') }; |
1212f7d8 |
25 | is( $@, '', 'compile()' ); |
26 | ok( defined &$sub, 'valid subref back from compile()' ); |
3a5d7bb8 |
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/ } |
31b49ad4 |
36 | qw ( OP COP LOOP PMOP UNOP BINOP LOGOP LISTOP PVOP ); |
3a5d7bb8 |
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}; |
1212f7d8 |
47 | like( $_, $ops{$op}, "$op " ); |
3a5d7bb8 |
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 |
31b49ad4 |
58 | # if you can think of a way to produce AV, NULL, PADOP, or SPECIAL, |
59 | # add it to the regex above too. (PADOPs are currently only produced |
60 | # under ithreads, though). |
3a5d7bb8 |
61 | # |
62 | use vars qw( $a $b ); |
63 | sub bar { |
64 | # OP SVOP COP IV here or in sub definition |
65 | my @bar = (1, 2, 3); |
66 | |
67 | # got a GV here |
68 | my $foo = $a + $b; |
69 | |
70 | # NV here |
71 | $a = 1.234; |
72 | |
73 | # this is awful, but it gives a PMOP |
74 | my $boo = split('', $foo); |
75 | |
31b49ad4 |
76 | # PVOP, LOOP |
3a5d7bb8 |
77 | LOOP: for (1 .. 10) { |
78 | last LOOP if $_ % 2; |
79 | } |
80 | |
81 | # make a PV |
82 | $foo = "a string"; |
f3be9b72 |
83 | |
84 | # make an OP_SUBSTCONT |
85 | $foo =~ s/(a)/$1/; |
3a5d7bb8 |
86 | } |
87 | |
31b49ad4 |
88 | # Schwern's example of finding an RV |
89 | my $path = join " ", map { qq["-I$_"] } @INC; |
90 | $path = '-I::lib -MMac::err=unix' if $^O eq 'MacOS'; |
91 | my $redir = $^O eq 'MacOS' ? '' : "2>&1"; |
92 | my $items = qx{$^X $path "-MO=Terse" -le "print \\42" $redir}; |
93 | like( $items, qr/RV $hex \\42/, 'RV' ); |
3a5d7bb8 |
94 | |
95 | package TieOut; |
96 | |
97 | sub TIEHANDLE { |
98 | bless( \(my $out), $_[0] ); |
99 | } |
100 | |
101 | sub PRINT { |
102 | my $self = shift; |
103 | $$self .= join('', @_); |
104 | } |
105 | |
106 | sub PRINTF { |
107 | my $self = shift; |
108 | $$self .= sprintf(@_); |
109 | } |
110 | |
111 | sub read { |
112 | my $self = shift; |
113 | return substr($$self, 0, length($$self), ''); |
114 | } |