Commit | Line | Data |
87a42246 |
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..14\n"; |
19 | |
20 | my $test = 1; |
21 | |
22 | sub ok { print "ok $test\n"; $test++ } |
23 | |
24 | |
25 | use B::Deparse; |
26 | my $deparse = B::Deparse->new() or print "not "; |
27 | ok; |
28 | |
29 | # Tell B::Deparse about our ambient pragmas |
30 | { my ($hint_bits, $warning_bits); |
31 | BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})} |
32 | $deparse->ambient_pragmas ( |
33 | hint_bits => $hint_bits, |
34 | warning_bits => $warning_bits, |
35 | '$[' => 0 + $[ |
36 | ); |
37 | } |
38 | |
39 | print "not " if "{\n 1;\n}" ne $deparse->coderef2text(sub {1}); |
40 | ok; |
41 | |
42 | print "not " if "{\n '???';\n 2;\n}" ne |
43 | $deparse->coderef2text(sub {1;2}); |
44 | ok; |
45 | |
46 | print "not " if "{\n \$test /= 2 if ++\$test;\n}" ne |
47 | $deparse->coderef2text(sub {++$test and $test/=2;}); |
48 | ok; |
49 | |
50 | print "not " if "{\n -((1, 2) x 2);\n}" ne |
51 | $deparse->coderef2text(sub {-((1,2)x2)}); |
52 | ok; |
53 | |
54 | { |
55 | my $a = <<'EOF'; |
56 | { |
57 | $test = sub : lvalue { |
58 | my $x; |
59 | } |
60 | ; |
61 | } |
62 | EOF |
63 | chomp $a; |
64 | print "not " if $deparse->coderef2text(sub{$test = sub : lvalue{my $x}}) ne $a; |
65 | ok; |
66 | |
67 | $a =~ s/lvalue/method/; |
68 | print "not " if $deparse->coderef2text(sub{$test = sub : method{my $x}}) ne $a; |
69 | ok; |
70 | |
71 | $a =~ s/method/locked method/; |
72 | print "not " if $deparse->coderef2text(sub{$test = sub : method locked {my $x}}) |
73 | ne $a; |
74 | ok; |
75 | } |
76 | |
77 | print "not " if (eval "sub ".$deparse->coderef2text(sub () { 42 }))->() != 42; |
78 | ok; |
79 | |
80 | use constant 'c', 'stuff'; |
81 | print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff'; |
82 | ok; |
83 | |
84 | $a = 0; |
85 | print "not " if "{\n (-1) ** \$a;\n}" |
86 | ne $deparse->coderef2text(sub{(-1) ** $a }); |
87 | ok; |
88 | |
89 | # XXX ToDo - constsub that returns a reference |
90 | #use constant cr => ['hello']; |
91 | #my $string = "sub " . $deparse->coderef2text(\&cr); |
92 | #my $val = (eval $string)->(); |
93 | #print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello'; |
94 | #ok; |
95 | |
96 | my $a; |
97 | my $Is_VMS = $^O eq 'VMS'; |
98 | my $Is_MacOS = $^O eq 'MacOS'; |
99 | |
100 | my $path = join " ", map { qq["-I$_"] } @INC; |
101 | my $redir = $Is_MacOS ? "" : "2>&1"; |
102 | |
103 | $a = `$^X $path "-MO=Deparse" -anle 1 $redir`; |
104 | $a =~ s/-e syntax OK\n//g; |
105 | $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037 |
106 | $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc' |
107 | $b = <<'EOF'; |
108 | |
109 | LINE: while (defined($_ = <ARGV>)) { |
110 | chomp $_; |
111 | @F = split(" ", $_, 0); |
112 | '???'; |
113 | } |
114 | |
115 | EOF |
116 | print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b; |
117 | ok; |
118 | |
119 | |
120 | # Bug 20001204.07 |
121 | { |
122 | my $foo = $deparse->coderef2text(sub { { 234; }}); |
123 | # Constants don't get optimised here. |
124 | print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm; |
125 | ok; |
126 | $foo = $deparse->coderef2text(sub { { 234; } continue { 123; } }); |
127 | print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm; |
128 | ok; |
129 | } |