summaryrefslogtreecommitdiff
path: root/ext/B
diff options
context:
space:
mode:
authorJarkko Hietaniemi <jhi@iki.fi>2001-06-18 04:17:15 +0000
committerJarkko Hietaniemi <jhi@iki.fi>2001-06-18 04:17:15 +0000
commitb695f709e8a342e35e482b0437eb6cdacdc58b6b (patch)
tree2d16192636e6ba806ff7a907f682c74f7705a920 /ext/B
parentd780cd7a0195e946e636d3ee546f6ef4f21d6acc (diff)
downloadperl-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-xext/B/B.t63
-rw-r--r--ext/B/Debug.t70
-rw-r--r--ext/B/Deparse.t176
-rw-r--r--ext/B/Showlex.t39
-rw-r--r--ext/B/Stash.t60
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++;
+}
+