#!/usr/bin/perl -w
#
# lwp_process -- processes lwp process dumps.
#  based upon code from.
#
# dmalloc_summarize -- summarizes dmalloc log files
#
# Copyright 1997 by USC/ISI All rights reserved.
#                                                                
# Redistribution and use in source and binary forms are permitted
# provided that the above copyright notice and this paragraph are
# duplicated in all such forms and that any documentation, advertising
# materials, and other materials related to such distribution and use
# acknowledge that the software was developed by the University of
# Southern California, Information Sciences Institute.  The name of
# the University may not be used to endorse or promote products
# derived from this software without specific prior written
# permission.
# 
# THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# $Id: dmalloc_summarize.pl,v 1.1 1997/07/07 08:13:52 gray Exp $
# 

sub usage {
    print STDERR <<END;
usage: $0 [executable] < logfile

Post-process a dmalloc logfile (read from standard input).

If an EXECUTABLE is specified, unknown symbols will be translated
according to that executable.
END
    exit 1;
}

require 5.000;
use strict;
# needed for gdb communications
use IPC::Open2;

# process args
use Getopt::Long;
&usage if ($#ARGV >= 1 && $ARGV[0] eq '-?');
my($exe) = undef;
if ($#ARGV >= 0) {
    $exe = $ARGV[0];
};

######################################################################

my($gdb_pid);

#
# Start a gdb pipe to resolve unknown return addresses.
#
sub start_gdb {
  $SIG{'PIPE'} = sub { mydie("ERROR: premature end-of-data.\n"); };
  $gdb_pid = open2('GDB_RDR', 'GDB_WTR', 'gdb', '-nx', '-q', $exe) ||
    die "$0: cannot run gdb on $exe\n";
  # tidy things up
  # prompt becomes a magic number to look for
  print GDB_WTR "set prompt (gdb)\\n\n";
  print GDB_WTR "set print asm-demangle on\n";
  print GDB_WTR "set height 0\n";
}

#
# Huh?
#
sub never_called {
    <GDB_RDR>; <GDB_WTR>;   # hack for warnings
}

#
# Lookup an unknown ra-address with gdb
#
sub interpret_name {
  my($name) = $_[0] ;
  return unless $name ;
  
  start_gdb() if (!defined($gdb_pid));
  
  print GDB_WTR "info line *($name)\n";
  
  my($something) = undef;
  my($file_line, $function);
  while (<GDB_RDR>) {
    if (/^\(gdb\)$/) {
      last if ($something);
      next;   # skip prompts
    };
    $something = 1;
    if (/^Line (\d+) of "([^\"]+)"/) {
      $file_line = "$2:$1";
    };
    if (/\<(.*)\+\d+\>/) {
      $function = $1;
    };
  };
  my($n) = "";
  $n .= "$function " if (defined($function));
  $n .= "[$file_line] " if (defined($file_line));
  $n = $name if ($n eq '');
  return $n;
}

######################################################################

# read the data
sub read_data {
  print "*************************************************************\n" ;
  while (<STDIN>) {
    chop ;

    print "$_\n" ;

    next unless /^[ \t]+Stack/;

    s/[ \t]+Stack: .* - // ;

    my $function = interpret_name($_);
    print "\t  $function\n" ;
  };
}

read_data;

exit 0;