B::walksymtable improperly documented?
Michael G. Schwern [Sat, 21 Apr 2001 16:11:12 +0000 (17:11 +0100)]
Message-ID: <20010421161112.L19736@blackrider.blackstar.co.uk>

p4raw-id: //depot/perl@9770

MANIFEST
ext/B/B.pm
t/lib/b-debug.t [new file with mode: 0644]
t/lib/b-deparse.t [new file with mode: 0644]
t/lib/b-showlex.t [new file with mode: 0644]
t/lib/b-stash.t [new file with mode: 0644]
t/lib/b.t

index 1a4e26f..9ee8e96 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1439,7 +1439,15 @@ t/lib/ansicolor.t        See if Term::ANSIColor works
 t/lib/anydbm.t         See if AnyDBM_File works
 t/lib/attrs.t          See if attrs works with C<sub : attrs>
 t/lib/autoloader.t     See if AutoLoader works
-t/lib/b.t              See if B backends work
+t/lib/b.t              See if B works
+t/lib/b-debug.t         See if B::Debug works
+t/lib/b-deparse.t       See if B::Deparse works
+t/lib/b-showlex.t       See if B::ShowLex works
+t/lib/b-stash.t         See if B::Stash works
+t/lib/b-debug.t         See if B::Debug works
+t/lib/b-deparse.t       See if B::Deparse works
+t/lib/b-showlex.t       See if B::ShowLex works
+t/lib/b-stash.t         See if B::Stash works
 t/lib/basename.t       See if File::Basename works
 t/lib/bigfloat.t       See if bigfloat.pl works
 t/lib/bigfltpm.t       See if BigFloat.pm works
index d00f512..97dd0c7 100644 (file)
@@ -843,12 +843,24 @@ DEBUG argument is non-zero, it sets the debugging flag to that. See
 the description of C<walkoptree> above for what the debugging flag
 does.
 
-=item walksymtable(SYMREF, METHOD, RECURSE)
+=item walksymtable(SYMREF, METHOD, RECURSE, PREFIX)
 
 Walk the symbol table starting at SYMREF and call METHOD on each
-symbol visited. When the walk reached package symbols "Foo::" it
-invokes RECURSE and only recurses into the package if that sub
-returns true.
+symbol (a B::GV object) visited.  When the walk reaches package
+symbols (such as "Foo::") it invokes RECURSE, passing in the symbol
+name, and only recurses into the package if that sub returns true.
+
+PREFIX is the name of the SYMREF you're walking.
+
+For example...
+
+  # Walk CGI's symbol table calling print_subs on each symbol.
+  # Only recurse into CGI::Util::
+  walksymtable(\%CGI::, 'print_subs', sub { $_[0] eq 'CGI::Util::' },
+               'CGI::');
+
+print_subs() is a B::GV method you have declared.
+
 
 =item svref_2object(SV)
 
diff --git a/t/lib/b-debug.t b/t/lib/b-debug.t
new file mode 100644 (file)
index 0000000..286dac3
--- /dev/null
@@ -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/t/lib/b-deparse.t b/t/lib/b-deparse.t
new file mode 100644 (file)
index 0000000..b321213
--- /dev/null
@@ -0,0 +1,129 @@
+#!./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";
+
+my $test = 1;
+
+sub ok { print "ok $test\n"; $test++ }
+
+
+use B::Deparse;
+my $deparse = B::Deparse->new() or print "not ";
+ok;
+
+# 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 + $[
+ );
+}
+
+print "not " if "{\n    1;\n}" ne $deparse->coderef2text(sub {1});
+ok;
+
+print "not " if "{\n    '???';\n    2;\n}" ne
+                    $deparse->coderef2text(sub {1;2});
+ok;
+
+print "not " if "{\n    \$test /= 2 if ++\$test;\n}" ne
+                    $deparse->coderef2text(sub {++$test and $test/=2;});
+ok;
+
+print "not " if "{\n    -((1, 2) x 2);\n}" ne
+                    $deparse->coderef2text(sub {-((1,2)x2)});
+ok;
+
+{
+my $a = <<'EOF';
+{
+    $test = sub : lvalue {
+        my $x;
+    }
+    ;
+}
+EOF
+chomp $a;
+print "not " if $deparse->coderef2text(sub{$test = sub : lvalue{my $x}}) ne $a;
+ok;
+
+$a =~ s/lvalue/method/;
+print "not " if $deparse->coderef2text(sub{$test = sub : method{my $x}}) ne $a;
+ok;
+
+$a =~ s/method/locked method/;
+print "not " if $deparse->coderef2text(sub{$test = sub : method locked {my $x}})
+                                     ne $a;
+ok;
+}
+
+print "not " if (eval "sub ".$deparse->coderef2text(sub () { 42 }))->() != 42;
+ok;
+
+use constant 'c', 'stuff';
+print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
+ok;
+
+$a = 0;
+print "not " if "{\n    (-1) ** \$a;\n}"
+               ne $deparse->coderef2text(sub{(-1) ** $a });
+ok;
+
+# 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';
+#ok;
+
+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\n# [$b]\nnot " if $a ne $b;
+ok;
+
+
+# Bug 20001204.07
+{
+my $foo = $deparse->coderef2text(sub { { 234; }});
+# Constants don't get optimised here.
+print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm;
+ok;
+$foo = $deparse->coderef2text(sub { { 234; } continue { 123; } });
+print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm;
+ok;
+}
diff --git a/t/lib/b-showlex.t b/t/lib/b-showlex.t
new file mode 100644 (file)
index 0000000..a21f03b
--- /dev/null
@@ -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/t/lib/b-stash.t b/t/lib/b-stash.t
new file mode 100644 (file)
index 0000000..de43912
--- /dev/null
@@ -0,0 +1,45 @@
+#!./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/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2';
+$a =~ s/-uCwd,// if $^O eq 'cygwin';
+if ($Config{static_ext} eq ' ') {
+  $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,'
+     . '-umain,-ustrict,-uutf8,-uwarnings';
+  if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a)
+      $b = join ',', sort split /,/, $b;
+  }
+  print "# [$a] vs [$b]\nnot " if $a ne $b;
+  ok;
+} else {
+  print "ok $test # skipped: one or more static extensions\n"; $test++;
+}
index 65a8013..f21f489 100755 (executable)
--- a/t/lib/b.t
+++ b/t/lib/b.t
@@ -15,182 +15,49 @@ use warnings;
 use strict;
 use Config;
 
-print "1..19\n";
+print "1..2\n";
 
 my $test = 1;
 
 sub ok { print "ok $test\n"; $test++ }
 
-use B::Deparse;
-my $deparse = B::Deparse->new() or print "not ";
-ok;
+use B;
 
-# 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 + $[
- );
-}
 
-print "not " if "{\n    1;\n}" ne $deparse->coderef2text(sub {1});
-ok;
+package Testing::Symtable;
+use vars qw($This @That %wibble $moo %moo);
+my $not_a_sym = 'moo';
 
-print "not " if "{\n    '???';\n    2;\n}" ne
-                    $deparse->coderef2text(sub {1;2});
-ok;
+sub moo { 42 }
+sub car { 23 }
 
-print "not " if "{\n    \$test /= 2 if ++\$test;\n}" ne
-                    $deparse->coderef2text(sub {++$test and $test/=2;});
-ok;
 
-print "not " if "{\n    -((1, 2) x 2);\n}" ne
-                    $deparse->coderef2text(sub {-((1,2)x2)});
-ok;
+package Testing::Symtable::Foo;
+sub yarrow { "Hock" }
 
-{
-my $a = <<'EOF';
-{
-    $test = sub : lvalue {
-        my $x;
-    }
-    ;
-}
-EOF
-chomp $a;
-print "not " if $deparse->coderef2text(sub{$test = sub : lvalue{my $x}}) ne $a;
-ok;
+package Testing::Symtable::Bar;
+sub hock { "yarrow" }
 
-$a =~ s/lvalue/method/;
-print "not " if $deparse->coderef2text(sub{$test = sub : method{my $x}}) ne $a;
-ok;
-
-$a =~ s/method/locked method/;
-print "not " if $deparse->coderef2text(sub{$test = sub : method locked {my $x}})
-                                     ne $a;
-ok;
-}
+package main;
+use vars qw(%Subs);
+local %Subs = ();
+B::walksymtable(\%Testing::Symtable::, 'find_syms', sub { $_[0] =~ /Foo/ },
+                'Testing::Symtable::');
 
-print "not " if (eval "sub ".$deparse->coderef2text(sub () { 42 }))->() != 42;
-ok;
-
-use constant 'c', 'stuff';
-print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
-ok;
+sub B::GV::find_syms {
+    my($symbol) = @_;
 
-$a = 0;
-print "not " if "{\n    (-1) ** \$a;\n}"
-               ne $deparse->coderef2text(sub{(-1) ** $a });
-ok;
-
-# 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';
-#ok;
-
-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\n# [$b]\nnot " if $a ne $b;
-ok;
-
-$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
+    $main::Subs{$symbol->STASH->NAME . '::' . $symbol->NAME}++;
 }
-$b=~s/\n/ /g;$b=~s/\s+/ /g;
-$b =~ s/\s+$//;
-print "# [$a]\n# vs\n# [$b]\nnot " if $a ne $b;
-ok;
 
-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/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2';
-$a =~ s/-uCwd,// if $^O eq 'cygwin';
-if ($Config{static_ext} eq ' ') {
-  $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,'
-     . '-umain,-ustrict,-uutf8,-uwarnings';
-  if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a)
-      $b = join ',', sort split /,/, $b;
-  }
-  print "# [$a] vs [$b]\nnot " if $a ne $b;
-  ok;
-} else {
-  print "ok $test # skipped: one or more static extensions\n"; $test++;
-}
+my @syms = map { 'Testing::Symtable::'.$_ } qw(This That wibble moo car
+                                               BEGIN);
+push @syms, "Testing::Symtable::Foo::yarrow";
 
-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;
-    }
-}
+# Make sure we hit all the expected symbols.
+print "not " unless join('', sort @syms) eq join('', sort keys %Subs);
 ok;
 
-# Bug 20001204.07
-{
-my $foo = $deparse->coderef2text(sub { { 234; }});
-# Constants don't get optimised here.
-print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm;
+# Make sure we only hit them each once.
+print "not " unless !grep $_ != 1, values %Subs;
 ok;
-$foo = $deparse->coderef2text(sub { { 234; } continue { 123; } });
-print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm;
-ok;
-}