view release on metacpan or  search on metacpan

auto-dbg/auto-debug-module.pl  view on Meta::CPAN

# 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!)

# 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 <<EOW;

  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 <<EOW;
  ... 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(<<EOW)), exit 0 unless @ARGV;

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 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";
die "Directory $bd exist; won't overwrite" if -d $bd and not ($opt{U} and $build_was_OK);
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 (<MF>) {
    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/(?<!\S)\Q$Config{optimize}\E(?!\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} =~ /(?<!\S)-O(\d*|[a-z]?)(?!\S)/;
  }