File Coverage

auto-dbg/auto-debug-module.pl
Criterion Covered Total %
statement 12 58 20.6
branch 0 48 0.0
condition 0 65 0.0
subroutine 4 8 50.0
pod n/a
total 16 179 8.9


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2 1     1   548 use strict;
  1         1  
  1         27  
3 1     1   5 use File::Path 'mkpath';
  1         1  
  1         51  
4 1     1   427 use File::Copy 'copy';
  1         2211  
  1         43  
5 1     1   6 use Config;
  1         1  
  1         2233  
6              
7             my $VERSION = '1.09'; # Changelog at end
8             die "Debugging cycle detected" # set to -1 to allow extra iteration
9             if ++$ENV{PERL_DEBUG_MCODE_CYCLE} > 1;
10              
11             my %opt;
12             $opt{$1} = shift while ($ARGV[0] || 0) =~ /^-([dq1OBU])$/;
13             if ($opt{1}) {
14             open STDERR, '>&STDOUT' or warn "can't redirect STDERR to STDOUT";
15             } else {
16             open STDOUT, '>&STDERR' or warn "can't redirect STDOUT to STDERR";
17             }
18              
19             my $bd = (my $bd0 = 'dbg-bld') . ($opt{O} || '');
20             @ARGV >= 1 or die <
21              
22             Usage:
23             $0 [-B] [-U] [-d] [-q] [-1] [-O] check-module [failing-script1 failing-script2 ...]
24              
25             A tool to simplify remote debugging of build problems for XSUB modules.
26             By default, output goes to STDERR (to pass through the test suite wrappers).
27              
28             If CHECK-MODULE is non-empty (and not 0) checks whether it may be
29             loaded (with -Mblib). If any problem is detected, outputs the MakeMaker
30             arguments (extracted from the generated Makefiles).
31              
32             If CHECK-MODULE is empty (or 0), or if FAILING-SCRIPTS are present,
33             rebuilds the current distribution with debugging (in subdirectory $bd),
34             and machine-code-debugs Perl crash when running each FAILING-SCRIPT.
35             Outputs as much info about the crash as it can massage from gdb, or
36             dbx, or lldb.
37              
38             Some minimal intelligence to avoid a flood of useless information is applied:
39             if CHECK-MODULE cannot be loaded (but there is no crash during loading), no
40             debugging for FAILING-SCRIPTs is done.
41              
42             Options: With -d, prefers dbx to gdb (DEFAULT: prefer gdb).
43             With -q and no FAILING-SCRIPTs, won't print anything unless a
44             failure of loading is detected.
45             With -1, all our output goes to STDOUT.
46             With -O, makes a non-debugging build.
47             With -B, builds in a subdirectory even if no debugger was found.
48             With -U will reuse the build directory if present.
49              
50             Assumptions:
51             Should be run in the root of a distribution, or its immediate subdir.
52             Running Makefile.PL with OPTIMIZE=-g builds debugging version.
53             (Actually, v1.00 starts to massage CFLAGS, LDFLAGS and DLLDFLAGS too.)
54             If FAILING-SCRIPTs are relative paths, they should be local w.r.t. the
55             root of the distribution.
56             gdb (or dbx, lldb) is fresh enough to understand the options we throw in.
57             Building in a subdirectory does not break a module (e.g., there is
58             no dependence on its position in its parent distribution, if any).
59              
60             Creates a subdirectory ./$bd0 or ./${bd0}O. Add them to `clean' in Makefile.PL
61             (add also the temporary files triggering running this script, if applicable).
62              
63             Version: $VERSION
64             EOP
65             $bd .= ($opt{O} || '');
66              
67             my ($chk_module) = (shift);
68              
69             sub report_Makefile ($) {
70 0     0     my($f, $in) = (shift, '');
71 0           print STDERR "# reporting $f header:\n# ==========================\n";
72 0 0         open M, "< $f" or die "Can't open $f";
73 0   0       ($in =~ /ARGV/ and print STDERR $in), $in = while defined $in and $in !~ /MakeMaker \s+ Parameters/xi;
      0        
74 0           $in = ;
75 0   0       $in = while defined $in and $in !~ /\S/;
76 0   0       print STDERR $in and $in = while defined $in and $in =~ /^#/;
      0        
77 0           close M;
78 0           print STDERR "# ==========================\n";
79             }
80              
81             # We assume that MANIFEST contains no filenames with spaces
82             chdir '..' or die "chdir ..: $!"
83             if not -f 'MANIFEST' and -f '../MANIFEST'; # we may be in ./t
84              
85             # Try to avoid debugging a code failing by some other reason than crashing.
86             # In principle, it is easier to do in the "trigger" code with proper BEGIN/END;
87             # just be extra careful, and recheck. (And we can be used standalone as well!)
88              
89             # There are 4 cases detected below, with !@ARGV thrown in, one covers 8 types.
90             my($skip_makefiles, $mod_load_out);
91             if ($chk_module) {
92             # Using blib may give a false positive (blib fails) unless distribution
93             # is already built; but the cost is small: just a useless rebuild+test
94             if (system $^X, q(-wle), q(use blib)) {
95             warn <
96              
97             Given that -Mblib fails, `perl Makefile.PL; make' was not run here yet...
98             I can't do any intelligent pre-flight testing now;
99              
100             EOW
101             die "Having no FAILING-SCRIPT makes no sense when -Mblib fails"
102             unless @ARGV;
103             warn <
104             ... so I just presume YOU know that machine-code debugging IS needed...
105              
106             EOW
107             $skip_makefiles = 1;
108             } else { #`
109             # The most common "perpendicular" problem is that a loader would not load DLL ==> no crash.
110             # Then there is no point in running machine code debugging; try to detect this:
111             my $mod_load = `$^X -wle "use blib; print(eval q(use $chk_module; 1) ? 123456789 : 987654321)" 2>&1`;
112             # Crashes ==> no "digits" output; DO debug. Do not debug if no crash, and no load
113             if ($mod_load =~ /987654321/) { # DLL does not load, no crash
114             $mod_load_out = `$^X -wle "use blib; use $chk_module" 2>&1`;
115             warn "Module $chk_module won't load: $mod_load_out";
116             @ARGV = (); # machine-code debugging won't help
117             } elsif ($mod_load =~ /123456789/) { # Loads OK
118             # a (suspected) failure has a chance to be helped by machine-code debug
119             ($opt{'q'} or warn(<
120              
121             Module loads without a problem. (No FAILING-SCRIPT, so I skip debugging step.)
122              
123             EOW
124             } # else: Crash during DLL load. Do debug
125             }
126             }
127             unless ($skip_makefiles) {
128             report_Makefile($_) for grep -f "$_.PL" && -f, map "$_/Makefile", '.', <*>;
129             }
130             exit 0 unless @ARGV or not $chk_module;
131              
132             my $dbxname = 'dbx';
133             my $gdb = `gdb --version` unless $opt{d};
134             my $dbx = `dbx -V -c quit` unless $gdb;
135             my $lldb = `lldb --version` unless $gdb or $dbx; # untested
136             $dbx = `dbxtool -V` and $dbxname = 'dbxtool' unless $gdb or $dbx or $lldb;
137              
138             sub find_candidates () {
139 0     0     my($sep, @cand) = quotemeta $Config{path_sep};
140 0   0       for my $dir (split m($sep), ($ENV{PATH} || '')) {
141 0           for my $f (<$dir/*>) {
142 0 0 0       push @cand, $f if $f =~ m{dbx|gdb|lldb}i and -x $f;
143             }
144             }
145 0 0         warn 'Possible candidates for debuggers: {{{'. join('}}} {{{', @cand), '}}}' if @cand;
146             }
147              
148             unless ($gdb or $dbx or $lldb) {
149             find_candidates() unless $gdb = `gdb --version`;
150             }
151              
152             sub report_no_debugger () {
153 0 0 0 0     die "Can't find gdb or dbx or lldb" unless defined $gdb or defined $dbx or defined $lldb;
      0        
154 0 0 0       die "Can't parse output of gdb --version: {{{$gdb}}}"
      0        
155             unless $dbx or $lldb or $gdb =~ /\b GDB \b | \b Copyright \b .* \b Free \s+ Software \b/x;
156 0 0 0       die "Can't parse output of `dbx -V -c quit': {{{$dbx}}}"
      0        
      0        
157             unless $gdb or $lldb or $dbxname eq 'dbxtool' or $dbx =~ /\b dbx \s+ debugger \b/xi;
158 0 0 0       warn "Can't parse output of `dbxtool -V': {{{$dbx}}}"
      0        
      0        
159             unless $gdb or $lldb or $dbxname eq 'dbx' or $dbx =~ /\b dbx \s+ debugger \b/xi;
160 0 0 0       die "Can't parse output of lldb --version: {{{$lldb}}}"
      0        
161             unless $dbx or $gdb or $lldb =~ /\b lldb-\S*\d/x;
162             }
163              
164             $@ = '';
165             my $postpone = ( eval {report_no_debugger(); 1 } ? '' : "$@" );
166             if ($opt{B}) {
167             warn "No debugger found. Nevertheless, I build a new version per -B switch." if $postpone;
168             } else {
169             die $postpone if $postpone;
170             }
171              
172             my $build_was_OK = -f "$bd/autodebug-make-ok";
173             die "Directory $bd exist; won't overwrite" if -d $bd and not ($opt{U} and $build_was_OK);
174             mkdir $bd or die "mkdir $bd: $!" unless -d $bd;
175             chdir $bd or die "chdir $bd: $!";
176              
177             sub do_subdir_build () {
178 0 0   0     open MF, '../MANIFEST' or die "Can't read MANIFEST: $!";
179 0           while () {
180 0 0         next unless /^\S/;
181 0           s/\s.*//;
182 0           my ($f, $d) = m[^((.*/)?.*)];
183 0 0 0       -d $d or mkpath $d if defined $d; # croak()s itself
184 0 0         copy "../$f", $f or die "copy `../$f' to `$f' (inside $bd): $!";
185             }
186 0 0         close MF or die "Can't close MANIFEST: $!";
187              
188 0           my(@extraflags, $more, $subst) = 'OPTIMIZE=-g';
189             # Work around bugs in Config: 'ccflags' may contain (parts???) of 'optimize'.
190 0 0 0       if ($opt{O}) { # Do not change debugging
    0          
    0          
191 0           @extraflags = ();
192             } elsif ($Config{ccflags} =~ s/(?
193             # e.g., Strawberry Perl
194 0           $subst++;
195             } elsif ($Config{gccversion} or $Config{cc} =~ /\b\w?cc\b/i) { # assume cc-flavor
196             # http://www.cpantesters.org/cpan/report/ef2ee424-1c8e-11e6-b928-8293027c4940
197             # http://www.cpantesters.org/cpan/report/4837b230-1d9d-11e6-91cb-6b7bc172c7fc
198             # Extra check:
199 0 0         $more++ if $Config{optimize} =~ /(?
200             }
201 0 0 0       if ($more or $subst) {
202 0           my $FL;
203 0 0         $subst++ if ($FL = $Config{ccflags}) =~ s/(?
204 0 0         push @extraflags, qq(CCFLAGS=$FL) if $subst;
205 0           for my $f (qw(ldflags lddlflags)) {
206             push @extraflags, qq(\U$f\E=$FL)
207 0 0         if ($FL = $Config{$f}) =~ s/(?
208             }
209             }
210              
211 0 0         system $^X, 'Makefile.PL', @extraflags and die "system(Makefile.PL @extraflags): rc=$?";
212 0           my $make = $Config{make};
213 0 0         $make = 'make' unless defined $make;
214 0 0         system $make and die "system($make): rc=$?";
215 0           { open my $f, '>', 'autodebug-make-ok'; } # Leave a footprint of a successful build
  0            
216 0           warn "Renaming Makefile.PL to orig-Makefile.PL\n\t(to avoid recursive calls from Makefile.PL in the parent directory)";
217 0           rename 'Makefile.PL', 'orig-Makefile.PL'; # ignore error
218             }
219              
220             do_subdir_build() unless -f 'autodebug-make-ok';
221              
222             die $postpone if $postpone; # Reached without a debugger only with -B
223              
224             my $p = ($^X =~ m([\\/]) ? $^X : `which perl`) || $^X;
225             chomp $p unless $p eq $^X;
226             my(@cmd, $ver, $ver_done, $cand_done, $dscript);
227              
228             for my $script (@ARGV) {
229             $script = "../$script" if not -f $script and -f "../$script";
230             if ($gdb) {
231             $ver = $gdb;
232             my $gdb_in = 'gdb-in';
233             open TT, ">$gdb_in" or die "Can't open $gdb_in for write: $!";
234             # bt full: include local vars (not in 5.0; is in 6.5; is in 6.1, but crashes on 6.3:
235             # http://www.cpantesters.org/cpan/report/2fffc390-afd2-11df-834b-ae20f5ac70d3)
236             # disas /m : with source lines (FULL function?!) (not in 6.5; is in 7.0.1)
237             # XXX all-registers may take 6K on amd64; maybe put at end?
238             # sharedlibrary: present on 7.3.1 (2011)
239             my $proc = (-d "/proc/$$" ? <
240             info proc mapping
241             echo \\n=====================================\\n\\n
242             EOP
243             my $extra = '';
244             $extra .= <
245             info w32 thread-information-block
246             echo \\n=====================================\\n\\n
247             EOE
248             print TT ($dscript = <
249             run -Mblib $script
250             echo \\n=====================================\\n\\n
251             bt
252             echo \\n=====================================\\n\\n
253             info all-registers
254             echo \\n=====================================\\n\\n
255             disassemble
256             echo \\n=====================================\\n\\n
257             bt 5 full
258             echo \\n=====================================\\n\\n
259             disassemble /m
260             echo \\n=====================================\\n\\n
261             ${extra}info sharedlibrary
262             echo \\n=====================================\\n\\n
263             ${proc}quit
264             EOP
265             close TT or die "Can't close $gdb_in for write: $!";
266              
267             #open STDIN, $gdb_in or die "cannot open STDIN from $gdb_in: $!";
268             @cmd = (qw(gdb -batch), "--command=$gdb_in", $p);
269             } elsif ($lldb) {
270             $ver = $lldb;
271             warn <
272              
273             !!!! I seem to have found LLDB, but extra work may be needed. !!!
274             !!!! If you see something like this: !!!
275              
276             (lldb) run -Mblib t/000_load-problem.t
277             error: process exited with status -1 (developer mode is not enabled on this machine and this is a non-interactive debug session.)
278              
279             !!!! Inspect the following recipe !!!
280             !!!! from https://developer.apple.com/forums/thread/678032 !!!
281              
282             sudo DevToolsSecurity -enable
283             Developer mode is now enabled.
284              
285             !!!! This was Step 1; it should lead to the following error: !!!
286              
287             error: process exited with status -1 (this is a non-interactive debug session, cannot get permission to debug processes.)
288              
289             !!!! You also need Step 2 (security implications???): !!!
290              
291             sudo dseditgroup -o edit -a UUU -t user _developer
292             ### replace UUU with your user name.
293              
294             !!!! I'm crossing my virtual fingers and proceed. !!!
295              
296             EOW
297             my $lldb_in = 'lldb-in';
298             open TT, ">$lldb_in" or die "Can't open $lldb_in for write: $!";
299             # bt full: include local vars (not in 5.0; is in 6.5; is in 6.1, but crashes on 6.3:
300             # http://www.cpantesters.org/cpan/report/2fffc390-afd2-11df-834b-ae20f5ac70d3)
301             # disas /m : with source lines (FULL function?!) (not in 6.5; is in 7.0.1)
302             # XXX all-registers may take 6K on amd64; maybe put at end?
303             # sharedlibrary: present on 7.3.1 (2011)
304             my $proc = (-d "/proc/$$" ? <
305             script print "??? info proc mapping"
306             script print "\\n=====================================\\n"
307             EOP
308             my $extra = '';
309             $extra .= <
310             script print "??? info w32 thread-information-block"
311             script print "\\n=====================================\\n"
312             EOE
313             print TT ($dscript = <
314             run -Mblib $script
315             script print "\\n=====================================\\n"
316             bt
317             script print "\\n=====================================\\n"
318             frame variable
319             script print "\\n=====================================\\n"
320             register read
321             script print "\\n=====================================\\n"
322             disassemble --frame
323             script print "\\n=====================================\\n"
324             bt 5 full
325             script print "\\n=====================================\\n"
326             disassemble --frame --mixed
327             script print "\\n=====================================\\n"
328             image list
329             script print "\\n=====================================\\n"
330             image dump sections
331             script print "\\n=====================================\\n"
332             register read --all
333             script print "\\n=====================================\\n"
334             ${extra}${proc}quit
335             EOP
336             close TT or die "Can't close $lldb_in for write: $!";
337              
338             #open STDIN, $gdb_in or die "cannot open STDIN from $gdb_in: $!";
339             @cmd = (qw(lldb -batch -s), $lldb_in, $p);
340             } else { # Assume $script has no spaces or metachars
341             # Linux: /proc/$proc/maps has the text map
342             # Solaris: /proc/$proc/map & /proc/$proc/rmap: binary used/reserved
343             # /usr/proc/bin/pmap $proc (>= 2.5) needs -F (force) inside dbx
344             $ver = $dbx;
345             # where -v # Verbose traceback (include function args and line info)
346             # dump # Print all variables local to the current procedure
347             # regs [-f] [-F] # Print value of registers (-f/-F: SPARC only)
348             # list - # List previous lines (next with +)
349             # -i or -instr # Intermix source lines and assembly code
350             @cmd = ($dbxname, qw(-c), # We do not do non-integer registers...
351             qq(run -Mblib $script; echo; echo =================================; echo; where -v; echo; echo =================================; echo; dump; echo; echo =================================; echo; regs; echo; echo =================================; echo; list -i +1; echo; echo =================================; echo; list -i -10; echo; echo =================================; echo; echo ============== up 1:; up; dump; echo; echo ============== up 2:; up; dump; echo; echo ============== up 3:; up; dump; echo; echo ============== up 4:; up; dump; echo ==============; /usr/proc/bin/pmap -F \$proc; quit),
352             $p);
353             }
354             warn "\nDebugger's version: $ver\n" unless $ver_done++;
355             warn 'Running {{{', join('}}} {{{', @cmd), "}}}\n\n";
356             if (system @cmd) {
357             warn "Running @cmd: rc=$?", ($dscript ? "\n========= script begin\n$dscript\n========= script end\n\t" : '');
358             find_candidates();
359             die "I stop here,"
360             }
361             }
362             1;
363              
364             __END__