# -*- cperl -*-
# Copyright (C) 2004-2006 MySQL AB
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

package My::CoreDump;

use strict;
use Carp;
use My::Platform;

use File::Temp qw/ tempfile tempdir /;

sub _gdb {
  my ($core_name)= @_;

  print "\nTrying 'gdb' to get a backtrace\n";

  return unless -f $core_name;

  # Find out name of binary that generated core
  `gdb -c '$core_name' --batch 2>&1` =~
    /Core was generated by `([^\s\'\`]+)/;
  my $binary= $1 or return;
  print "Core generated by '$binary'\n";

  # Create tempfile containing gdb commands
  my ($tmp, $tmp_name) = tempfile();
  print $tmp
    "bt\n",
    "thread apply all bt\n",
    "quit\n";
  close $tmp or die "Error closing $tmp_name: $!";

  # Run gdb
  my $gdb_output=
    `gdb '$binary' -c '$core_name' -x '$tmp_name' --batch 2>&1`;

  unlink $tmp_name or die "Error removing $tmp_name: $!";

  return if $? >> 8;
  return unless $gdb_output;

  print <<EOF, $gdb_output, "\n";
Output from gdb follows. The first stack trace is from the failing thread.
The following stack traces are from all threads (so the failing one is
duplicated).
--------------------------
EOF
  return 1;
}


sub _dbx {
  my ($core_name)= @_;

  print "\nTrying 'dbx' to get a backtrace\n";

  return unless -f $core_name;

  # Find out name of binary that generated core
  `echo | dbx - '$core_name' 2>&1` =~
    /Corefile specified executable: "([^"]+)"/;
  my $binary= $1 or return;
  print "Core generated by '$binary'\n";

  # Find all threads
  my @thr_ids = `echo threads | dbx '$binary' '$core_name' 2>&1` =~ /t@\d+/g;

  # Create tempfile containing dbx commands
  my ($tmp, $tmp_name) = tempfile();
  foreach my $thread (@thr_ids) {
    print $tmp "where $thread\n";
  }
  print $tmp "exit\n";
  close $tmp or die "Error closing $tmp_name: $!";

  # Run dbx
  my $dbx_output=
    `cat '$tmp_name' | dbx '$binary' '$core_name' 2>&1`;

  unlink $tmp_name or die "Error removing $tmp_name: $!";

  return if $? >> 8;
  return unless $dbx_output;

  print <<EOF, $dbx_output, "\n";
Output from dbx follows. Stack trace is printed for all threads in order,
above this you should see info about which thread was the failing one.
----------------------------
EOF
  return 1;
}


sub show {
  my ($class, $core_name)= @_;

  # We try dbx first; gdb itself may coredump if run on a Sun Studio
  # compiled binary on Solaris.

  my @debuggers =
    (
     \&_dbx,
     \&_gdb,
     # TODO...
   );

  # Try debuggers until one succeeds

  foreach my $debugger (@debuggers){
    if ($debugger->($core_name)){
      return;
    }
  }
  return;
}


1;