Commit | Line | Data |
---|---|---|
3a5d7bb8 JH |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
5638aaac SM |
4 | if ($ENV{PERL_CORE}){ |
5 | chdir('t') if -d 't'; | |
6 | @INC = ('.', '../lib'); | |
7 | } else { | |
8 | unshift @INC, 't'; | |
9 | } | |
9cd8f857 NC |
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 | } | |
3a5d7bb8 JH |
15 | } |
16 | ||
31b49ad4 | 17 | use Test::More tests => 16; |
3a5d7bb8 JH |
18 | |
19 | use_ok( 'B::Terse' ); | |
20 | ||
21 | # indent should return a string indented four spaces times the argument | |
1212f7d8 JH |
22 | is( B::Terse::indent(2), ' ' x 8, 'indent with an argument' ); |
23 | is( B::Terse::indent(), '', 'indent with no argument' ); | |
3a5d7bb8 JH |
24 | |
25 | # this should fail without a reference | |
26 | eval { B::Terse::terse('scalar') }; | |
1212f7d8 | 27 | like( $@, qr/not a reference/, 'terse() fed bad parameters' ); |
3a5d7bb8 JH |
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') }; | |
1212f7d8 JH |
34 | is( $@, '', 'compile()' ); |
35 | ok( defined &$sub, 'valid subref back from compile()' ); | |
3a5d7bb8 JH |
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/ } | |
31b49ad4 | 45 | qw ( OP COP LOOP PMOP UNOP BINOP LOGOP LISTOP PVOP ); |
3a5d7bb8 JH |
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}; | |
1212f7d8 | 56 | like( $_, $ops{$op}, "$op " ); |
3a5d7bb8 | 57 | s/$ops{$op}//; |
5638aaac | 58 | delete $ops{$op}; |
3a5d7bb8 JH |
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 | |
31b49ad4 SM |
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). | |
3a5d7bb8 JH |
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 | |
5638aaac | 83 | our @ary = split('', $foo); |
3a5d7bb8 | 84 | |
31b49ad4 | 85 | # PVOP, LOOP |
3a5d7bb8 JH |
86 | LOOP: for (1 .. 10) { |
87 | last LOOP if $_ % 2; | |
88 | } | |
89 | ||
90 | # make a PV | |
91 | $foo = "a string"; | |
f3be9b72 RGS |
92 | |
93 | # make an OP_SUBSTCONT | |
94 | $foo =~ s/(a)/$1/; | |
3a5d7bb8 JH |
95 | } |
96 | ||
31b49ad4 SM |
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' ); | |
3a5d7bb8 JH |
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 | } |