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

#!/usr/bin/perl -w
use strict;
use File::Path 'mkpath';
use File::Copy 'copy';
use Config;

my $VERSION = '1.10a';			# Changelog at end
die "Debugging cycle detected"		# set to -1 to allow extra iteration
  if ++$ENV{PERL_DEBUG_MCODE_CYCLE} > 1;

my(@ARGVi, %opt) = @ARGV;
$opt{$1} = shift while ($ARGV[0] || 0) =~ /^-([dq1OBU])$/;
if ($opt{1}) {
  open STDERR, '>&STDOUT' or warn "can't redirect STDERR to STDOUT";
} else {
  open STDOUT, '>&STDERR' or warn "can't redirect STDOUT to STDERR";
}

my $bd = (my $bd0 = 'dbg-bld') . ($opt{O} || '');
@ARGV >= 1 or die <

Usage:
 $0 [-B] [-U] [-d] [-q] [-1] [-O] check-module [failing-script1 failing-script2 ...]

A tool to simplify remote debugging of build problems for XSUB modules.
By default, output goes to STDERR (to pass through the test suite wrappers).

If CHECK-MODULE is non-empty (and not 0) checks whether it may be
loaded (with -Mblib).  If any problem is detected, outputs the MakeMaker
arguments (extracted from the generated Makefiles).

If CHECK-MODULE is empty (or 0), or if FAILING-SCRIPTS are present,
rebuilds the current distribution with debugging (in subdirectory $bd),
and machine-code-debugs Perl crash when running each FAILING-SCRIPT.
Outputs as much info about the crash as it can massage from gdb, or
dbx, or lldb.

Some minimal intelligence to avoid a flood of useless information is applied:
if CHECK-MODULE cannot be loaded (but there is no crash during loading), no
debugging for FAILING-SCRIPTs is done.

Options:	With -d, prefers dbx to gdb (DEFAULT: prefer gdb).
		With -q and no FAILING-SCRIPTs, won't print anything unless a
			failure of loading is detected.
		With -1, all our output goes to STDOUT.
		With -O, makes a non-debugging build.
		With -B, builds in a subdirectory even if no debugger was found.
		With -U will reuse the build directory if present.

Assumptions:
  Should be run in the root of a distribution, or its immediate subdir.
  Running Makefile.PL with OPTIMIZE=-g builds debugging version.
	(Actually, v1.00 starts to massage CFLAGS, LDFLAGS and DLLDFLAGS too.)
  If FAILING-SCRIPTs are relative paths, they should be local w.r.t. the
	root of the distribution.
  gdb (or dbx, lldb) is fresh enough to understand the options we throw in.
  Building in a subdirectory does not break a module (e.g., there is
	no dependence on its position in its parent distribution, if any).

Creates a subdirectory ./$bd0 or  ./${bd0}O.  Add them to `clean' in Makefile.PL
(add also the temporary files triggering running this script, if applicable), like
./had-tst-run-.

			Version: $VERSION
EOP
$bd .= ($opt{O} || '');

my ($chk_module) = (shift);

sub report_Makefile ($) {
  my($f, $in) = (shift, '');
  print STDERR "# reporting $f header:\n# ==========================\n";
  open M, "< $f" or die "Can't open $f";
  ($in =~ /ARGV/ and print STDERR $in), $in =  while defined $in and $in !~ /MakeMaker \s+ Parameters/xi;
  $in = ;
  $in =  while defined $in and $in !~ /\S/;
  print STDERR $in and $in =  while defined $in and $in =~ /^#/;
  close M;
  print STDERR "# ==========================\n";
}

# We assume that MANIFEST contains no filenames with spaces
chdir '..' or die "chdir ..: $!"
  if not -f 'MANIFEST' and -f '../MANIFEST';	# we may be in ./t

# Try to avoid debugging a code failing by some other reason than crashing.
# In principle, it is easier to do in the "trigger" code with proper BEGIN/END;
# just be extra careful, and recheck. (And we can be used standalone as well!)

warn <

     >>>	Checking whether I need to auto-debug (v=$VERSION): $0 @ARGVi

EOW
# There are 4 cases detected below, with !@ARGV thrown in, one covers 8 types.
my($skip_makefiles, $mod_load_out);
if ($chk_module) {
  # Using blib may give a false positive (blib fails) unless distribution
  # is already built; but the cost is small: just a useless rebuild+test
  if (system $^X, q(-wle), q(use blib)) {
    warn <

  Given that -Mblib fails, `perl Makefile.PL; make' was not run here yet...
  I can't do any intelligent pre-flight testing now;

EOW
    die "Having no FAILING-SCRIPT makes no sense when -Mblib fails"
      unless @ARGV;
    warn <
  ... so I just presume YOU know that machine-code debugging IS needed...

EOW
    $skip_makefiles = 1;
  } else {	#`
    # The most common "perpendicular" problem is that a loader would not load DLL ==> no crash.
    # Then there is no point in running machine code debugging; try to detect this:
    my $mod_load = `$^X -wle "use blib; print(eval q(use $chk_module; 1) ? 123456789 : 987654321)" 2>&1`;
    # Crashes ==> no "digits" output; DO debug.  Do not debug if no crash, and no load
    if ($mod_load =~ /987654321/) { # DLL does not load, no crash
      $mod_load_out = `$^X -wle "use blib; use $chk_module" 2>&1`;
      warn "Module $chk_module won't load: $mod_load_out";
      @ARGV = ();		# machine-code debugging won't help
    } elsif ($mod_load =~ /123456789/) { # Loads OK
      # a (suspected) failure has a chance to be helped by machine-code debug
      ($opt{'q'} or warn(<

Module loads without a problem.  (No FAILING-SCRIPT, so I skip debugging step.)

EOW
    }				# else: Crash during DLL load.  Do debug
  }
}
unless ($skip_makefiles) {
  report_Makefile($_) for grep -f "$_.PL" && -f, map "$_/Makefile", '.', <*>;
}
exit 0 unless @ARGV or not $chk_module;

my $dbxname = 'dbx';
my $gdb = `gdb --version` unless $opt{d};
my $dbx = `dbx -V -c quit` unless $gdb;
my $lldb = `lldb --version` unless $gdb or $dbx;	# untested
$dbx = `dbxtool -V` and $dbxname = 'dbxtool' unless $gdb or $dbx or $lldb;

sub find_candidates () {
  my($sep, @cand) = quotemeta $Config{path_sep};
  for my $dir (split m($sep), ($ENV{PATH} || '')) {
    for my $f (<$dir/*>) {
      push @cand, $f if $f =~ m{dbx|gdb|lldb}i and -x $f;
    }
  }
  warn 'Possible candidates for debuggers: {{{'. join('}}} {{{', @cand), '}}}' if @cand;
}

unless ($gdb or $dbx or $lldb) {
  find_candidates() unless $gdb = `gdb --version`;
}

sub report_no_debugger () {
  die "Can't find gdb or dbx or lldb" unless defined $gdb or defined $dbx or defined $lldb;
  die "Can't parse output of gdb --version: {{{$gdb}}}"
    unless $dbx or $lldb or $gdb =~ /\b GDB \b | \b Copyright \b .* \b Free \s+ Software \b/x;
  die "Can't parse output of `dbx -V -c quit': {{{$dbx}}}"
    unless $gdb or $lldb or $dbxname eq 'dbxtool' or $dbx =~ /\b dbx \s+ debugger \b/xi;
  warn "Can't parse output of `dbxtool -V': {{{$dbx}}}"
    unless $gdb or $lldb or $dbxname eq 'dbx' or $dbx =~ /\b dbx \s+ debugger \b/xi;
  die "Can't parse output of lldb --version: {{{$lldb}}}"
    unless $dbx or $gdb or $lldb =~ /\b lldb-\S*\d/x;
}

$@ = '';
my $postpone = ( eval {report_no_debugger(); 1 } ? '' : "$@" );
if ($opt{B}) {
  warn "No debugger found.  Nevertheless, I build a new version per -B switch." if $postpone;
} else {
  die $postpone if $postpone;
}

my $build_was_OK = -f "$bd/autodebug-make-ok";
if (-d $bd) {
  if ($build_was_OK) {
    die "Directory $bd exists; won't overwrite (give option -U to override)" unless $opt{U};
    warn <
Directory $bd exists with a good build; reusing per option -U.

	(If you edited something in the "top" directory "in between",
	 you need to copy changes to the directory $bd manually!!!)

EOW
  } else {
    warn "Directory $bd exists, but the build was not successful; retrying...";
  }
}
mkdir $bd or die "mkdir $bd: $!" unless -d $bd;
chdir $bd or die "chdir $bd: $!";

sub do_subdir_build () {
  open MF, '../MANIFEST' or die "Can't read MANIFEST: $!";
  while () {
    next unless /^\S/;
    s/\s.*//;
    my ($f, $d) = m[^((.*/)?.*)];
    -d $d or mkpath $d if defined $d;	# croak()s itself
    copy "../$f", $f or die "copy `../$f' to `$f' (inside $bd): $!";
  }
  close MF or die "Can't close MANIFEST: $!";

  my(@extraflags, $more, $subst) = 'OPTIMIZE=-g';
  # Work around bugs in Config: 'ccflags' may contain (parts???) of 'optimize'.
  if ($opt{O}) {			# Do not change debugging
    @extraflags = ();
  } elsif ($Config{ccflags} =~ s/(?
    # e.g., Strawberry Perl
    $subst++;
  } elsif ($Config{gccversion} or $Config{cc} =~ /\b\w?cc\b/i) {	# assume cc-flavor
    #     http://www.cpantesters.org/cpan/report/ef2ee424-1c8e-11e6-b928-8293027c4940
    #     http://www.cpantesters.org/cpan/report/4837b230-1d9d-11e6-91cb-6b7bc172c7fc
    # Extra check:
    $more++ if $Config{optimize} =~ /(?
  }
  if ($more or $subst) {
    my $FL;
    $subst++ if ($FL = $Config{ccflags}) =~ s/(?
    push @extraflags, qq(CCFLAGS=$FL) if $subst;
    for my $f (qw(ldflags lddlflags)) {
      push @extraflags, qq(\U$f\E=$FL)
        if ($FL = $Config{$f}) =~ s/(?
    }
  }

  system $^X, 'Makefile.PL', @extraflags and die "system(Makefile.PL @extraflags): rc=$?";
  my $make = $Config{make};
  $make = 'make' unless defined $make;
  system $make and die "system($make): rc=$?";
  { open my $f, '>', 'autodebug-make-ok'; }	# Leave a footprint of a successful build
  warn "Renaming Makefile.PL to orig-Makefile.PL\n\t(to avoid recursive calls from Makefile.PL in the parent directory)";
  rename 'Makefile.PL', 'orig-Makefile.PL'; # ignore error
}

do_subdir_build() unless -f 'autodebug-make-ok';

die $postpone if $postpone;	# Reached without a debugger only with -B

my $p = ($^X =~ m([\\/]) ? $^X : `which perl`) || $^X;
chomp $p unless $p eq $^X;
my(@cmd, $ver, $ver_done, $cand_done, $dscript, $dbbatchname);
my $leak_ok = 1 eq ($ENV{AUTO_DBG_LOADMAPS} || 0);

for my $script (@ARGV) {
  $script = "../$script" if not -f $script and -f "../$script";
  if ($gdb) {
    $ver = $gdb;
    my $gdb_in = $dbbatchname = 'gdb-in';
    # bt full: include local vars (not in 5.0; is in 6.5; is in 6.1, but crashes on 6.3:
	# http://www.cpantesters.org/cpan/report/2fffc390-afd2-11df-834b-ae20f5ac70d3)
    # disas /m : with source lines (FULL function?!) (not in 6.5; is in 7.0.1)
    # XXX all-registers may take 6K on amd64; maybe put at end?
    # sharedlibrary: present on 7.3.1 (2011)
    my $graceful_degradation;
    my $tst_python = q[gdb -nx -batch -ex "python print(' py' + 'thon-ok ')"];
    my $out = `$tst_python 2>&1`;
    if ($out =~ /\bpython-ok\s*/) {
      $graceful_degradation = <<'EOP';
python
import os

def safe(*cmds):
    for cmd in cmds:
        try:
            gdb.execute(cmd)
            return
        except gdb.error as e:
            print(f"[SKIPPED] {cmd}: {e}")
    print("[FAILED] No fallback command succeeded.")

safe("set confirm off")

safe("bt full 5", "bt 5 full", "bt full", "bt")
print("\n=====================================\n\n")

safe("disassemble /m")
print("\n=====================================\n\n")

safe("info proc status")
print("\n=====================================\n\n")

if os.getenv("AUTO_DBG_LOADMAPS") != "1":
    print("[INFO] Memory maps disabled to reduce attack surface; enable by AUTO_DBG_LOADMAPS=1.")
    print("\n=====================================\n\n")
else:
    safe("info sharedlibrary", "info shared")
    print("\n=====================================\n\n")

    safe("info proc mapping")
    print("\n=====================================\n\n")

    safe("info files")
    print("\n=====================================\n\n")


safe("info w32 thread-information-block")
print("\n=====================================\n\n")

safe("info w32 exception")
print("\n=====================================\n\n")

safe("info w32 ldt")
print("\n=====================================\n\n")

gdb.execute("quit")
end
EOP
    } else {
      warn <
Seems gdb is not supporting embedded-Python.  Tested by <<<$tst_python 2>&1>>> ==>
$out

  I'll try using GDB commands directly.
  Since GDB interpreter isn't backward-compatible, some commands may
  fail - and then this would ruin the rest of my script!

EOW
      my $proc = (-d "/proc/$$" ? <
info proc mapping
echo \\n=====================================\\n\\n
EOP
      my $extra = '';
      $extra .= <
info w32 thread-information-block
echo \\n=====================================\\n\\n
EOE
      $graceful_degradation = <
disassemble
echo \\n=====================================\\n\\n
bt 5 full
echo \\n=====================================\\n\\n
disassemble /m
echo \\n=====================================\\n\\n
${extra}info sharedlibrary
echo \\n=====================================\\n\\n
${proc}quit
EOP
    }
    $dscript = <
run -Mblib $script
echo \\n=====================================\\n\\n
bt
echo \\n=====================================\\n\\n
info all-registers
echo \\n=====================================\\n\\n
$graceful_degradation
EOP

      # One could also consider
      # info frame; info threads; thread apply all bt full 5; info target

    #open STDIN, $gdb_in or die "cannot open STDIN from $gdb_in: $!";
    @cmd = (qw(gdb -batch), "--command=$gdb_in", $p);
  } elsif ($lldb) {
    $ver = $lldb;
    my $Python = `lldb -b -o 'script print(" pyth" + "on-ok ")' -o 'quit' 2>&1`;
    warn <

!!!!  I seem to have found LLDB, but extra work may be needed.  !!!
!!!!  If you see something like this:                           !!!

  (lldb) run -Mblib t/000_load-problem.t
  error: process exited with status -1 (developer mode is not enabled on this machine and this is a non-interactive debug session.)

!!!!  Inspect the following recipe                              !!!
!!!!     from https://developer.apple.com/forums/thread/678032  !!!

  	sudo DevToolsSecurity -enable
	Developer mode is now enabled.

!!!!  This was Step 1; it should lead to the following error:   !!!

  error: process exited with status -1 (this is a non-interactive debug session, cannot get permission to debug processes.)

!!!!  You also need Step 2 (security implications???):          !!!

	sudo dseditgroup -o edit -a UUU -t user _developer
	###   replace UUU with your user name.

!!!!  I'm crossing my virtual fingers and proceed.              !!!

EOW
    my $lldb_in = $dbbatchname = 'lldb-in';
    # bt full: include local vars (not in 5.0; is in 6.5; is in 6.1, but crashes on 6.3:
	# http://www.cpantesters.org/cpan/report/2fffc390-afd2-11df-834b-ae20f5ac70d3)
    # disas /m : with source lines (FULL function?!) (not in 6.5; is in 7.0.1)
    # XXX all-registers may take 6K on amd64; maybe put at end?
    # sharedlibrary: present on 7.3.1 (2011)
    my $proc = $leak_ok && <<'EOP';
image list
script print "\\n=====================================\\n"

image dump sections
script print "\n=====================================\n"

## script print "??? info proc mapping"
script
import lldb
process = lldb.debugger.GetSelectedTarget().process
count = process.GetNumMemoryRegions()
for i in range(count):
    region = lldb.SBMemoryRegionInfo()
    process.GetMemoryRegionAtIndex(i, region)
    print(region)
end

script print "\n=====================================\n"
EOP
    my $extra = '';
    $extra .= <
script print "??? info w32 thread-information-block"
script print "\\n=====================================\\n"
EOE
    $dscript = <
run -Mblib $script
script print "\\n=====================================\\n"
bt
script print "\\n=====================================\\n"
frame variable
script print "\\n=====================================\\n"
register read
script print "\\n=====================================\\n"
disassemble --frame
script print "\\n=====================================\\n"
bt --count 5 --verbose		# bt 5 full
script print "\\n=====================================\\n"
disassemble --frame --mixed
script print "\\n=====================================\\n"
register read --all
script print "\\n=====================================\\n"
${extra}${proc}quit
EOP

    #open STDIN, $gdb_in or die "cannot open STDIN from $gdb_in: $!";
    @cmd = (qw(lldb -batch -s), $lldb_in, $p);
  } else {			# Assume $script has no spaces or metachars
	# Linux: /proc/$proc/maps has the text map
	# Solaris: /proc/$proc/map & /proc/$proc/rmap: binary used/reserved
	#   /usr/proc/bin/pmap $proc (>= 2.5) needs -F (force) inside dbx
    $ver = $dbx;
    # where -v		# Verbose traceback (include function args and line info)
    # dump                  # Print all variables local to the current procedure
    # regs [-f] [-F]        # Print value of registers (-f/-F: SPARC only)
    # list -             # List previous  lines (next with +)
    #   -i or -instr        # Intermix source lines and assembly code
    my $pmap = $leak_ok && '/usr/proc/bin/pmap -F \$proc;';
    @cmd = ($dbxname, qw(-c),		# We do not do non-integer registers...
	    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 ==============; $pmap quit),
	    $p);
  }
  if (defined $dbbatchname) {
    open TT, ">$dbbatchname" or die "Can't open $dbbatchname for write: $!";
    print TT $dscript;
    close TT or die "Can't close $dbbatchname for write: $!";
    warn "\n========= $dbbatchname script begin\n\n$dscript\n\n========= script end\n\n";
  }
  warn "\nDebugger's version: $ver\n" unless $ver_done++;
  warn 'Running {{{', join('}}} {{{', @cmd), "}}}\n\n";
  if (system @cmd) {
    warn "Running @cmd: rc=$?", ($dscript ? "\n========= script begin\n$dscript\n========= script end\n\t" : '');
    find_candidates() if $leak_ok;
    die "I stop here,"
  }
}
1;

__END__