This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
B::walksymtable improperly documented?
[perl5.git] / t / lib / b-deparse.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     if ($^O eq 'MacOS') {
6         @INC = qw(: ::lib ::macos:lib);
7     } else {
8         @INC = '.';
9         push @INC, '../lib';
10     }
11 }
12
13 $|  = 1;
14 use warnings;
15 use strict;
16 use Config;
17
18 print "1..14\n";
19
20 my $test = 1;
21
22 sub ok { print "ok $test\n"; $test++ }
23
24
25 use B::Deparse;
26 my $deparse = B::Deparse->new() or print "not ";
27 ok;
28
29 # Tell B::Deparse about our ambient pragmas
30 { my ($hint_bits, $warning_bits);
31  BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
32  $deparse->ambient_pragmas (
33      hint_bits    => $hint_bits,
34      warning_bits => $warning_bits,
35      '$['         => 0 + $[
36  );
37 }
38
39 print "not " if "{\n    1;\n}" ne $deparse->coderef2text(sub {1});
40 ok;
41
42 print "not " if "{\n    '???';\n    2;\n}" ne
43                     $deparse->coderef2text(sub {1;2});
44 ok;
45
46 print "not " if "{\n    \$test /= 2 if ++\$test;\n}" ne
47                     $deparse->coderef2text(sub {++$test and $test/=2;});
48 ok;
49
50 print "not " if "{\n    -((1, 2) x 2);\n}" ne
51                     $deparse->coderef2text(sub {-((1,2)x2)});
52 ok;
53
54 {
55 my $a = <<'EOF';
56 {
57     $test = sub : lvalue {
58         my $x;
59     }
60     ;
61 }
62 EOF
63 chomp $a;
64 print "not " if $deparse->coderef2text(sub{$test = sub : lvalue{my $x}}) ne $a;
65 ok;
66
67 $a =~ s/lvalue/method/;
68 print "not " if $deparse->coderef2text(sub{$test = sub : method{my $x}}) ne $a;
69 ok;
70
71 $a =~ s/method/locked method/;
72 print "not " if $deparse->coderef2text(sub{$test = sub : method locked {my $x}})
73                                      ne $a;
74 ok;
75 }
76
77 print "not " if (eval "sub ".$deparse->coderef2text(sub () { 42 }))->() != 42;
78 ok;
79
80 use constant 'c', 'stuff';
81 print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
82 ok;
83
84 $a = 0;
85 print "not " if "{\n    (-1) ** \$a;\n}"
86                 ne $deparse->coderef2text(sub{(-1) ** $a });
87 ok;
88
89 # XXX ToDo - constsub that returns a reference
90 #use constant cr => ['hello'];
91 #my $string = "sub " . $deparse->coderef2text(\&cr);
92 #my $val = (eval $string)->();
93 #print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
94 #ok;
95
96 my $a;
97 my $Is_VMS = $^O eq 'VMS';
98 my $Is_MacOS = $^O eq 'MacOS';
99
100 my $path = join " ", map { qq["-I$_"] } @INC;
101 my $redir = $Is_MacOS ? "" : "2>&1";
102
103 $a = `$^X $path "-MO=Deparse" -anle 1 $redir`;
104 $a =~ s/-e syntax OK\n//g;
105 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
106 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
107 $b = <<'EOF';
108
109 LINE: while (defined($_ = <ARGV>)) {
110     chomp $_;
111     @F = split(" ", $_, 0);
112     '???';
113 }
114
115 EOF
116 print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b;
117 ok;
118
119
120 # Bug 20001204.07
121 {
122 my $foo = $deparse->coderef2text(sub { { 234; }});
123 # Constants don't get optimised here.
124 print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm;
125 ok;
126 $foo = $deparse->coderef2text(sub { { 234; } continue { 123; } });
127 print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm;
128 ok;
129 }