#!/usr/bin/perl

# **********************************************************
# Copyright (c) 2007 VMware, Inc.  All rights reserved.
# **********************************************************

# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
# * Redistributions of source code must retain the above copyright notice,
#   this list of conditions and the following disclaimer.
#
# * Redistributions in binary form must reproduce the above copyright notice,
#   this list of conditions and the following disclaimer in the documentation
#   and/or other materials provided with the distribution.
#
# * Neither the name of VMware, Inc. nor the names of its contributors may be
#   used to endorse or promote products derived from this software without
#   specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL VMWARE, INC. OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
# DAMAGE.

##
## FILE: bugcrash.pl:
##
## Author: Sam Larsen
## Date: Thu Mar 22 19:07:51 2007
##
## Reads a forensics file and:
## - Launches windbg with DRload using the correct base address
## - Fills in the DR stack and dcontext dumps from the forensics
## - Locates the CONTEXT in the stack dump and sets it
##
## Preferred usage is just to supply a forensics file, and the script
## will try to find windbg and the proper dynamorio.dll from the
## nightlies.  However, you can explicitly specify these locations
## with the options below.
##

$usage = "Usage: $0 [-v] [-g <debuggerpath>] [-b <build_dir_base>] [-d DRdllpath] <forensic file>\n";

##
## Get options
##
use Getopt::Long;
@optl = ("v", "d=s", "b=s", "p=s", "g=s");
if (!(GetOptions @optl) || $#ARGV != 0) {
    die $usage;
}

$verbose = $opt_v;
$build_dir = $opt_b ? $opt_b : "";
$forensics = $ARGV[0];


##
## Locate debugger executable
##
if (!$opt_g) {
    # try to find installation of debugging tools for windows
    $progroot = &win32path2unix($ENV{'PROGRAMFILES'});
    @debugtools = glob("$progroot/Debug*/windbg.exe");
    $debugger = $debugtools[0];
} else {
    if (-d $opt_g) {
        $debugger = "$opt_g/windbg.exe";
    } else {
        $debugger = $opt_g;
    }
}

# -x seems to require o+x so we don't check
die "ERROR: can't find debugger $debugger\n" if (!-f "$debugger");
printf "Using debugger at $debugger\n" if ($verbose);


##
## Locate DRload
##
$DRtools = $ENV{'DYNAMORIO_TOOLS'};
if ($DRtools eq "") {
    # try same dir this script sits in
    $DRtools = $0;
    if ($DRtools =~ /[\\\/]/) {
        $DRtools =~ s/^(.+)[\\\/][\w\.]+$/\1/;
    } else {
        $DRtools = "./";
    }
}
$DRload = "$DRtools/DRload.exe";
# need win32 path with double backslashes
# e.g., c:\\\\derek\\\\dr\\\\tools\\\\DRload.exe
$DRload = &unixpath2win32($DRload);
die "ERROR: can't find DRload.exe" if (!-f "$DRload");


##
## Create a script file
##
$tmpdir = $ENV{'TMPDIR'} || $ENV{'TEMP'} || $ENV{'TMP'} || '/tmp';
die "Cannot find temp directory $tmpdir" if (! -d $tmpdir);
$script = "$tmpdir/bugcrash-$$.script";
$winscript = &unixpath2win32($script);
printf "script file is $script\n" if ($verbose);
open (OUT, "> $script") || die "ERROR: couldn't open $script";


##
## Parse forensics file
##
open (IN, "$forensics") ||
    die "ERROR: can't open forensics file $forensics\n";

$build_num = "";
$dr_base = "";
$lib = "";

$context = "";
$esp = "";

while (<IN>) {
    if (!$opt_d && /^Generated by SecureCore [^,]+,\s*(.+)/) {
        my $build_string = $1;
        if ($build_string =~ /build ([0-9]+)/) {
            $build_num = $1;
        } else {
            die "ERROR parsing dynamorio build number\n";
        }
    }
    elsif (!$opt_d && /^Unrecoverable error at PC 0x([0-9A-Za-z]+)/) {
        my $addr = $1;
        if ($addr =~ /^15/) {
            $lib = "debug";
        } elsif ($addr =~ /^71/) {
            $lib = "release";
        } else {
            die "ERROR: can't guess build from PC 0x$addr\n";
        }
    }
    elsif ($_ =~ /^dynamorio\.dll=(0x[0-9a-f]{8})/) {
        die "ERROR locating dynamorio.dll base\n" if ($dr_base ne "");
        $dr_base = $1;
    }
    elsif ($_ =~ /ebp=0x[0-9a-f]{8} esp=(0x[0-9a-f]{8})/) {
        die "ERROR locating esp\n" if ($esp ne "");
        $esp = $1;
    }
    elsif ($_ =~ /^DR Stack: 0x([0-9a-f]{8})/) {
        my $addr = hex($1);
        my $base = $addr;

        printf "DR stack is at 0x%x\n", $base;
        printf OUT ".dvalloc /b 0x%x 0x1000\n", $base;

        while (<IN>) {
            my @bits = split(' ', $_);
            if ($bits[0] =~ /^([0-9a-f]{8})$/) {
                die "ERROR reading DR stack\n", if (hex($bits[0]) != $addr);
                for (my $i=1; $i <= $#bits; $i++) {
                    die "ERROR reading DR stack\n" if ($bits[$i] !~ /^[0-9a-f]{8}$/);
                    printf OUT "ed 0x%08x 0x%08x\n", $addr, hex($bits[$i]);

                    # look for the context
                    if ($bits[$i] eq "0001003f") {
                        die "ERROR: found > 1 instances of 0x0001003f on the stack. " .
                            "Can't decipher the context\n" if ($context ne "");
                        $context = $addr;
                    }
                    $addr += 4;
                }
            }
            else {
                my $size = $addr - $base;
                die "ERROR: DR stack is $size bytes; expecting 0x1000\n"
                    if ($size != 0x1000);
                last;
            }
        }
    }
    elsif ($_ =~ /^current dcontext: 0x([0-9a-f]{8})/) {
        my $addr = hex($1);
        my $base = $addr;

        # The size of the dcontext could vary with the build, so
        # read it first and then output the .dvalloc command
        my $dcontext = "";
        while (<IN>) {
            my @bits = split(' ', $_);
            if ($#bits == 0 && $bits[0] eq "<![CDATA[") {
                next;
            }
            elsif ($bits[0] =~ /^([0-9a-f]{8})$/) {
                die "ERROR reading dcontext\n", if (hex($bits[0]) != $addr);
                for (my $i=1; $i <= $#bits; $i++) {
                    die "ERROR reading dcontext\n" if ($bits[$i] !~ /^[0-9a-f]{8}$/);
                    $dcontext .= sprintf("ed 0x%08x 0x%08x\n", $addr, hex($bits[$i]));
                    $addr += 4;
                }
            }
            else {
                my $size = $addr - $base;
                printf "dcontext is %d bytes at 0x%x\n", $size, $base;
                printf OUT ".dvalloc /b 0x%x 0x%x\n", $base, $size;
                printf OUT $dcontext;
                last;
            }
        }
    }
    elsif ($_ =~ /^\<hotpatching\-information\>/) {
        last;
    }
}
die "ERROR: didn't find dynamorio base\n" if ($dr_base eq "");
die "ERROR: didn't find context\n" if ($context eq "");
die "ERROR: didn't find esp\n" if ($esp eq "");
close (IN);


##
## Fill in context
##
printf OUT "r esp=$esp\n";
printf OUT ".cxr 0x%08x\n", $context;


##
## Create a debugger log file
##
$logfile = "$tmpdir/bugcrash-$$.log";
# start fresh -- no stale results
system("rm -f $logfile") if (-e $logfile);
printf "Log file is $logfile\n";
$win32logfile = &unixpath2win32($logfile);
printf OUT ".logopen $win32logfile\n";

close (OUT);


##
## Locate dynamorio.dll
##
if ($opt_d) {
    $DRdll = $opt_d;
} else {
    $DRdll = &findDRdll($build_dir, $build_num, $lib);
}
die "ERROR: can't find dynamorio.dll\n" if (!-e "$DRdll");
$DRdllwin32 = &unixpath2win32($DRdll);


##
## Run the debugger
##
$cmd = "\$><$winscript";
$cmdline = "\"$debugger\" -g -c \"$cmd\" $DRload -base $dr_base -debugbreak $DRdllwin32";
printf "$cmdline\n" if ($verbose);
system("$cmdline") && die "ERROR: couldn't run $cmdline\n";


sub findDRdll($,$,$) {
    my ($build_dir, $build_num, $lib) = @_;
    # would be nice to use symbol server, but cannot locate
    # based solely on build number w/o querying every dll, or having
    # a symlink set up externally or something.
    my @try = ( "//10.1.5.15/nightly",
                "//10.1.5.15/nightly_archive" );
    if ($build_dir ne "") {
        unshift @try, $build_dir;
    }
    print "searching these bases: @try\n" if ($verbose);
    # match ver_2_1, ver_2_5, etc., as well as the new dist
    # we avoid {ver*,dist} since that gives two entries regardless of existence
    my $ver = "[vd][ei][rs]*";
    my $missed_at_all = 0;
    foreach $base (@try) {
        my $glob_path = "$base/$build_num/$ver/lib/$lib/dynamorio.dll";
        my @wildcard = glob($glob_path);
        if (@wildcard == 0) {
            print STDERR "couldn't find $glob_path\n" if (!$quiet);
            $missed_at_all = 1;
        }
        foreach $w (@wildcard) {
            print "looking for $w\n" if ($verbose);
            if (-f $w) {
                # avoid found message if did it 1st try
                print STDERR "found $w\n" if (!$quiet && $missed_at_all);
                return $w;
            }
            print STDERR "couldn't find $w\n" if (!$quiet);
            $missed_at_all = 1;
        }
    }
    return "";
}


sub unixpath2win32($) {
    my ($p) = @_;
    # use cygpath if available, it will convert /home to c:\cygwin\home, etc.
    $cp = `cygpath -wi \"$p\"`;
    chomp $cp;
    if ($cp eq "") {
        # do it by hand
        # add support for /x => x:
        $p =~ s|^/([a-z])/|\1:/|;
        # forward slash becomes backslash since going through another shell
        $p =~ s|/|\\|g;
    } else {
        $p = $cp;
    }
    # make single backslashes doubles
    $p =~ s|\\{1}|\\\\|g;
    return $p;
}


sub win32path2unix($) {
    my ($p) = @_;
    # avoid issues with spaces by using 8.3 names
    $cp = `cygpath -dmi \"$p\"`;
    chomp $cp;
    if ($cp eq "") {
        # do it by hand
        $p =~ s|\\|/|g;
    } else {
        $p = $cp;
    }
    return $p;
}