This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[PATCH] assertions
[perl5.git] / ext / B / t / 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..18\n";
19
20 use B::Deparse;
21 my $deparse = B::Deparse->new() or print "not ";
22 my $i=1;
23 print "ok " . $i++ . "\n";
24
25
26 # Tell B::Deparse about our ambient pragmas
27 { my ($hint_bits, $warning_bits);
28  # Note: there used to be ${^WARNING_BITS} here, instead of
29  # warnings::bits('all'), but this doesn't work, as ${^WARNING_BITS} is
30  # supposed to be the set of warnings this code has been compiled with, and
31  # later in this test we include modules that themselves use warnings::register
32  # (thus modyfing the warnings mask).
33  BEGIN { ($hint_bits, $warning_bits) = ($^H, warnings::bits('all')); }
34  $deparse->ambient_pragmas (
35      hint_bits    => $hint_bits,
36      warning_bits => $warning_bits,
37      '$['         => 0 + $[
38  );
39 }
40
41 $/ = "\n####\n";
42 while (<DATA>) {
43     chomp;
44     s/#.*$//mg;
45
46     my ($input, $expected);
47     if (/(.*)\n>>>>\n(.*)/s) {
48         ($input, $expected) = ($1, $2);
49     }
50     else {
51         ($input, $expected) = ($_, $_);
52     }
53
54     my $coderef = eval "sub {$input}";
55
56     if ($@) {
57         print "not ok " . $i++ . "\n";
58         print "# $@";
59     }
60     else {
61         my $deparsed = $deparse->coderef2text( $coderef );
62         my $regex = quotemeta($expected);
63         do {
64             no warnings 'misc';
65             $regex =~ s/\s+/\s+/g;
66         };
67
68         my $ok = ($deparsed =~ /^\{\s*$regex\s*\}$/);
69         print (($ok ? "ok " : "not ok ") . $i++ . "\n");
70         if (!$ok) {
71             print "# EXPECTED:\n";
72             $regex =~ s/^/# /mg;
73             print "$regex\n";
74
75             print "\n# GOT: \n";
76             $deparsed =~ s/^/# /mg;
77             print "$deparsed\n";
78         }
79     }
80 }
81
82 use constant 'c', 'stuff';
83 print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
84 print "ok " . $i++ . "\n";
85
86 $a = 0;
87 print "not " if "{\n    (-1) ** \$a;\n}"
88                 ne $deparse->coderef2text(sub{(-1) ** $a });
89 print "ok " . $i++ . "\n";
90
91 # XXX ToDo - constsub that returns a reference
92 #use constant cr => ['hello'];
93 #my $string = "sub " . $deparse->coderef2text(\&cr);
94 #my $val = (eval $string)->();
95 #print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
96 #print "ok " . $i++ . "\n";
97
98 my $a;
99 my $Is_VMS = $^O eq 'VMS';
100 my $Is_MacOS = $^O eq 'MacOS';
101
102 my $path = join " ", map { qq["-I$_"] } @INC;
103 $path .= " -MMac::err=unix" if $Is_MacOS;
104 my $redir = $Is_MacOS ? "" : "2>&1";
105
106 $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 $redir`;
107 $a =~ s/-e syntax OK\n//g;
108 $a =~ s/.*possible typo.*\n//;     # Remove warning line
109 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
110 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
111 $b = <<'EOF';
112 BEGIN { $^I = ".bak"; }
113 BEGIN { $^W = 1; }
114 BEGIN { $/ = "\n"; $\ = "\n"; }
115 LINE: while (defined($_ = <ARGV>)) {
116     chomp $_;
117     our(@F) = split(" ", $_, 0);
118     '???';
119 }
120 EOF
121 $b =~ s/(LINE:)/sub BEGIN {
122     'MacPerl'->bootstrap;
123     'OSA'->bootstrap;
124     'XL'->bootstrap;
125 }
126 $1/ if $Is_MacOS;
127 print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b;
128 print "ok " . $i++ . "\n";
129
130 __DATA__
131 # 2
132 1;
133 ####
134 # 3
135 {
136     no warnings;
137     '???';
138     2;
139 }
140 ####
141 # 4
142 my $test;
143 ++$test and $test /= 2;
144 >>>>
145 my $test;
146 $test /= 2 if ++$test;
147 ####
148 # 5
149 -((1, 2) x 2);
150 ####
151 # 6
152 {
153     my $test = sub : lvalue {
154         my $x;
155     }
156     ;
157 }
158 ####
159 # 7
160 {
161     my $test = sub : method {
162         my $x;
163     }
164     ;
165 }
166 ####
167 # 8
168 {
169     my $test = sub : locked method {
170         my $x;
171     }
172     ;
173 }
174 ####
175 # 9
176 {
177     234;
178 }
179 continue {
180     123;
181 }
182 ####
183 # 10
184 my $x;
185 print $main::x;
186 ####
187 # 11
188 my @x;
189 print $main::x[1];
190 ####
191 # 12
192 my %x;
193 $x{warn()};
194 ####
195 # 13
196 my $foo;
197 $_ .= <ARGV> . <$foo>;
198 ####
199 # 14
200 my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ";
201 ####
202 # 15
203 s/x/'y';/e;