ext/attrs/attrs.xs attrs extension external subroutines
ext/attrs/Makefile.PL attrs extension makefile writer
ext/B/B.pm Compiler backend support functions and methods
-ext/B/B.t See if B works
ext/B/B.xs Compiler backend external subroutines
ext/B/B/Asmdata.pm Compiler backend data for assembler
ext/B/B/assemble Assemble compiler bytecode
ext/B/B/Stackobj.pm Compiler stack objects support functions
ext/B/B/Stash.pm Compiler module to identify stashes
ext/B/B/Terse.pm Compiler Terse backend
-ext/B/B/Terse.t See if B::Terse works
ext/B/B/Xref.pm Compiler Xref backend
-ext/B/Debug.t See if B::Debug works
ext/B/defsubs_h.PL Generator for constant subroutines
-ext/B/Deparse.t See if B::Deparse works
ext/B/Makefile.PL Compiler backend makefile writer
ext/B/NOTES Compiler backend notes
ext/B/O.pm Compiler front-end module (-MO=...)
ext/B/ramblings/reg.alloc Compiler ramblings: register allocation
ext/B/ramblings/runtime.porting Compiler ramblings: porting PP enging
ext/B/README Compiler backend README
-ext/B/Showlex.t See if B::ShowLex works
-ext/B/Stash.t See if B::Stash works
+ext/B/t/b.t See if B works
+ext/B/t/debug.t See if B::Debug works
+ext/B/t/deparse.t See if B::Deparse works
+ext/B/t/showlex.t See if B::ShowLex works
+ext/B/t/stash.t See if B::Stash works
+ext/B/t/terse.t See if B::Terse works
ext/B/TESTS Compiler backend test data
ext/B/Todo Compiler backend Todo list
ext/B/typemap Compiler backend interface types
ext/threads/Makefile.PL ithreads
ext/threads/README ithreads
ext/threads/t/basic.t ithreads
+ext/threads/t/stress_cv.t Test with multiple threads, coderef cv argument.
+ext/threads/t/stress_string.t Test with multiple threads, string cv argument.
ext/threads/threads.h ithreads
ext/threads/threads.pm ithreads
ext/threads/threads.xs ithreads
-ext/threads/t/stress_string.t Test with multiple threads, string cv argument.
-ext/threads/t/stress_cv.t Test with multiple threads, coderef cv argument.
ext/Time/HiRes/Changes Time::HiRes extension
ext/Time/HiRes/hints/dynixptx.pl Hint for Time::HiRes for named architecture
ext/Time/HiRes/hints/sco.pl Hints for Time::HiRes for named architecture
+++ /dev/null
-#!./perl
-
-BEGIN {
- chdir 't' if -d 't';
- if ($^O eq 'MacOS') {
- @INC = qw(: ::lib ::macos:lib);
- } else {
- @INC = '.';
- push @INC, '../lib';
- }
-}
-
-$| = 1;
-use warnings;
-use strict;
-use Config;
-
-print "1..2\n";
-
-my $test = 1;
-
-sub ok { print "ok $test\n"; $test++ }
-
-use B;
-
-
-package Testing::Symtable;
-use vars qw($This @That %wibble $moo %moo);
-my $not_a_sym = 'moo';
-
-sub moo { 42 }
-sub car { 23 }
-
-
-package Testing::Symtable::Foo;
-sub yarrow { "Hock" }
-
-package Testing::Symtable::Bar;
-sub hock { "yarrow" }
-
-package main;
-use vars qw(%Subs);
-local %Subs = ();
-B::walksymtable(\%Testing::Symtable::, 'find_syms', sub { $_[0] =~ /Foo/ },
- 'Testing::Symtable::');
-
-sub B::GV::find_syms {
- my($symbol) = @_;
-
- $main::Subs{$symbol->STASH->NAME . '::' . $symbol->NAME}++;
-}
-
-my @syms = map { 'Testing::Symtable::'.$_ } qw(This That wibble moo car
- BEGIN);
-push @syms, "Testing::Symtable::Foo::yarrow";
-
-# Make sure we hit all the expected symbols.
-print "not " unless join('', sort @syms) eq join('', sort keys %Subs);
-ok;
-
-# Make sure we only hit them each once.
-print "not " unless !grep $_ != 1, values %Subs;
-ok;
+++ /dev/null
-#!./perl
-
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
-}
-
-use Test::More tests => 15;
-
-use_ok( 'B::Terse' );
-
-# indent should return a string indented four spaces times the argument
-is( B::Terse::indent(2), ' ' x 8, 'indent works with an argument' );
-is( B::Terse::indent(), '', 'indent works with no argument' );
-
-# this should fail without a reference
-eval { B::Terse::terse('scalar') };
-like( $@, qr/not a reference/, 'terse() caught bad parameters okay' );
-
-# now point it at a sub and see what happens
-sub foo {}
-
-my $sub;
-eval{ $sub = B::Terse::compile('', 'foo') };
-is( $@, '', 'compile() worked without error' );
-ok( defined &$sub, 'got a valid subref back from compile()' );
-
-# and point it at a real sub and hope the returned ops look alright
-my $out = tie *STDOUT, 'TieOut';
-$sub = B::Terse::compile('', 'bar');
-$sub->();
-
-# now build some regexes that should match the dumped ops
-my ($hex, $op) = ('\(0x[a-f0-9]+\)', '\s+\w+');
-my %ops = map { $_ => qr/$_ $hex$op/ }
- qw ( OP COP LOOP PMOP UNOP BINOP LOGOP LISTOP );
-
-# split up the output lines into individual ops (terse is, well, terse!)
-# use an array here so $_ is modifiable
-my @lines = split(/\n+/, $out->read);
-foreach (@lines) {
- next unless /\S/;
- s/^\s+//;
- if (/^([A-Z]+)\s+/) {
- my $op = $1;
- next unless exists $ops{$op};
- like( $_, $ops{$op}, "$op appears okay" );
- delete $ops{$op};
- s/$ops{$op}//;
- redo if $_;
- }
-}
-
-warn "# didn't find " . join(' ', keys %ops) if keys %ops;
-
-# XXX:
-# this tries to get at all tersified optypes in B::Terse
-# if you add AV, NULL, PADOP, PVOP, or SPECIAL, add it to the regex above too
-#
-use vars qw( $a $b );
-sub bar {
- # OP SVOP COP IV here or in sub definition
- my @bar = (1, 2, 3);
-
- # got a GV here
- my $foo = $a + $b;
-
- # NV here
- $a = 1.234;
-
- # this is awful, but it gives a PMOP
- my $boo = split('', $foo);
-
- # PMOP
- LOOP: for (1 .. 10) {
- last LOOP if $_ % 2;
- }
-
- # make a PV
- $foo = "a string";
-}
-
-# Schwern's example of finding an RV
-my $path = join " ", map { qq["-I$_"] } @INC;
-my $redir = $^O eq 'MacOS' ? '' : "2>&1";
-my $items = qx{$^X $path "-MO=Terse" -le "print \\42" $redir};
-like( $items, qr/RV $hex \\42/, 'found an RV, appears okay!' );
-
-package TieOut;
-
-sub TIEHANDLE {
- bless( \(my $out), $_[0] );
-}
-
-sub PRINT {
- my $self = shift;
- $$self .= join('', @_);
-}
-
-sub PRINTF {
- my $self = shift;
- $$self .= sprintf(@_);
-}
-
-sub read {
- my $self = shift;
- return substr($$self, 0, length($$self), '');
-}
+++ /dev/null
-#!./perl
-
-BEGIN {
- chdir 't' if -d 't';
- if ($^O eq 'MacOS') {
- @INC = qw(: ::lib ::macos:lib);
- } else {
- @INC = '.';
- push @INC, '../lib';
- }
-}
-
-$| = 1;
-use warnings;
-use strict;
-use Config;
-
-print "1..3\n";
-
-my $test = 1;
-
-sub ok { print "ok $test\n"; $test++ }
-
-
-my $a;
-my $Is_VMS = $^O eq 'VMS';
-my $Is_MacOS = $^O eq 'MacOS';
-
-my $path = join " ", map { qq["-I$_"] } @INC;
-my $redir = $Is_MacOS ? "" : "2>&1";
-
-$a = `$^X $path "-MO=Debug" -e 1 $redir`;
-print "not " unless $a =~
-/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s;
-ok;
-
-
-$a = `$^X $path "-MO=Terse" -e 1 $redir`;
-print "not " unless $a =~
-/\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s;
-ok;
-
-$a = `$^X $path "-MO=Terse" -ane "s/foo/bar/" $redir`;
-$a =~ s/\(0x[^)]+\)//g;
-$a =~ s/\[[^\]]+\]//g;
-$a =~ s/-e syntax OK//;
-$a =~ s/[^a-z ]+//g;
-$a =~ s/\s+/ /g;
-$a =~ s/\b(s|foo|bar|ullsv)\b\s?//g;
-$a =~ s/^\s+//;
-$a =~ s/\s+$//;
-my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
-if ($is_thread) {
- $b=<<EOF;
-leave enter nextstate label leaveloop enterloop null and defined null
-threadsv readline gv lineseq nextstate aassign null pushmark split pushre
-threadsv const null pushmark rvav gv nextstate subst const unstack nextstate
-EOF
-} else {
- $b=<<EOF;
-leave enter nextstate label leaveloop enterloop null and defined null
-null gvsv readline gv lineseq nextstate aassign null pushmark split pushre
-null gvsv const null pushmark rvav gv nextstate subst const unstack nextstate
-EOF
-}
-$b=~s/\n/ /g;$b=~s/\s+/ /g;
-$b =~ s/\s+$//;
-print "# [$a]\n# vs\n# [$b]\nnot " if $a ne $b;
-ok;
-
+++ /dev/null
-#!./perl
-
-BEGIN {
- chdir 't' if -d 't';
- if ($^O eq 'MacOS') {
- @INC = qw(: ::lib ::macos:lib);
- } else {
- @INC = '.';
- push @INC, '../lib';
- }
-}
-
-$| = 1;
-use warnings;
-use strict;
-use Config;
-
-print "1..15\n";
-
-use B::Deparse;
-my $deparse = B::Deparse->new() or print "not ";
-my $i=1;
-print "ok " . $i++ . "\n";
-
-
-# Tell B::Deparse about our ambient pragmas
-{ my ($hint_bits, $warning_bits);
- BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
- $deparse->ambient_pragmas (
- hint_bits => $hint_bits,
- warning_bits => $warning_bits,
- '$[' => 0 + $[
- );
-}
-
-$/ = "\n####\n";
-while (<DATA>) {
- chomp;
- s/#.*$//mg;
-
- my ($input, $expected);
- if (/(.*)\n>>>>\n(.*)/s) {
- ($input, $expected) = ($1, $2);
- }
- else {
- ($input, $expected) = ($_, $_);
- }
-
- my $coderef = eval "sub {$input}";
-
- if ($@) {
- print "not ok " . $i++ . "\n";
- print "# $@";
- }
- else {
- my $deparsed = $deparse->coderef2text( $coderef );
- my $regex = quotemeta($expected);
- do {
- no warnings 'misc';
- $regex =~ s/\s+/\s+/g;
- };
-
- my $ok = ($deparsed =~ /^\{\s*$regex\s*\}$/);
- print (($ok ? "ok " : "not ok ") . $i++ . "\n");
- if (!$ok) {
- print "# EXPECTED:\n";
- $regex =~ s/^/# /mg;
- print "$regex\n";
-
- print "\n# GOT: \n";
- $deparsed =~ s/^/# /mg;
- print "$deparsed\n";
- }
- }
-}
-
-use constant 'c', 'stuff';
-print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
-print "ok " . $i++ . "\n";
-
-$a = 0;
-print "not " if "{\n (-1) ** \$a;\n}"
- ne $deparse->coderef2text(sub{(-1) ** $a });
-print "ok " . $i++ . "\n";
-
-# XXX ToDo - constsub that returns a reference
-#use constant cr => ['hello'];
-#my $string = "sub " . $deparse->coderef2text(\&cr);
-#my $val = (eval $string)->();
-#print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
-#print "ok " . $i++ . "\n";
-
-my $a;
-my $Is_VMS = $^O eq 'VMS';
-my $Is_MacOS = $^O eq 'MacOS';
-
-my $path = join " ", map { qq["-I$_"] } @INC;
-$path .= " -MMac::err=unix" if $Is_MacOS;
-my $redir = $Is_MacOS ? "" : "2>&1";
-
-$a = `$^X $path "-MO=Deparse" -anle 1 $redir`;
-$a =~ s/(?:# )?-e syntax OK\n//g; # "# " for Mac OS
-$a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
-$a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
-$b = <<'EOF';
-LINE: while (defined($_ = <ARGV>)) {
- chomp $_;
- our(@F) = split(" ", $_, 0);
- '???';
-}
-EOF
-print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b;
-print "ok " . $i++ . "\n";
-
-__DATA__
-# 2
-1;
-####
-# 3
-{
- no warnings;
- '???';
- 2;
-}
-####
-# 4
-my $test;
-++$test and $test /= 2;
->>>>
-my $test;
-$test /= 2 if ++$test;
-####
-# 5
--((1, 2) x 2);
-####
-# 6
-{
- my $test = sub : lvalue {
- my $x;
- }
- ;
-}
-####
-# 7
-{
- my $test = sub : method {
- my $x;
- }
- ;
-}
-####
-# 8
-{
- my $test = sub : locked method {
- my $x;
- }
- ;
-}
-####
-# 9
-{
- 234;
-}
-continue {
- 123;
-}
-####
-# 10
-my $x;
-print $main::x;
-####
-# 11
-my @x;
-print $main::x[1];
-####
-# 12
-my %x;
-$x{warn()};
+++ /dev/null
-#!./perl
-
-BEGIN {
- if ($^O eq 'MacOS') {
- @INC = qw(: ::lib ::macos:lib);
- }
-}
-
-$| = 1;
-use warnings;
-use strict;
-use Config;
-
-print "1..1\n";
-
-my $test = 1;
-
-sub ok { print "ok $test\n"; $test++ }
-
-my $a;
-my $Is_VMS = $^O eq 'VMS';
-my $Is_MacOS = $^O eq 'MacOS';
-
-my $path = join " ", map { qq["-I$_"] } @INC;
-$path = '"-I../lib" "-Iperl_root:[lib]"' if $Is_VMS; # gets too long otherwise
-my $redir = $Is_MacOS ? "" : "2>&1";
-my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
-
-if ($is_thread) {
- print "# use5005threads: test $test skipped\n";
-} else {
- $a = `$^X $path "-MO=Showlex" -e "my \@one" $redir`;
- if (ord('A') != 193) { # ASCIIish
- print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*\@one.*sv_undef.*AV/s;
- }
- else { # EBCDICish C<1: PVNV (0x1a7ede34) "@\226\225\205">
- print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*\@\\[0-9].*sv_undef.*AV/s;
- }
-}
-ok;
+++ /dev/null
-#!./perl
-
-BEGIN {
- if ($^O eq 'MacOS') {
- @INC = qw(: ::lib ::macos:lib);
- }
-}
-
-$| = 1;
-use warnings;
-use strict;
-use Config;
-
-print "1..1\n";
-
-my $test = 1;
-
-sub ok { print "ok $test\n"; $test++ }
-
-
-my $a;
-my $Is_VMS = $^O eq 'VMS';
-my $Is_MacOS = $^O eq 'MacOS';
-
-my $path = join " ", map { qq["-I$_"] } @INC;
-$path = '"-I../lib" "-Iperl_root:[lib]"' if $Is_VMS; # gets too long otherwise
-my $redir = $Is_MacOS ? "" : "2>&1";
-
-
-chomp($a = `$^X $path "-MB::Stash" "-Mwarnings" -e1`);
-$a = join ',', sort split /,/, $a;
-$a =~ s/-u(PerlIO|open)(?:::\w+)?,//g;
-$a =~ s/-uWin32,// if $^O eq 'MSWin32';
-$a =~ s/-uNetWare,// if $^O eq 'NetWare';
-$a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2';
-$a =~ s/-uCwd,// if $^O eq 'cygwin';
- $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,'
- . '-umain,-ustrict,-uutf8,-uwarnings';
-if ($Is_VMS) {
- $a =~ s/-uFile,-uFile::Copy,//;
- $a =~ s/-uVMS,-uVMS::Filespec,//;
- $a =~ s/-uSocket,//; # Socket is optional/compiler version dependent
-}
-
-{
- no strict 'vars';
- use vars '$OS2::is_aout';
-}
-if ((($Config{static_ext} eq ' ') || ($Config{static_ext} eq ''))
- && !($^O eq 'os2' and $OS2::is_aout)
- ) {
- if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a)
- $b = join ',', sort split /,/, $b;
- }
- print "# [$a]\n# vs.\n# [$b]\nnot " if $a ne $b;
- ok;
-} else {
- print "ok $test # skipped: one or more static extensions\n"; $test++;
-}
-
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '.';
+ push @INC, '../lib';
+ }
+}
+
+$| = 1;
+use warnings;
+use strict;
+use Config;
+
+print "1..2\n";
+
+my $test = 1;
+
+sub ok { print "ok $test\n"; $test++ }
+
+use B;
+
+
+package Testing::Symtable;
+use vars qw($This @That %wibble $moo %moo);
+my $not_a_sym = 'moo';
+
+sub moo { 42 }
+sub car { 23 }
+
+
+package Testing::Symtable::Foo;
+sub yarrow { "Hock" }
+
+package Testing::Symtable::Bar;
+sub hock { "yarrow" }
+
+package main;
+use vars qw(%Subs);
+local %Subs = ();
+B::walksymtable(\%Testing::Symtable::, 'find_syms', sub { $_[0] =~ /Foo/ },
+ 'Testing::Symtable::');
+
+sub B::GV::find_syms {
+ my($symbol) = @_;
+
+ $main::Subs{$symbol->STASH->NAME . '::' . $symbol->NAME}++;
+}
+
+my @syms = map { 'Testing::Symtable::'.$_ } qw(This That wibble moo car
+ BEGIN);
+push @syms, "Testing::Symtable::Foo::yarrow";
+
+# Make sure we hit all the expected symbols.
+print "not " unless join('', sort @syms) eq join('', sort keys %Subs);
+ok;
+
+# Make sure we only hit them each once.
+print "not " unless !grep $_ != 1, values %Subs;
+ok;
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '.';
+ push @INC, '../lib';
+ }
+}
+
+$| = 1;
+use warnings;
+use strict;
+use Config;
+
+print "1..3\n";
+
+my $test = 1;
+
+sub ok { print "ok $test\n"; $test++ }
+
+
+my $a;
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MacOS = $^O eq 'MacOS';
+
+my $path = join " ", map { qq["-I$_"] } @INC;
+my $redir = $Is_MacOS ? "" : "2>&1";
+
+$a = `$^X $path "-MO=Debug" -e 1 $redir`;
+print "not " unless $a =~
+/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s;
+ok;
+
+
+$a = `$^X $path "-MO=Terse" -e 1 $redir`;
+print "not " unless $a =~
+/\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s;
+ok;
+
+$a = `$^X $path "-MO=Terse" -ane "s/foo/bar/" $redir`;
+$a =~ s/\(0x[^)]+\)//g;
+$a =~ s/\[[^\]]+\]//g;
+$a =~ s/-e syntax OK//;
+$a =~ s/[^a-z ]+//g;
+$a =~ s/\s+/ /g;
+$a =~ s/\b(s|foo|bar|ullsv)\b\s?//g;
+$a =~ s/^\s+//;
+$a =~ s/\s+$//;
+my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
+if ($is_thread) {
+ $b=<<EOF;
+leave enter nextstate label leaveloop enterloop null and defined null
+threadsv readline gv lineseq nextstate aassign null pushmark split pushre
+threadsv const null pushmark rvav gv nextstate subst const unstack nextstate
+EOF
+} else {
+ $b=<<EOF;
+leave enter nextstate label leaveloop enterloop null and defined null
+null gvsv readline gv lineseq nextstate aassign null pushmark split pushre
+null gvsv const null pushmark rvav gv nextstate subst const unstack nextstate
+EOF
+}
+$b=~s/\n/ /g;$b=~s/\s+/ /g;
+$b =~ s/\s+$//;
+print "# [$a]\n# vs\n# [$b]\nnot " if $a ne $b;
+ok;
+
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ } else {
+ @INC = '.';
+ push @INC, '../lib';
+ }
+}
+
+$| = 1;
+use warnings;
+use strict;
+use Config;
+
+print "1..15\n";
+
+use B::Deparse;
+my $deparse = B::Deparse->new() or print "not ";
+my $i=1;
+print "ok " . $i++ . "\n";
+
+
+# Tell B::Deparse about our ambient pragmas
+{ my ($hint_bits, $warning_bits);
+ BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
+ $deparse->ambient_pragmas (
+ hint_bits => $hint_bits,
+ warning_bits => $warning_bits,
+ '$[' => 0 + $[
+ );
+}
+
+$/ = "\n####\n";
+while (<DATA>) {
+ chomp;
+ s/#.*$//mg;
+
+ my ($input, $expected);
+ if (/(.*)\n>>>>\n(.*)/s) {
+ ($input, $expected) = ($1, $2);
+ }
+ else {
+ ($input, $expected) = ($_, $_);
+ }
+
+ my $coderef = eval "sub {$input}";
+
+ if ($@) {
+ print "not ok " . $i++ . "\n";
+ print "# $@";
+ }
+ else {
+ my $deparsed = $deparse->coderef2text( $coderef );
+ my $regex = quotemeta($expected);
+ do {
+ no warnings 'misc';
+ $regex =~ s/\s+/\s+/g;
+ };
+
+ my $ok = ($deparsed =~ /^\{\s*$regex\s*\}$/);
+ print (($ok ? "ok " : "not ok ") . $i++ . "\n");
+ if (!$ok) {
+ print "# EXPECTED:\n";
+ $regex =~ s/^/# /mg;
+ print "$regex\n";
+
+ print "\n# GOT: \n";
+ $deparsed =~ s/^/# /mg;
+ print "$deparsed\n";
+ }
+ }
+}
+
+use constant 'c', 'stuff';
+print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
+print "ok " . $i++ . "\n";
+
+$a = 0;
+print "not " if "{\n (-1) ** \$a;\n}"
+ ne $deparse->coderef2text(sub{(-1) ** $a });
+print "ok " . $i++ . "\n";
+
+# XXX ToDo - constsub that returns a reference
+#use constant cr => ['hello'];
+#my $string = "sub " . $deparse->coderef2text(\&cr);
+#my $val = (eval $string)->();
+#print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
+#print "ok " . $i++ . "\n";
+
+my $a;
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MacOS = $^O eq 'MacOS';
+
+my $path = join " ", map { qq["-I$_"] } @INC;
+$path .= " -MMac::err=unix" if $Is_MacOS;
+my $redir = $Is_MacOS ? "" : "2>&1";
+
+$a = `$^X $path "-MO=Deparse" -anle 1 $redir`;
+$a =~ s/(?:# )?-e syntax OK\n//g; # "# " for Mac OS
+$a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
+$a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
+$b = <<'EOF';
+LINE: while (defined($_ = <ARGV>)) {
+ chomp $_;
+ our(@F) = split(" ", $_, 0);
+ '???';
+}
+EOF
+print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b;
+print "ok " . $i++ . "\n";
+
+__DATA__
+# 2
+1;
+####
+# 3
+{
+ no warnings;
+ '???';
+ 2;
+}
+####
+# 4
+my $test;
+++$test and $test /= 2;
+>>>>
+my $test;
+$test /= 2 if ++$test;
+####
+# 5
+-((1, 2) x 2);
+####
+# 6
+{
+ my $test = sub : lvalue {
+ my $x;
+ }
+ ;
+}
+####
+# 7
+{
+ my $test = sub : method {
+ my $x;
+ }
+ ;
+}
+####
+# 8
+{
+ my $test = sub : locked method {
+ my $x;
+ }
+ ;
+}
+####
+# 9
+{
+ 234;
+}
+continue {
+ 123;
+}
+####
+# 10
+my $x;
+print $main::x;
+####
+# 11
+my @x;
+print $main::x[1];
+####
+# 12
+my %x;
+$x{warn()};
--- /dev/null
+#!./perl
+
+BEGIN {
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ }
+}
+
+$| = 1;
+use warnings;
+use strict;
+use Config;
+
+print "1..1\n";
+
+my $test = 1;
+
+sub ok { print "ok $test\n"; $test++ }
+
+my $a;
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MacOS = $^O eq 'MacOS';
+
+my $path = join " ", map { qq["-I$_"] } @INC;
+$path = '"-I../lib" "-Iperl_root:[lib]"' if $Is_VMS; # gets too long otherwise
+my $redir = $Is_MacOS ? "" : "2>&1";
+my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
+
+if ($is_thread) {
+ print "# use5005threads: test $test skipped\n";
+} else {
+ $a = `$^X $path "-MO=Showlex" -e "my \@one" $redir`;
+ if (ord('A') != 193) { # ASCIIish
+ print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*\@one.*sv_undef.*AV/s;
+ }
+ else { # EBCDICish C<1: PVNV (0x1a7ede34) "@\226\225\205">
+ print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*\@\\[0-9].*sv_undef.*AV/s;
+ }
+}
+ok;
--- /dev/null
+#!./perl
+
+BEGIN {
+ if ($^O eq 'MacOS') {
+ @INC = qw(: ::lib ::macos:lib);
+ }
+}
+
+$| = 1;
+use warnings;
+use strict;
+use Config;
+
+print "1..1\n";
+
+my $test = 1;
+
+sub ok { print "ok $test\n"; $test++ }
+
+
+my $a;
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MacOS = $^O eq 'MacOS';
+
+my $path = join " ", map { qq["-I$_"] } @INC;
+$path = '"-I../lib" "-Iperl_root:[lib]"' if $Is_VMS; # gets too long otherwise
+my $redir = $Is_MacOS ? "" : "2>&1";
+
+
+chomp($a = `$^X $path "-MB::Stash" "-Mwarnings" -e1`);
+$a = join ',', sort split /,/, $a;
+$a =~ s/-u(PerlIO|open)(?:::\w+)?,//g;
+$a =~ s/-uWin32,// if $^O eq 'MSWin32';
+$a =~ s/-uNetWare,// if $^O eq 'NetWare';
+$a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2';
+$a =~ s/-uCwd,// if $^O eq 'cygwin';
+ $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,'
+ . '-umain,-ustrict,-uutf8,-uwarnings';
+if ($Is_VMS) {
+ $a =~ s/-uFile,-uFile::Copy,//;
+ $a =~ s/-uVMS,-uVMS::Filespec,//;
+ $a =~ s/-uSocket,//; # Socket is optional/compiler version dependent
+}
+
+{
+ no strict 'vars';
+ use vars '$OS2::is_aout';
+}
+if ((($Config{static_ext} eq ' ') || ($Config{static_ext} eq ''))
+ && !($^O eq 'os2' and $OS2::is_aout)
+ ) {
+ if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a)
+ $b = join ',', sort split /,/, $b;
+ }
+ print "# [$a]\n# vs.\n# [$b]\nnot " if $a ne $b;
+ ok;
+} else {
+ print "ok $test # skipped: one or more static extensions\n"; $test++;
+}
+
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Test::More tests => 15;
+
+use_ok( 'B::Terse' );
+
+# indent should return a string indented four spaces times the argument
+is( B::Terse::indent(2), ' ' x 8, 'indent works with an argument' );
+is( B::Terse::indent(), '', 'indent works with no argument' );
+
+# this should fail without a reference
+eval { B::Terse::terse('scalar') };
+like( $@, qr/not a reference/, 'terse() caught bad parameters okay' );
+
+# now point it at a sub and see what happens
+sub foo {}
+
+my $sub;
+eval{ $sub = B::Terse::compile('', 'foo') };
+is( $@, '', 'compile() worked without error' );
+ok( defined &$sub, 'got a valid subref back from compile()' );
+
+# and point it at a real sub and hope the returned ops look alright
+my $out = tie *STDOUT, 'TieOut';
+$sub = B::Terse::compile('', 'bar');
+$sub->();
+
+# now build some regexes that should match the dumped ops
+my ($hex, $op) = ('\(0x[a-f0-9]+\)', '\s+\w+');
+my %ops = map { $_ => qr/$_ $hex$op/ }
+ qw ( OP COP LOOP PMOP UNOP BINOP LOGOP LISTOP );
+
+# split up the output lines into individual ops (terse is, well, terse!)
+# use an array here so $_ is modifiable
+my @lines = split(/\n+/, $out->read);
+foreach (@lines) {
+ next unless /\S/;
+ s/^\s+//;
+ if (/^([A-Z]+)\s+/) {
+ my $op = $1;
+ next unless exists $ops{$op};
+ like( $_, $ops{$op}, "$op appears okay" );
+ delete $ops{$op};
+ s/$ops{$op}//;
+ redo if $_;
+ }
+}
+
+warn "# didn't find " . join(' ', keys %ops) if keys %ops;
+
+# XXX:
+# this tries to get at all tersified optypes in B::Terse
+# if you add AV, NULL, PADOP, PVOP, or SPECIAL, add it to the regex above too
+#
+use vars qw( $a $b );
+sub bar {
+ # OP SVOP COP IV here or in sub definition
+ my @bar = (1, 2, 3);
+
+ # got a GV here
+ my $foo = $a + $b;
+
+ # NV here
+ $a = 1.234;
+
+ # this is awful, but it gives a PMOP
+ my $boo = split('', $foo);
+
+ # PMOP
+ LOOP: for (1 .. 10) {
+ last LOOP if $_ % 2;
+ }
+
+ # make a PV
+ $foo = "a string";
+}
+
+# Schwern's example of finding an RV
+my $path = join " ", map { qq["-I$_"] } @INC;
+my $redir = $^O eq 'MacOS' ? '' : "2>&1";
+my $items = qx{$^X $path "-MO=Terse" -le "print \\42" $redir};
+like( $items, qr/RV $hex \\42/, 'found an RV, appears okay!' );
+
+package TieOut;
+
+sub TIEHANDLE {
+ bless( \(my $out), $_[0] );
+}
+
+sub PRINT {
+ my $self = shift;
+ $$self .= join('', @_);
+}
+
+sub PRINTF {
+ my $self = shift;
+ $$self .= sprintf(@_);
+}
+
+sub read {
+ my $self = shift;
+ return substr($$self, 0, length($$self), '');
+}
projects / platform / upstream / perl.git / commitdiff