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
1 #!./perl
2
3 BEGIN {
4         if ($ENV{PERL_CORE}){
5                 chdir('t') if -d 't';
6                 @INC = ('.', '../lib');
7         } else {
8                 unshift @INC, 't';
9         }
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         }
15 }
16
17 use Test::More tests => 16;
18
19 use_ok( 'B::Terse' );
20
21 # indent should return a string indented four spaces times the argument
22 is( B::Terse::indent(2), ' ' x 8, 'indent with an argument' );
23 is( B::Terse::indent(), '', 'indent with no argument' );
24
25 # this should fail without a reference
26 eval { B::Terse::terse('scalar') };
27 like( $@, qr/not a reference/, 'terse() fed bad parameters' );
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') };
34 is( $@, '', 'compile()' );
35 ok( defined &$sub, 'valid subref back from compile()' );
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/ }
45         qw ( OP COP LOOP PMOP UNOP BINOP LOGOP LISTOP PVOP );
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};
56                 like( $_, $ops{$op}, "$op " );
57                 s/$ops{$op}//;
58                 delete $ops{$op};
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
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).
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
83         our @ary = split('', $foo);
84
85         # PVOP, LOOP
86         LOOP: for (1 .. 10) {
87                 last LOOP if $_ % 2;
88         }
89
90         # make a PV
91         $foo = "a string";
92
93         # make an OP_SUBSTCONT
94         $foo =~ s/(a)/$1/;
95 }
96
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 if( $] >= 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 }
107
108 package TieOut;
109
110 sub TIEHANDLE {
111         bless( \(my $out), $_[0] );
112 }
113
114 sub PRINT {
115         my $self = shift;
116         $$self .= join('', @_);
117 }
118
119 sub PRINTF {
120         my $self = shift;
121         $$self .= sprintf(@_);
122 }
123
124 sub read {
125         my $self = shift;
126         return substr($$self, 0, length($$self), '');
127 }