#!/usr/bin/perl

#
# Modification History
#
# 2004-January-17    Jason Rohrer
# Fixed regexps to match both A-F and a-f for hex address strings.
#


# Erwin S. Andreasen <erwin@andreasen.org>
# Henner Zeller <foobar@to.com>
#
# Homepage: http://www.andreasen.org/LeakTracer/
# This program is Public Domain
use IO::Handle;

die "You must supply at least one argument.\n" unless $#ARGV >= 0;

$ExeFile = shift @ARGV;
$LeaksFile = $#ARGV >= 0 ? shift @ARGV : "leak.out";
open (LEAKS, $LeaksFile) or die "Could not open leaks data file $LeaksFile: $!";

if ($#ARGV >= 0) {
    $BreakOn = shift @ARGV;
    # Rest in @ARGV are program arguments
}

$n = $u = 0;
while (<LEAKS>) {
    chop;
    next if (m/^\s*#/);
    #             1       2          3       4          5      6            7
    #if (/^\s*L\s+(0x)?([0-9a-fA-F]+)\s+(0x)?([0-9a-fA-F]+)\s+(0x)?([0-9a-fA-F]+)\s+(\d+)/) {
    # Allocations, which have not been freed or deallocations which have not
    # been allocated.
    #              1      2           3
    if (/^\s*L\s+(0x)?([0-9a-fA-F]+)\s+(\d+)/) {
        $addr="$2";  # ",$4,$6";
        $u++ if not exists $Type{$addr};
        $Count{$addr}++;
	$Size{$addr} += $3; # $7;
	$Type{$addr} = "Leak";
        $n++;
    }
    elsif (/^\s*D\s+(0x)?([0-9a-fA-F]+)/) {
        $addr="$2";  # ",$4,$6";
        $u++ if not exists $Type{$addr};
        $Count{$addr}++;
	$Type{$addr} = "delete on not allocated memory";
        $n++;
    }
    # allocations/deallocations with other errornous conditions
    #              1      2        3         4        5
    elsif (/^\s*([SO])\s+(0x)?([0-9a-fA-F]+)\s+(0x)?([0-9a-fA-F]+)/) {
	$addrs = "$3,$5,$1";
	$AllocDealloc{$addrs} = ("$1" =~ m/S/) 
	    ? "Different allocation schemes" 
	    : "This Memory was overwritten";
    }
}

print STDERR "Gathered $n ($u unique) points of data.\n";

close (LEAKS);


# Instead of using -batch, we just run things as usual. with -batch,
# we quit on the first error, which we don't want.
open (PIPE, "|gdb -q  $ExeFile") or die "Cannot start gdb";
#open (PIPE, "|cat");

# Change set listsize 2 to something else to show more lines
print PIPE "set prompt\nset complaints 1000\nset height 0\n";

# Optionally, run the program
if (defined($BreakOn)) {
    print PIPE "break $BreakOn\n";
    print PIPE "run ", join(" ", @ARGV), " \n";
}


print PIPE "set listsize 2\n";
foreach (sort keys %AllocDealloc) {
    print PIPE "echo \\n#-- Alloc: $AllocDealloc{$_}\\nalloc here :\n";
    @addrs = split(/,/,$_);
    print PIPE "l *0x" . (shift @addrs) . "\necho ..free here :\n";
    print PIPE "set listsize 1\n";
    print PIPE "l *0x" . (shift @addrs) . "\n";
}

foreach (sort keys %Type) {
    print PIPE "echo \\n#-- $Type{$_}: counted $Count{$_}x";
    if ($Size{$_} > 0) {
	print PIPE " / total Size: $Size{$_}";
    }
    print PIPE "\\n\n";
    @addrs = split(/,/,$_);
    print PIPE "set listsize 2\n";
    print PIPE "l *0x" . (shift @addrs) . "\n";
    #print PIPE "echo ..called from :\n";
    #print PIPE "set listsize 1\n";
    # gdb bails out, if it cannot find an address.
    #print PIPE "l *0x" . (shift @addrs) . "\necho ..called from :\n";
    #print PIPE "l *0x" . (shift @addrs) . "\n";
}

if (defined($BreakOn)) {
    print PIPE "kill\n";
}

print PIPE "quit\n";
PIPE->flush();
wait();

close (PIPE);