6 @INC = qw(: ::lib ::macos:lib);
22 sub ok { print "ok $test\n"; $test++ }
25 my $deparse = B::Deparse->new() or print "not ";
28 print "not " if "{\n 1;\n}" ne $deparse->coderef2text(sub {1});
31 print "not " if "{\n '???';\n 2;\n}" ne
32 $deparse->coderef2text(sub {1;2});
35 print "not " if "{\n \$test /= 2 if ++\$test;\n}" ne
36 $deparse->coderef2text(sub {++$test and $test/=2;});
39 print "not " if "{\n -((1, 2) x 2);\n}" ne
40 $deparse->coderef2text(sub {-((1,2)x2)});
46 $test = sub : lvalue {
53 print "not " if $deparse->coderef2text(sub{$test = sub : lvalue{my $x}}) ne $a;
56 $a =~ s/lvalue/method/;
57 print "not " if $deparse->coderef2text(sub{$test = sub : method{my $x}}) ne $a;
60 $a =~ s/method/locked method/;
61 print "not " if $deparse->coderef2text(sub{$test = sub : method locked {my $x}})
66 print "not " if (eval "sub ".$deparse->coderef2text(sub () { 42 }))->() != 42;
69 use constant 'c', 'stuff';
70 print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
74 print "not " if "{\n (-1) ** \$a;\n}"
75 ne $deparse->coderef2text(sub{(-1) ** $a });
78 # XXX ToDo - constsub that returns a reference
79 #use constant cr => ['hello'];
80 #my $string = "sub " . $deparse->coderef2text(\&cr);
81 #my $val = (eval $string)->();
82 #print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
86 my $Is_VMS = $^O eq 'VMS';
87 my $Is_MacOS = $^O eq 'MacOS';
89 my $path = join " ", map { qq["-I$_"] } @INC;
90 my $redir = $Is_MacOS ? "" : "2>&1";
92 $a = `$^X $path "-MO=Deparse" -anle 1 $redir`;
93 $a =~ s/-e syntax OK\n//g;
94 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
95 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
98 LINE: while (defined($_ = <ARGV>)) {
100 @F = split(/\s+/, $_, 0);
105 print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b;
108 $a = `$^X $path "-MO=Debug" -e 1 $redir`;
109 print "not " unless $a =~
110 /\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s;
113 $a = `$^X $path "-MO=Terse" -e 1 $redir`;
114 print "not " unless $a =~
115 /\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s;
118 $a = `$^X $path "-MO=Terse" -ane "s/foo/bar/" $redir`;
119 $a =~ s/\(0x[^)]+\)//g;
120 $a =~ s/\[[^\]]+\]//g;
121 $a =~ s/-e syntax OK//;
124 $a =~ s/\b(s|foo|bar|ullsv)\b\s?//g;
127 my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
130 leave enter nextstate label leaveloop enterloop null and defined null
131 threadsv readline gv lineseq nextstate aassign null pushmark split pushre
132 threadsv const null pushmark rvav gv nextstate subst const unstack nextstate
136 leave enter nextstate label leaveloop enterloop null and defined null
137 null gvsv readline gv lineseq nextstate aassign null pushmark split pushre
138 null gvsv const null pushmark rvav gv nextstate subst const unstack nextstate
141 $b=~s/\n/ /g;$b=~s/\s+/ /g;
143 print "# [$a]\n# vs\n# [$b]\nnot " if $a ne $b;
146 chomp($a = `$^X $path "-MB::Stash" "-Mwarnings" -e1`);
147 $a = join ',', sort split /,/, $a;
148 $a =~ s/-u(PerlIO|open)(?:::\w+)?,//g if defined $Config{'useperlio'} and $Config{'useperlio'} eq 'define';
149 $a =~ s/-uWin32,// if $^O eq 'MSWin32';
150 $a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2';
151 $a =~ s/-uCwd,// if $^O eq 'cygwin';
152 if ($Config{static_ext} eq ' ') {
153 $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,'
154 . '-umain,-ustrict,-uutf8,-uwarnings';
155 if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a)
156 $b = join ',', sort split /,/, $b;
158 print "# [$a] vs [$b]\nnot " if $a ne $b;
161 print "ok $test # skipped: one or more static extensions\n"; $test++;
165 print "# use5005threads: test $test skipped\n";
167 $a = `$^X $path "-MO=Showlex" -e "my %one" $redir`;
168 if (ord('A') != 193) { # ASCIIish
169 print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s;
171 else { # EBCDICish C<1: PVNV (0x1a7ede34) "%\226\225\205">
172 print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%\\[0-9].*sv_undef.*HV/s;
179 my $foo = $deparse->coderef2text(sub { { 234; }});
180 # Constants don't get optimised here.
181 print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm;
183 $foo = $deparse->coderef2text(sub { { 234; } continue { 123; } });
184 print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm;