This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Document the undefinedness of bitshifting out of range.
[perl5.git] / t / lib / b-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..12\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  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
36 $/ = "\n####\n";
37 while (<DATA>) {
38     chomp;
39     s/#.*$//mg;
40
41     my ($input, $expected);
42     if (/(.*)\n>>>>\n(.*)/s) {
43         ($input, $expected) = ($1, $2);
44     }
45     else {
46         ($input, $expected) = ($_, $_);
47     }
48
49     my $coderef = eval "sub {$input}";
50
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         }
75     }
76 }
77
78 use constant 'c', 'stuff';
79 print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
80 print "ok ", $i++, "\n";
81
82 $a = 0;
83 print "not " if "{\n    (-1) ** \$a;\n}"
84                 ne $deparse->coderef2text(sub{(-1) ** $a });
85 print "ok ", $i++, "\n";
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';
92 #print "ok ", $i++, "\n";
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
114 print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b;
115 print "ok ", $i++, "\n";
116
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
163 {
164     234;
165 }
166 continue {
167     123;
168 }