This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Change the prefixes only if $prefix is unset,
[perl5.git] / ext / B / Deparse.t
CommitLineData
87a42246
MS
1#!./perl
2
3BEGIN {
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;
14use warnings;
15use strict;
16use Config;
17
ce4e655d 18print "1..14\n";
87a42246
MS
19
20use B::Deparse;
21my $deparse = B::Deparse->new() or print "not ";
ad46c0be
RH
22my $i=1;
23print "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";
37while (<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
78use constant 'c', 'stuff';
79print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
ad46c0be 80print "ok ", $i++, "\n";
87a42246
MS
81
82$a = 0;
83print "not " if "{\n (-1) ** \$a;\n}"
84 ne $deparse->coderef2text(sub{(-1) ** $a });
ad46c0be 85print "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
94my $a;
95my $Is_VMS = $^O eq 'VMS';
96my $Is_MacOS = $^O eq 'MacOS';
97
98my $path = join " ", map { qq["-I$_"] } @INC;
99my $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
107LINE: while (defined($_ = <ARGV>)) {
108 chomp $_;
109 @F = split(" ", $_, 0);
110 '???';
111}
112
113EOF
f99a63a2 114print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b;
ad46c0be 115print "ok ", $i++, "\n";
87a42246 116
ad46c0be
RH
117__DATA__
118# 1
1191;
120####
121# 2
122{
123 no warnings;
124 '???';
125 2;
126}
127####
128# 3
129my $test;
130++$test and $test /= 2;
131>>>>
132my $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
166continue {
167 123;
87a42246 168}
ce4e655d
RH
169####
170# 9
171my $x;
172print $main::x;
173####
174# 10
175my @x;
176print $main::x[1];