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