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;});
41 $test = sub : lvalue {
48 print "not " if $deparse->coderef2text(sub{$test = sub : lvalue{my $x}}) ne $a;
51 $a =~ s/lvalue/method/;
52 print "not " if $deparse->coderef2text(sub{$test = sub : method{my $x}}) ne $a;
55 $a =~ s/method/locked method/;
56 print "not " if $deparse->coderef2text(sub{$test = sub : method locked {my $x}})
61 print "not " if (eval "sub ".$deparse->coderef2text(sub () { 42 }))->() != 42;
64 use constant 'c', 'stuff';
65 print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
68 # XXX ToDo - constsub that returns a reference
69 #use constant cr => ['hello'];
70 #my $string = "sub " . $deparse->coderef2text(\&cr);
71 #my $val = (eval $string)->();
72 #print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
76 my $Is_VMS = $^O eq 'VMS';
77 my $Is_MacOS = $^O eq 'MacOS';
79 my $path = join " ", map { qq["-I$_"] } @INC;
80 my $redir = $Is_MacOS ? "" : "2>&1";
82 $a = `$^X $path "-MO=Deparse" -anle 1 $redir`;
83 $a =~ s/-e syntax OK\n//g;
84 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
85 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
88 LINE: while (defined($_ = <ARGV>)) {
90 @F = split(/\s+/, $_, 0);
95 print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b;
98 $a = `$^X $path "-MO=Debug" -e 1 $redir`;
99 print "not " unless $a =~
100 /\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s;
103 $a = `$^X $path "-MO=Terse" -e 1 $redir`;
104 print "not " unless $a =~
105 /\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s;
108 $a = `$^X $path "-MO=Terse" -ane "s/foo/bar/" $redir`;
109 $a =~ s/\(0x[^)]+\)//g;
110 $a =~ s/\[[^\]]+\]//g;
111 $a =~ s/-e syntax OK//;
114 $a =~ s/\b(s|foo|bar|ullsv)\b\s?//g;
117 my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
120 leave enter nextstate label leaveloop enterloop null and defined null
121 threadsv readline gv lineseq nextstate aassign null pushmark split pushre
122 threadsv const null pushmark rvav gv nextstate subst const unstack nextstate
126 leave enter nextstate label leaveloop enterloop null and defined null
127 null gvsv readline gv lineseq nextstate aassign null pushmark split pushre
128 null gvsv const null pushmark rvav gv nextstate subst const unstack nextstate
131 $b=~s/\n/ /g;$b=~s/\s+/ /g;
133 print "# [$a]\n# vs\n# [$b]\nnot " if $a ne $b;
136 chomp($a = `$^X $path "-MB::Stash" "-Mwarnings" -e1`);
137 $a = join ',', sort split /,/, $a;
138 $a =~ s/-u(perlio|open)(?:::\w+)?,//g if defined $Config{'useperlio'} and $Config{'useperlio'} eq 'define';
139 $a =~ s/-uWin32,// if $^O eq 'MSWin32';
140 $a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2';
141 $a =~ s/-uCwd,// if $^O eq 'cygwin';
142 if ($Config{static_ext} eq ' ') {
143 $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,'
144 . '-umain,-ustrict,-uutf8,-uwarnings';
145 if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a)
146 $b = join ',', sort split /,/, $b;
148 print "# [$a] vs [$b]\nnot " if $a ne $b;
151 print "ok $test # skipped: one or more static extensions\n"; $test++;
155 print "# use5005threads: test $test skipped\n";
157 $a = `$^X $path "-MO=Showlex" -e "my %one" $redir`;
158 if (ord('A') != 193) { # ASCIIish
159 print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s;
161 else { # EBCDICish C<1: PVNV (0x1a7ede34) "%\226\225\205">
162 print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%\\[0-9].*sv_undef.*HV/s;
169 my $foo = $deparse->coderef2text(sub { { 234; }});
170 # Constants don't get optimised here.
171 print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm;
173 $foo = $deparse->coderef2text(sub { { 234; } continue { 123; } });
174 print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm;