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';
73 # XXX ToDo - constsub that returns a reference
74 #use constant cr => ['hello'];
75 #my $string = "sub " . $deparse->coderef2text(\&cr);
76 #my $val = (eval $string)->();
77 #print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
81 my $Is_VMS = $^O eq 'VMS';
82 my $Is_MacOS = $^O eq 'MacOS';
84 my $path = join " ", map { qq["-I$_"] } @INC;
85 my $redir = $Is_MacOS ? "" : "2>&1";
87 $a = `$^X $path "-MO=Deparse" -anle 1 $redir`;
88 $a =~ s/-e syntax OK\n//g;
89 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
90 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
93 LINE: while (defined($_ = <ARGV>)) {
95 @F = split(/\s+/, $_, 0);
100 print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b;
103 $a = `$^X $path "-MO=Debug" -e 1 $redir`;
104 print "not " unless $a =~
105 /\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s;
108 $a = `$^X $path "-MO=Terse" -e 1 $redir`;
109 print "not " unless $a =~
110 /\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s;
113 $a = `$^X $path "-MO=Terse" -ane "s/foo/bar/" $redir`;
114 $a =~ s/\(0x[^)]+\)//g;
115 $a =~ s/\[[^\]]+\]//g;
116 $a =~ s/-e syntax OK//;
119 $a =~ s/\b(s|foo|bar|ullsv)\b\s?//g;
122 my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
125 leave enter nextstate label leaveloop enterloop null and defined null
126 threadsv readline gv lineseq nextstate aassign null pushmark split pushre
127 threadsv const null pushmark rvav gv nextstate subst const unstack nextstate
131 leave enter nextstate label leaveloop enterloop null and defined null
132 null gvsv readline gv lineseq nextstate aassign null pushmark split pushre
133 null gvsv const null pushmark rvav gv nextstate subst const unstack nextstate
136 $b=~s/\n/ /g;$b=~s/\s+/ /g;
138 print "# [$a]\n# vs\n# [$b]\nnot " if $a ne $b;
141 chomp($a = `$^X $path "-MB::Stash" "-Mwarnings" -e1`);
142 $a = join ',', sort split /,/, $a;
143 $a =~ s/-u(perlio|open)(?:::\w+)?,//g if defined $Config{'useperlio'} and $Config{'useperlio'} eq 'define';
144 $a =~ s/-uWin32,// if $^O eq 'MSWin32';
145 $a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2';
146 $a =~ s/-uCwd,// if $^O eq 'cygwin';
147 if ($Config{static_ext} eq ' ') {
148 $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,'
149 . '-umain,-ustrict,-uutf8,-uwarnings';
150 if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a)
151 $b = join ',', sort split /,/, $b;
153 print "# [$a] vs [$b]\nnot " if $a ne $b;
156 print "ok $test # skipped: one or more static extensions\n"; $test++;
160 print "# use5005threads: test $test skipped\n";
162 $a = `$^X $path "-MO=Showlex" -e "my %one" $redir`;
163 if (ord('A') != 193) { # ASCIIish
164 print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s;
166 else { # EBCDICish C<1: PVNV (0x1a7ede34) "%\226\225\205">
167 print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%\\[0-9].*sv_undef.*HV/s;
174 my $foo = $deparse->coderef2text(sub { { 234; }});
175 # Constants don't get optimised here.
176 print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm;
178 $foo = $deparse->coderef2text(sub { { 234; } continue { 123; } });
179 print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm;