Commit | Line | Data |
---|---|---|
ccc418af GS |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
1b026014 NIS |
5 | if ($^O eq 'MacOS') { |
6 | @INC = qw(: ::lib ::macos:lib); | |
7 | } else { | |
8 | @INC = '.'; | |
9 | push @INC, '../lib'; | |
db5fd395 | 10 | } |
ccc418af GS |
11 | } |
12 | ||
13 | $| = 1; | |
14 | use warnings; | |
15 | use strict; | |
16 | use Config; | |
17 | ||
fc674faa | 18 | print "1..19\n"; |
ccc418af GS |
19 | |
20 | my $test = 1; | |
21 | ||
22 | sub ok { print "ok $test\n"; $test++ } | |
23 | ||
24 | use B::Deparse; | |
25 | my $deparse = B::Deparse->new() or print "not "; | |
26 | ok; | |
27 | ||
08c6f5ec RH |
28 | # Tell B::Deparse about our ambient pragmas |
29 | { my ($hint_bits, $warning_bits); | |
30 | BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})} | |
31 | $deparse->ambient_pragmas ( | |
32 | hint_bits => $hint_bits, | |
33 | warning_bits => $warning_bits, | |
34 | '$[' => 0 + $[ | |
35 | ); | |
36 | } | |
37 | ||
ccc418af GS |
38 | print "not " if "{\n 1;\n}" ne $deparse->coderef2text(sub {1}); |
39 | ok; | |
40 | ||
41 | print "not " if "{\n '???';\n 2;\n}" ne | |
42 | $deparse->coderef2text(sub {1;2}); | |
43 | ok; | |
44 | ||
45 | print "not " if "{\n \$test /= 2 if ++\$test;\n}" ne | |
46 | $deparse->coderef2text(sub {++$test and $test/=2;}); | |
47 | ok; | |
f70490b9 NIS |
48 | |
49 | print "not " if "{\n -((1, 2) x 2);\n}" ne | |
50 | $deparse->coderef2text(sub {-((1,2)x2)}); | |
51 | ok; | |
52 | ||
9b86dfa2 SC |
53 | { |
54 | my $a = <<'EOF'; | |
55 | { | |
56 | $test = sub : lvalue { | |
78f9721b | 57 | my $x; |
9b86dfa2 SC |
58 | } |
59 | ; | |
60 | } | |
61 | EOF | |
62 | chomp $a; | |
78f9721b | 63 | print "not " if $deparse->coderef2text(sub{$test = sub : lvalue{my $x}}) ne $a; |
9b86dfa2 SC |
64 | ok; |
65 | ||
66 | $a =~ s/lvalue/method/; | |
78f9721b | 67 | print "not " if $deparse->coderef2text(sub{$test = sub : method{my $x}}) ne $a; |
9b86dfa2 SC |
68 | ok; |
69 | ||
70 | $a =~ s/method/locked method/; | |
78f9721b | 71 | print "not " if $deparse->coderef2text(sub{$test = sub : method locked {my $x}}) |
9b86dfa2 SC |
72 | ne $a; |
73 | ok; | |
74 | } | |
ccc418af | 75 | |
de3f1649 JT |
76 | print "not " if (eval "sub ".$deparse->coderef2text(sub () { 42 }))->() != 42; |
77 | ok; | |
78 | ||
79 | use constant 'c', 'stuff'; | |
80 | print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff'; | |
81 | ok; | |
82 | ||
fc674faa JH |
83 | $a = 0; |
84 | print "not " if "{\n (-1) ** \$a;\n}" | |
85 | ne $deparse->coderef2text(sub{(-1) ** $a }); | |
86 | ok; | |
87 | ||
de3f1649 JT |
88 | # XXX ToDo - constsub that returns a reference |
89 | #use constant cr => ['hello']; | |
90 | #my $string = "sub " . $deparse->coderef2text(\&cr); | |
91 | #my $val = (eval $string)->(); | |
92 | #print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello'; | |
93 | #ok; | |
94 | ||
885a8af1 JH |
95 | my $a; |
96 | my $Is_VMS = $^O eq 'VMS'; | |
db5fd395 CN |
97 | my $Is_MacOS = $^O eq 'MacOS'; |
98 | ||
99 | my $path = join " ", map { qq["-I$_"] } @INC; | |
100 | my $redir = $Is_MacOS ? "" : "2>&1"; | |
101 | ||
102 | $a = `$^X $path "-MO=Deparse" -anle 1 $redir`; | |
5fb4d820 | 103 | $a =~ s/-e syntax OK\n//g; |
bd145f00 PP |
104 | $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037 |
105 | $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc' | |
ccc418af | 106 | $b = <<'EOF'; |
ccc418af GS |
107 | |
108 | LINE: while (defined($_ = <ARGV>)) { | |
109 | chomp $_; | |
fee7e838 | 110 | @F = split(" ", $_, 0); |
58cccf98 | 111 | '???'; |
ccc418af | 112 | } |
ccc418af GS |
113 | |
114 | EOF | |
5fb4d820 | 115 | print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b; |
ccc418af GS |
116 | ok; |
117 | ||
db5fd395 | 118 | $a = `$^X $path "-MO=Debug" -e 1 $redir`; |
ccc418af GS |
119 | print "not " unless $a =~ |
120 | /\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s; | |
121 | ok; | |
122 | ||
db5fd395 | 123 | $a = `$^X $path "-MO=Terse" -e 1 $redir`; |
ccc418af | 124 | print "not " unless $a =~ |
f72d64f0 | 125 | /\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s; |
ccc418af GS |
126 | ok; |
127 | ||
db5fd395 | 128 | $a = `$^X $path "-MO=Terse" -ane "s/foo/bar/" $redir`; |
ccc418af GS |
129 | $a =~ s/\(0x[^)]+\)//g; |
130 | $a =~ s/\[[^\]]+\]//g; | |
131 | $a =~ s/-e syntax OK//; | |
132 | $a =~ s/[^a-z ]+//g; | |
133 | $a =~ s/\s+/ /g; | |
b2ec7025 | 134 | $a =~ s/\b(s|foo|bar|ullsv)\b\s?//g; |
ccc418af GS |
135 | $a =~ s/^\s+//; |
136 | $a =~ s/\s+$//; | |
208edb77 MG |
137 | my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define'; |
138 | if ($is_thread) { | |
cfe9256d JH |
139 | $b=<<EOF; |
140 | leave enter nextstate label leaveloop enterloop null and defined null | |
141 | threadsv readline gv lineseq nextstate aassign null pushmark split pushre | |
142 | threadsv const null pushmark rvav gv nextstate subst const unstack nextstate | |
143 | EOF | |
144 | } else { | |
145 | $b=<<EOF; | |
ccc418af GS |
146 | leave enter nextstate label leaveloop enterloop null and defined null |
147 | null gvsv readline gv lineseq nextstate aassign null pushmark split pushre | |
cfe9256d | 148 | null gvsv const null pushmark rvav gv nextstate subst const unstack nextstate |
ccc418af | 149 | EOF |
cfe9256d | 150 | } |
ccc418af GS |
151 | $b=~s/\n/ /g;$b=~s/\s+/ /g; |
152 | $b =~ s/\s+$//; | |
cfe9256d | 153 | print "# [$a]\n# vs\n# [$b]\nnot " if $a ne $b; |
ccc418af GS |
154 | ok; |
155 | ||
db5fd395 | 156 | chomp($a = `$^X $path "-MB::Stash" "-Mwarnings" -e1`); |
ccc418af | 157 | $a = join ',', sort split /,/, $a; |
7d3b96bb | 158 | $a =~ s/-u(PerlIO|open)(?:::\w+)?,//g if defined $Config{'useperlio'} and $Config{'useperlio'} eq 'define'; |
754a99e1 GS |
159 | $a =~ s/-uWin32,// if $^O eq 'MSWin32'; |
160 | $a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2'; | |
5d129265 | 161 | $a =~ s/-uCwd,// if $^O eq 'cygwin'; |
f3ff050f JH |
162 | if ($Config{static_ext} eq ' ') { |
163 | $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,' | |
1b026014 | 164 | . '-umain,-ustrict,-uutf8,-uwarnings'; |
e5befd65 PP |
165 | if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a) |
166 | $b = join ',', sort split /,/, $b; | |
167 | } | |
f3ff050f JH |
168 | print "# [$a] vs [$b]\nnot " if $a ne $b; |
169 | ok; | |
170 | } else { | |
171 | print "ok $test # skipped: one or more static extensions\n"; $test++; | |
172 | } | |
ccc418af | 173 | |
208edb77 | 174 | if ($is_thread) { |
cfe9256d JH |
175 | print "# use5005threads: test $test skipped\n"; |
176 | } else { | |
db5fd395 | 177 | $a = `$^X $path "-MO=Showlex" -e "my %one" $redir`; |
bd145f00 PP |
178 | if (ord('A') != 193) { # ASCIIish |
179 | print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s; | |
1b026014 | 180 | } |
bd145f00 PP |
181 | else { # EBCDICish C<1: PVNV (0x1a7ede34) "%\226\225\205"> |
182 | print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%\\[0-9].*sv_undef.*HV/s; | |
183 | } | |
885a8af1 | 184 | } |
ccc418af | 185 | ok; |
1e1dbab6 SC |
186 | |
187 | # Bug 20001204.07 | |
188 | { | |
189 | my $foo = $deparse->coderef2text(sub { { 234; }}); | |
190 | # Constants don't get optimised here. | |
191 | print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm; | |
192 | ok; | |
193 | $foo = $deparse->coderef2text(sub { { 234; } continue { 123; } }); | |
1b026014 | 194 | print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm; |
1e1dbab6 SC |
195 | ok; |
196 | } |