diff options
author | Jarkko Hietaniemi <jhi@iki.fi> | 2001-06-18 04:17:15 +0000 |
---|---|---|
committer | Jarkko Hietaniemi <jhi@iki.fi> | 2001-06-18 04:17:15 +0000 |
commit | b695f709e8a342e35e482b0437eb6cdacdc58b6b (patch) | |
tree | 2d16192636e6ba806ff7a907f682c74f7705a920 /ext/B | |
parent | d780cd7a0195e946e636d3ee546f6ef4f21d6acc (diff) | |
download | perl-b695f709e8a342e35e482b0437eb6cdacdc58b6b.tar.gz |
The Grand Trek: move the *.t files from t/ to lib/ and ext/.
No doubt I made some mistakes like missed some files or
misnamed some files. The naming rules were more or less:
(1) if the module is from CPAN, follows its ways, be it
t/*.t or test.pl.
(2) otherwise if there are multiple tests for a module
put them in a t/
(3) otherwise if there's only one test put it in Module.t
(4) helper files go to module/ (locale, strict, warnings)
(5) use longer filenames now that we can (but e.g. the
compat-0.6.t and the Text::Balanced test files still
were renamed to be more civil against the 8.3 people)
installperl was updated appropriately not to install the
*.t files or the help files from under lib.
TODO: some helper files still remain under t/ that could
follow their 'masters'. UPDATE: On second thoughts, why
should they. They can continue to live under t/lib, and
in fact the locale/strict/warnings helpers that were moved
could be moved back. This way the amount of non-installable
stuff under lib/ stays smaller.
p4raw-id: //depot/perl@10676
Diffstat (limited to 'ext/B')
-rwxr-xr-x | ext/B/B.t | 63 | ||||
-rw-r--r-- | ext/B/Debug.t | 70 | ||||
-rw-r--r-- | ext/B/Deparse.t | 176 | ||||
-rw-r--r-- | ext/B/Showlex.t | 39 | ||||
-rw-r--r-- | ext/B/Stash.t | 60 |
5 files changed, 408 insertions, 0 deletions
diff --git a/ext/B/B.t b/ext/B/B.t new file mode 100755 index 0000000000..f21f4891e4 --- /dev/null +++ b/ext/B/B.t @@ -0,0 +1,63 @@ +#!./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; diff --git a/ext/B/Debug.t b/ext/B/Debug.t new file mode 100644 index 0000000000..286dac3574 --- /dev/null +++ b/ext/B/Debug.t @@ -0,0 +1,70 @@ +#!./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; + diff --git a/ext/B/Deparse.t b/ext/B/Deparse.t new file mode 100644 index 0000000000..048ce31eef --- /dev/null +++ b/ext/B/Deparse.t @@ -0,0 +1,176 @@ +#!./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..14\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 "); + print $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; +my $redir = $Is_MacOS ? "" : "2>&1"; + +$a = `$^X $path "-MO=Deparse" -anle 1 $redir`; +$a =~ s/-e syntax OK\n//g; +$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 $_; + @F = split(" ", $_, 0); + '???'; +} + +EOF +print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b; +print "ok ", $i++, "\n"; + +__DATA__ +# 1 +1; +#### +# 2 +{ + no warnings; + '???'; + 2; +} +#### +# 3 +my $test; +++$test and $test /= 2; +>>>> +my $test; +$test /= 2 if ++$test; +#### +# 4 +-((1, 2) x 2); +#### +# 5 +{ + my $test = sub : lvalue { + my $x; + } + ; +} +#### +# 6 +{ + my $test = sub : method { + my $x; + } + ; +} +#### +# 7 +{ + my $test = sub : locked method { + my $x; + } + ; +} +#### +# 8 +{ + 234; +} +continue { + 123; +} +#### +# 9 +my $x; +print $main::x; +#### +# 10 +my @x; +print $main::x[1]; diff --git a/ext/B/Showlex.t b/ext/B/Showlex.t new file mode 100644 index 0000000000..a21f03bb15 --- /dev/null +++ b/ext/B/Showlex.t @@ -0,0 +1,39 @@ +#!./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; +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.*HV/s; + } + else { # EBCDICish C<1: PVNV (0x1a7ede34) "%\226\225\205"> + print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%\\[0-9].*sv_undef.*HV/s; + } +} +ok; diff --git a/ext/B/Stash.t b/ext/B/Stash.t new file mode 100644 index 0000000000..bc9d896927 --- /dev/null +++ b/ext/B/Stash.t @@ -0,0 +1,60 @@ +#!./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; +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 if defined $Config{'useperlio'} and $Config{'useperlio'} eq 'define'; +$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 'Socket' && $Is_VMS)) + && !($^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++; +} + |