From 87a42246e293661e2d9c528a536402d6ca8fcb1e Mon Sep 17 00:00:00 2001 From: "Michael G. Schwern" Date: Sat, 21 Apr 2001 17:11:12 +0100 Subject: [PATCH] B::walksymtable improperly documented? Message-ID: <20010421161112.L19736@blackrider.blackstar.co.uk> p4raw-id: //depot/perl@9770 --- MANIFEST | 10 ++- ext/B/B.pm | 20 ++++-- t/lib/b-debug.t | 70 +++++++++++++++++++++ t/lib/b-deparse.t | 129 +++++++++++++++++++++++++++++++++++++ t/lib/b-showlex.t | 39 ++++++++++++ t/lib/b-stash.t | 45 +++++++++++++ t/lib/b.t | 185 ++++++++---------------------------------------------- 7 files changed, 334 insertions(+), 164 deletions(-) create mode 100644 t/lib/b-debug.t create mode 100644 t/lib/b-deparse.t create mode 100644 t/lib/b-showlex.t create mode 100644 t/lib/b-stash.t diff --git a/MANIFEST b/MANIFEST index 1a4e26f..9ee8e96 100644 --- 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 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 diff --git a/ext/B/B.pm b/ext/B/B.pm index d00f512..97dd0c7 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -843,12 +843,24 @@ DEBUG argument is non-zero, it sets the debugging flag to that. See the description of C 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 index 0000000..286dac3 --- /dev/null +++ b/t/lib/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=<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($_ = )) { + 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 index 0000000..a21f03b --- /dev/null +++ b/t/lib/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/t/lib/b-stash.t b/t/lib/b-stash.t new file mode 100644 index 0000000..de43912 --- /dev/null +++ b/t/lib/b-stash.t @@ -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++; +} diff --git a/t/lib/b.t b/t/lib/b.t index 65a8013..f21f489 100755 --- 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($_ = )) { - 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=<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; -} -- 2.7.4