Commit | Line | Data |
---|---|---|
87a42246 MS |
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 | ||
ad46c0be | 18 | print "1..12\n"; |
87a42246 MS |
19 | |
20 | use B::Deparse; | |
21 | my $deparse = B::Deparse->new() or print "not "; | |
ad46c0be RH |
22 | my $i=1; |
23 | print "ok ", $i++, "\n"; | |
24 | ||
87a42246 MS |
25 | |
26 | # Tell B::Deparse about our ambient pragmas | |
27 | { my ($hint_bits, $warning_bits); | |
28 | BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})} | |
29 | $deparse->ambient_pragmas ( | |
30 | hint_bits => $hint_bits, | |
31 | warning_bits => $warning_bits, | |
32 | '$[' => 0 + $[ | |
33 | ); | |
34 | } | |
35 | ||
ad46c0be RH |
36 | $/ = "\n####\n"; |
37 | while (<DATA>) { | |
38 | chomp; | |
39 | s/#.*$//mg; | |
87a42246 | 40 | |
ad46c0be RH |
41 | my ($input, $expected); |
42 | if (/(.*)\n>>>>\n(.*)/s) { | |
43 | ($input, $expected) = ($1, $2); | |
44 | } | |
45 | else { | |
46 | ($input, $expected) = ($_, $_); | |
47 | } | |
87a42246 | 48 | |
ad46c0be | 49 | my $coderef = eval "sub {$input}"; |
87a42246 | 50 | |
ad46c0be RH |
51 | if ($@) { |
52 | print "not ok ", $i++, "\n"; | |
53 | print "# $@"; | |
54 | } | |
55 | else { | |
56 | my $deparsed = $deparse->coderef2text( $coderef ); | |
57 | my $regex = quotemeta($expected); | |
58 | do { | |
59 | no warnings 'misc'; | |
60 | $regex =~ s/\s+/\s+/g; | |
61 | }; | |
62 | ||
63 | my $ok = ($deparsed =~ /^\{\s*$regex\s*\}$/); | |
64 | print ($ok ? "ok " : "not ok "); | |
65 | print $i++, "\n"; | |
66 | if (!$ok) { | |
67 | print "# EXPECTED:\n"; | |
68 | $regex =~ s/^/# /mg; | |
69 | print "$regex\n"; | |
70 | ||
71 | print "\n# GOT: \n"; | |
72 | $deparsed =~ s/^/# /mg; | |
73 | print "$deparsed\n"; | |
74 | } | |
87a42246 | 75 | } |
87a42246 MS |
76 | } |
77 | ||
87a42246 MS |
78 | use constant 'c', 'stuff'; |
79 | print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff'; | |
ad46c0be | 80 | print "ok ", $i++, "\n"; |
87a42246 MS |
81 | |
82 | $a = 0; | |
83 | print "not " if "{\n (-1) ** \$a;\n}" | |
84 | ne $deparse->coderef2text(sub{(-1) ** $a }); | |
ad46c0be | 85 | print "ok ", $i++, "\n"; |
87a42246 MS |
86 | |
87 | # XXX ToDo - constsub that returns a reference | |
88 | #use constant cr => ['hello']; | |
89 | #my $string = "sub " . $deparse->coderef2text(\&cr); | |
90 | #my $val = (eval $string)->(); | |
91 | #print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello'; | |
ad46c0be | 92 | #print "ok ", $i++, "\n"; |
87a42246 MS |
93 | |
94 | my $a; | |
95 | my $Is_VMS = $^O eq 'VMS'; | |
96 | my $Is_MacOS = $^O eq 'MacOS'; | |
97 | ||
98 | my $path = join " ", map { qq["-I$_"] } @INC; | |
99 | my $redir = $Is_MacOS ? "" : "2>&1"; | |
100 | ||
101 | $a = `$^X $path "-MO=Deparse" -anle 1 $redir`; | |
102 | $a =~ s/-e syntax OK\n//g; | |
103 | $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037 | |
104 | $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc' | |
105 | $b = <<'EOF'; | |
106 | ||
107 | LINE: while (defined($_ = <ARGV>)) { | |
108 | chomp $_; | |
109 | @F = split(" ", $_, 0); | |
110 | '???'; | |
111 | } | |
112 | ||
113 | EOF | |
f99a63a2 | 114 | print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b; |
ad46c0be | 115 | print "ok ", $i++, "\n"; |
87a42246 | 116 | |
ad46c0be RH |
117 | __DATA__ |
118 | # 1 | |
119 | 1; | |
120 | #### | |
121 | # 2 | |
122 | { | |
123 | no warnings; | |
124 | '???'; | |
125 | 2; | |
126 | } | |
127 | #### | |
128 | # 3 | |
129 | my $test; | |
130 | ++$test and $test /= 2; | |
131 | >>>> | |
132 | my $test; | |
133 | $test /= 2 if ++$test; | |
134 | #### | |
135 | # 4 | |
136 | -((1, 2) x 2); | |
137 | #### | |
138 | # 5 | |
139 | { | |
140 | my $test = sub : lvalue { | |
141 | my $x; | |
142 | } | |
143 | ; | |
144 | } | |
145 | #### | |
146 | # 6 | |
147 | { | |
148 | my $test = sub : method { | |
149 | my $x; | |
150 | } | |
151 | ; | |
152 | } | |
153 | #### | |
154 | # 7 | |
155 | { | |
156 | my $test = sub : locked method { | |
157 | my $x; | |
158 | } | |
159 | ; | |
160 | } | |
161 | #### | |
162 | # 8 | |
87a42246 | 163 | { |
ad46c0be | 164 | 234; |
f99a63a2 | 165 | } |
ad46c0be RH |
166 | continue { |
167 | 123; | |
87a42246 | 168 | } |