This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
7c1d39686edc2027045b6cf6a437abb8b7ebac24
[perl5.git] / ext / B / t / terse.t
1 #!./perl
2
3 BEGIN {
4         unshift @INC, 't';
5         require Config;
6         if (($Config::Config{'extensions'} !~ /\bB\b/) ){
7                 print "1..0 # Skip -- Perl configured without B module\n";
8                 exit 0;
9         }
10 }
11
12 use Test::More tests => 16;
13
14 use_ok( 'B::Terse' );
15
16 # indent should return a string indented four spaces times the argument
17 is( B::Terse::indent(2), ' ' x 8, 'indent with an argument' );
18 is( B::Terse::indent(), '', 'indent with no argument' );
19
20 # this should fail without a reference
21 eval { B::Terse::terse('scalar') };
22 like( $@, qr/not a reference/, 'terse() fed bad parameters' );
23
24 # now point it at a sub and see what happens
25 sub foo {}
26
27 my $sub;
28 eval{ $sub = B::Terse::compile('', 'foo') };
29 is( $@, '', 'compile()' );
30 ok( defined &$sub, 'valid subref back from compile()' );
31
32 # and point it at a real sub and hope the returned ops look alright
33 my $out = tie *STDOUT, 'TieOut';
34 $sub = B::Terse::compile('', 'bar');
35 $sub->();
36
37 # now build some regexes that should match the dumped ops
38 my ($hex, $op) = ('\(0x[a-f0-9]+\)', '\s+\w+');
39 my %ops = map { $_ => qr/$_ $hex$op/ }
40         qw ( OP COP LOOP PMOP UNOP BINOP LOGOP LISTOP PVOP );
41
42 # split up the output lines into individual ops (terse is, well, terse!)
43 # use an array here so $_ is modifiable
44 my @lines = split(/\n+/, $out->read);
45 foreach (@lines) {
46         next unless /\S/;
47         s/^\s+//;
48         if (/^([A-Z]+)\s+/) {
49                 my $op = $1;
50                 next unless exists $ops{$op};
51                 like( $_, $ops{$op}, "$op " );
52                 s/$ops{$op}//;
53                 delete $ops{$op};
54                 redo if $_;
55         }
56 }
57
58 warn "# didn't find " . join(' ', keys %ops) if keys %ops;
59
60 # XXX:
61 # this tries to get at all tersified optypes in B::Terse
62 # if you can think of a way to produce AV, NULL, PADOP, or SPECIAL,
63 # add it to the regex above too. (PADOPs are currently only produced
64 # under ithreads, though).
65 #
66 use vars qw( $a $b );
67 sub bar {
68         # OP SVOP COP IV here or in sub definition
69         my @bar = (1, 2, 3);
70
71         # got a GV here
72         my $foo = $a + $b;
73
74         # NV here
75         $a = 1.234;
76
77         # this is awful, but it gives a PMOP
78         our @ary = split('', $foo);
79
80         # PVOP, LOOP
81         LOOP: for (1 .. 10) {
82                 last LOOP if $_ % 2;
83         }
84
85         # make a PV
86         $foo = "a string";
87
88         # make an OP_SUBSTCONT
89         $foo =~ s/(a)/$1/;
90 }
91
92 # Schwern's example of finding an RV
93 my $path = join " ", map { qq["-I$_"] } @INC;
94 $path = '-I::lib -MMac::err=unix' if $^O eq 'MacOS';
95 my $redir = $^O eq 'MacOS' ? '' : "2>&1";
96 my $items = qx{$^X $path "-MO=Terse" -le "print \\42" $redir};
97 if( $] >= 5.011 ) {
98     like( $items, qr/IV $hex \\42/, 'RV (but now stored in an IV)' );
99 } else {
100     like( $items, qr/RV $hex \\42/, 'RV' );
101 }
102
103 package TieOut;
104
105 sub TIEHANDLE {
106         bless( \(my $out), $_[0] );
107 }
108
109 sub PRINT {
110         my $self = shift;
111         $$self .= join('', @_);
112 }
113
114 sub PRINTF {
115         my $self = shift;
116         $$self .= sprintf(@_);
117 }
118
119 sub read {
120         my $self = shift;
121         return substr($$self, 0, length($$self), '');
122 }