This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Eliminate SVt_RV, and use SVt_IV to store plain references.
[perl5.git] / ext / B / t / terse.t
CommitLineData
3a5d7bb8
JH
1#!./perl
2
3BEGIN {
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 17use Test::More tests => 16;
3a5d7bb8
JH
18
19use_ok( 'B::Terse' );
20
21# indent should return a string indented four spaces times the argument
1212f7d8
JH
22is( B::Terse::indent(2), ' ' x 8, 'indent with an argument' );
23is( B::Terse::indent(), '', 'indent with no argument' );
3a5d7bb8
JH
24
25# this should fail without a reference
26eval { B::Terse::terse('scalar') };
1212f7d8 27like( $@, qr/not a reference/, 'terse() fed bad parameters' );
3a5d7bb8
JH
28
29# now point it at a sub and see what happens
30sub foo {}
31
32my $sub;
33eval{ $sub = B::Terse::compile('', 'foo') };
1212f7d8
JH
34is( $@, '', 'compile()' );
35ok( 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
38my $out = tie *STDOUT, 'TieOut';
39$sub = B::Terse::compile('', 'bar');
40$sub->();
41
42# now build some regexes that should match the dumped ops
43my ($hex, $op) = ('\(0x[a-f0-9]+\)', '\s+\w+');
44my %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
49my @lines = split(/\n+/, $out->read);
50foreach (@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
63warn "# 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#
71use vars qw( $a $b );
72sub 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
98my $path = join " ", map { qq["-I$_"] } @INC;
99$path = '-I::lib -MMac::err=unix' if $^O eq 'MacOS';
100my $redir = $^O eq 'MacOS' ? '' : "2>&1";
101my $items = qx{$^X $path "-MO=Terse" -le "print \\42" $redir};
4df7f6af
NC
102if( $] >= 5.011 ) {
103 like( $items, qr/IV $hex \\42/, 'RV (but now stored in an IV)' );
104} else {
105 like( $items, qr/RV $hex \\42/, 'RV' );
106}
3a5d7bb8
JH
107
108package TieOut;
109
110sub TIEHANDLE {
111 bless( \(my $out), $_[0] );
112}
113
114sub PRINT {
115 my $self = shift;
116 $$self .= join('', @_);
117}
118
119sub PRINTF {
120 my $self = shift;
121 $$self .= sprintf(@_);
122}
123
124sub read {
125 my $self = shift;
126 return substr($$self, 0, length($$self), '');
127}