a test for B::Xref

Message-ID: <20020313171857.F1144@rafael>

p4raw-id: //depot/perl@15221

2 files changed, 113 insertions, 6 deletions

diff --git a/ext/B/B/Xref.pm b/ext/B/B/Xref.pm
index 5ae19beba0..f727dc766b 100644
--- a/ext/B/B/Xref.pm
+++ b/ext/B/B/Xref.pm
@@ -1,6 +1,6 @@
 package B::Xref;
 
-our $VERSION = '1.00';
+our $VERSION = '1.01';
 
 =head1 NAME
 
@@ -21,8 +21,8 @@ The report generated is in the following format:
     File filename1
       Subroutine subname1
 	Package package1
-	  object1        C<line numbers>
-	  object2        C<line numbers>
+	  object1        line numbers
+	  object2        line numbers
 	  ...
 	Package package2
 	...
@@ -64,6 +64,10 @@ Directs output to C<FILENAME> instead of standard output.
 Raw output. Instead of producing a human-readable report, outputs a line
 in machine-readable form for each definition/use of a variable/sub/format.
 
+=item C<-d>
+
+Don't output the "(definitions)" sections.
+
 =item C<-D[tO]>
 
 (Internal) debug options, probably only useful if C<-r> included.
@@ -89,7 +93,7 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk.
 use strict;
 use Config;
 use B qw(peekop class comppadlist main_start svref_2object walksymtable
-         OPpLVAL_INTRO SVf_POK OPpOUR_INTRO
+         OPpLVAL_INTRO SVf_POK OPpOUR_INTRO cstring
         );
 
 sub UNKNOWN { ["?", "?", "?"] }
@@ -145,7 +149,7 @@ sub load_pad {
 	my $namesv = $namelist[$ix];
 	next if class($namesv) eq "SPECIAL";
 	my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/;
-	$pad[$ix] = ["(lexical)", $type, $name];
+	$pad[$ix] = ["(lexical)", $type || '?', $name || '?'];
     }
     if ($Config{useithreads}) {
 	my (@vallist);
@@ -278,7 +282,8 @@ sub pp_const {
     # constant could be in the pad (under useithreads)
     if ($$sv) {
 	$top = ["?", "",
-		(class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"];
+		(class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK)
+		? cstring($sv->PV) : "?"];
     }
     else {
 	$top = $pad[$op->targ];
diff --git a/ext/B/t/xref.t b/ext/B/t/xref.t
new file mode 100644
index 0000000000..8268e3f898
--- /dev/null
+++ b/ext/B/t/xref.t
@@ -0,0 +1,102 @@
+#!./perl -w
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = qw(../lib);
+}
+
+use strict;
+use Test::More tests => 14;
+
+# line 50
+use_ok( 'B::Xref' );
+
+my $file = 'xreftest.out';
+
+# line 100
+our $compilesub = B::Xref::compile("-o$file");
+ok( ref $compilesub eq 'CODE', "compile() returns a coderef ($compilesub)" );
+$compilesub->(); # Compile this test script
+
+#END { unlink $file or diag "END block failed: $!" }
+
+# Now parse the output
+# line 200
+my ($curfile, $cursub, $curpack) = ('') x 3;
+our %xreftable = ();
+open XREF, $file or die "# Can't open $file: $!\n";
+while (<XREF>) {
+    chomp;
+    if (/^File (.*)/) {
+	$curfile = $1;
+    } elsif (/^  Subroutine (.*)/) {
+	$cursub = $1;
+    } elsif (/^    Package (.*)/) {
+	$curpack = $1;
+    } elsif ($curpack eq '?' && /^      (".*")  +(.*)/
+	    or /^      (\S+)\s+(.*)/) {
+	$xreftable{$curfile}{$cursub}{$curpack}{$1} = $2;
+    }
+}
+close XREF;
+my $thisfile = __FILE__;
+
+ok(
+    defined $xreftable{$thisfile}{'(main)'}{main}{'$compilesub'},
+    '$compilesub present in main program'
+);
+like(
+    $xreftable{$thisfile}{'(main)'}{main}{'$compilesub'},
+    qr/\bi100\b/,
+    '$compilesub introduced at line 100'
+);
+like(
+    $xreftable{$thisfile}{'(main)'}{main}{'$compilesub'},
+    qr/&102\b/,
+    '$compilesub coderef called at line 102'
+);
+ok(
+    defined $xreftable{$thisfile}{'(main)'}{'(lexical)'}{'$curfile'},
+    '$curfile present in main program'
+);
+like(
+    $xreftable{$thisfile}{'(main)'}{'(lexical)'}{'$curfile'},
+    qr/\bi200\b/,
+    '$curfile introduced at line 200'
+);
+ok(
+    defined $xreftable{$thisfile}{'(main)'}{main}{'%xreftable'},
+    '$xreftable present in main program'
+);
+ok(
+    defined $xreftable{$thisfile}{'Testing::Xref::foo'}{main}{'%xreftable'},
+    '$xreftable used in subroutine bar'
+);
+is(
+    $xreftable{$thisfile}{'(main)'}{main}{'&use_ok'}, '&50',
+    'use_ok called at line 50'
+);
+is(
+    $xreftable{$thisfile}{'(definitions)'}{'Testing::Xref'}{'&foo'}, 's1001',
+    'subroutine foo defined at line 1001'
+);
+is(
+    $xreftable{$thisfile}{'(definitions)'}{'Testing::Xref'}{'&bar'}, 's1002',
+    'subroutine bar defined at line 1002'
+);
+is(
+    $xreftable{$thisfile}{'Testing::Xref::bar'}{'Testing::Xref'}{'&foo'},
+    '&1002', 'subroutine foo called at line 1002 by bar'
+);
+is(
+    $xreftable{$thisfile}{'Testing::Xref::foo'}{'Testing::Xref'}{'*FOO'},
+    '1001', 'glob FOO used in subroutine foo'
+);
+
+# End of tests.
+# Now some stuff to feed B::Xref
+
+# line 1000
+package Testing::Xref;
+sub foo { print FOO %::xreftable; }
+sub bar { print FOO foo; }