| Subject: | [PATCH] Win32 fixes + some improvements and tests |
Module-Info-0.12, perl, v5.6.1 MSWin32-x86-multi-thread
(ActivePerl 628), Win2k.
there were various failures in the test suite, I fixed them by more cut'n'paste from B::Deparse; added features are:
recognize require inside subs
do not crash on "require $foo";
All tests still pass on a stock Debian 3.0/x86.
Regards
Mattia
diff -r -N -u -2 Module-Info-0.12.orig/MANIFEST Module-Info-0.12/MANIFEST
--- Module-Info-0.12.orig/MANIFEST Sun Feb 3 01:34:30 2002
+++ Module-Info-0.12/MANIFEST Mon Sep 16 22:07:44 2002
@@ -7,4 +7,5 @@
lib/Module/Info.pm
t/Module-Info.t
+t/lib/Bar.pm
t/lib/Foo.pm
t/lib/Test/Builder.pm
diff -r -N -u -2 Module-Info-0.12.orig/lib/B/Module/Info.pm Module-Info-0.12/lib/B/Module/Info.pm
--- Module-Info-0.12.orig/lib/B/Module/Info.pm Sun Feb 3 01:40:48 2002
+++ Module-Info-0.12/lib/B/Module/Info.pm Mon Sep 16 21:56:52 2002
@@ -8,4 +8,7 @@
@B::Utils::bad_stashes = qw(); # give us everything.
+my $the_file = $0; # when walking all subroutines, you need to skip
+ # the ones in other modules
+
sub state_change {
return opgrep {name => [qw(nextstate dbstate setstate)]}, @_
@@ -31,4 +34,21 @@
}
+
+=head2 roots_cv_pairs
+
+Returns a list of pairs, each containing a root with the relative
+B::CV object; this list includes B::main_root/cv.
+
+=cut
+
+sub roots_cv_pairs {
+ my %roots = filtered_roots;
+ my @roots = ( [ B::main_root, B::main_cv ],
+ map { [ $roots{$_},
+ B::svref_2object(\&{$_}) ] }
+ keys %roots );
+}
+
+
my %modes = (
packages => sub {
@@ -51,4 +71,9 @@
local $CurCV = $begin_cv;
+ next unless $begin_cv->FILE eq $the_file;
+ # cheat otherwise show_require guard prevents display
+ local $B::Utils::file = $begin_cv->FILE;
+ local $B::Utils::line = $begin_cv->START->line;
+
my $lineseq = $root->first;
next if $lineseq->name ne 'lineseq';
@@ -64,5 +89,7 @@
}
else {
- $module = const(const_sv($req_op->first));
+ # if it is not bare it can't be an "use"
+ show_require($req_op);
+ next;
}
@@ -70,16 +97,21 @@
$begin_cv->FILE,
$begin_cv->START->line;
-
}
- walkoptree_filtered(B::main_root,
- \&is_require,
- \&show_require,
- );
+ {
+ foreach my $p ( roots_cv_pairs ) {
+ local $CurCV = $p->[1];
+ walkoptree_filtered($p->[0],
+ \&is_require,
+ \&show_require,
+ );
+ }
+ }
},
subs_called => sub {
my %roots = filtered_roots;
- foreach my $op (B::main_root, values %roots) {
- walkoptree_filtered($op,
+ foreach my $p ( roots_cv_pairs ) {
+ local $CurCV = $p->[1];
+ walkoptree_filtered($p->[0],
\&sub_call,
\&sub_check );
@@ -91,5 +123,5 @@
sub const_sv {
my $op = shift;
- my $sv = $op->sv;
+ my $sv = $op->sv if $op->can('sv');
# the constant could be in the pad (under useithreads)
$sv = padval($op->targ) unless $$sv;
@@ -97,4 +129,11 @@
}
+# Don't do this for regexen
+sub unback {
+ my($str) = @_;
+ $str =~ s/\\/\\\\/g;
+ return $str;
+}
+
sub const {
my $sv = shift;
@@ -178,4 +217,5 @@
sub show_require {
+ return unless $B::Utils::file eq $the_file;
my($op) = shift;
@@ -196,10 +236,10 @@
}
- my $sv = $kid->sv;
- $name = $sv->isa("B::PV") ? $sv->PV :
- $sv->isa("B::NV") ? $sv->NV
- : $sv->IV;
-
- }
+ my $sv = const_sv($kid);
+ return unless defined $sv && !$sv->isa('B::NULL');
+ $name = $sv->isa("B::PV") ? $sv->PV : '';
+ $name ||= $sv->isa("B::NV") ? $sv->NV : 0;
+ $name ||= $sv->IV;
+ }
else {
$name = "";
@@ -252,6 +292,7 @@
my($name_op) = grep($_->name eq 'gv', @kids);
if( $name_op ) {
+ my $gv = gv_or_padgv($name_op);
printf "function call to %s at %s line %d\n",
- $name_op->gv->NAME, $B::Utils::file, $B::Utils::line;
+ $gv->NAME, $B::Utils::file, $B::Utils::line;
}
else {
@@ -259,5 +300,17 @@
$B::Utils::file, $B::Utils::line;
}
- }
+ }
+}
+
+
+sub gv_or_padgv {
+# my $self = shift;
+ my $op = shift;
+ if ($op->isa("B::PADOP")) {
+ return padval($op->padix);
+ }
+ else { # class($op) eq "SVOP"
+ return $op->gv;
+ }
}
@@ -269,5 +322,5 @@
my($classop) = $kids[1];
if( $classop->name eq 'const' ) {
- $class = $classop->sv->PV;
+ $class = const_sv($classop)->PV;
}
diff -r -N -u -2 Module-Info-0.12.orig/t/Module-Info.t Module-Info-0.12/t/Module-Info.t
--- Module-Info-0.12.orig/t/Module-Info.t Sun Feb 3 01:49:04 2002
+++ Module-Info-0.12/t/Module-Info.t Mon Sep 16 21:55:06 2002
@@ -139,5 +139,5 @@
my %subs = $module->subroutines;
- is( keys %subs, 1, 'Found one subroutine' );
+ is( keys %subs, 2, 'Found two subroutine' );
ok( exists $subs{'Foo::wibble'}, ' its right' );
@@ -148,7 +148,7 @@
my @mods = $module->modules_used;
- is( @mods, 5, 'modules_used' );
+ is( @mods, 7, 'modules_used' );
is_deeply( [sort @mods],
- [sort qw(strict vars Exporter t/lib/Foo.pm lib)] );
+ [sort qw(strict vars Carp Exporter t/lib/Bar.pm t/lib/Foo.pm lib)] );
$module->name('Foo');
@@ -218,5 +218,11 @@
type => 'object method',
name => 'wibble'
- }
+ },
+ {
+ line => 51,
+ class => undef,
+ type => 'function',
+ name => 'croak'
+ },
);
is_deeply(\@calls, \@expected_calls, 'subroutines_called');
diff -r -N -u -2 Module-Info-0.12.orig/t/lib/Bar.pm Module-Info-0.12/t/lib/Bar.pm
--- Module-Info-0.12.orig/t/lib/Bar.pm Thu Jan 1 01:00:00 1970
+++ Module-Info-0.12/t/lib/Bar.pm Mon Sep 16 21:31:38 2002
@@ -0,0 +1,14 @@
+package Bar;
+
+use Cwd;
+
+BEGIN {
+ cwd();
+}
+
+sub my_croak {
+ require Carp;
+ Carp::croak(cwd, @_);
+}
+
+1;
diff -r -N -u -2 Module-Info-0.12.orig/t/lib/Foo.pm Module-Info-0.12/t/lib/Foo.pm
--- Module-Info-0.12.orig/t/lib/Foo.pm Sun Feb 3 00:56:10 2002
+++ Module-Info-0.12/t/lib/Foo.pm Mon Sep 16 21:55:50 2002
@@ -46,2 +46,14 @@
eval "require Text::Soundex";
+
+sub croak {
+ require Carp;
+ Carp::croak(@_);
+}
+
+BEGIN {
+ require 't/lib/Bar.pm';
+}
+
+my $mod = 't/lib/Bar.pm';
+require $mod;