#!perl -w
# (C) 2003-2007 Willem Jan Hengeveld <itsme@xs4all.nl>
# Web: http://www.xs4all.nl/~itsme/
#      http://wiki.xda-developers.com/
#
# $Id: dumpstack.pl 1502 2007-04-15 07:54:20Z itsme $
#
use strict;
use warnings;
$|=1;
use Dumpvalue;
my $d= new Dumpvalue;

# todo: read segment size
sub readmapfile {
    my ($filepath)= @_;

    my %syms;

    open FH, "<$filepath" or die "$filepath: $!\n";
    while (<FH>) {
        s/\s+$//;
        if (/^ \w+:\w+\s+(\S+)\s+(\w+)\s...\s(\S+)$/) {
            my ($symbol, $rva, $object)= ($1, hex($2), $3);
            $syms{$rva}= {
                symbol => $symbol,
                rva => $rva,
                object => $object,
            };
        }
    }

    close FH;

    return \%syms;
}
sub readsymfile {
    my ($filepath)= @_;

    my %syms;
    open FH, "<$filepath" or die "$filepath: $!\n";
    while (<FH>) {
        s/\s+$//;
        if (/^e\s(\S+):(\w+)\sr(\w+)\s+(\S+)$/) {
            my ($dllname, $ord, $rva, $symbol)= ($1, $2, hex($3), $4);
            $syms{$dllname}{$rva}= {
                symbol => $symbol || $ord,
                rva => $rva,
                dllname=> $dllname,
            };
        }
    }

    close FH;
    return \%syms;
}
sub pps_threads {
    my %threads;
    open PPS, "pps -t -v|" or die "pps: $!\n";
    while (<PPS>) {
        s/\s+$//;
        if (/^(\w+) (\w+) \w+ \w+ (\w+) (\w+) (\w+)\s+\S+\s+\S+  (.*)   (\w{8}): .*$/) {
            my ($tid, $start, $curpc, $curlr, $cursp, $modulename, $pid)= (hex($1), hex($2), hex($3), hex($4), hex($5), $6, hex($7));
            $threads{$tid}= {
                tid => $tid,
                start => $start,
                curpc => $curpc,
                curlr => $curlr,
                cursp => $cursp,
                modulename => $modulename,
                pid => $pid,
            };
        }
    }
    close PPS;
    return \%threads;
}
sub pps_processes {
    my %processes;
    open PPS, "pps|" or die "pps: $!\n";
    while (<PPS>) {
        s/\s+$//;
        if (/^(\w+)\s+\d+\s(\w+)\s+\S+\s+\S+\s+\S+\s(.*)$/) {
            my ($pid, $vmbase, $commandline)= (hex($1), hex($2), $3);
            (my $processname= $commandline) =~ s/\s.*//;
            $processes{$pid}= {
                vmbase=>$vmbase,
                slot=>($vmbase>>25) - 1,
                commandline=>$commandline,
                pid=>$pid,
                processname=>lc($processname),
            };
        }
    }
    close PPS;
    return \%processes;
}
sub pps_modules {
    my %modules;
    open PPS, "pps -m -h|" or die "pps: $!\n";
    while (<PPS>) {
        s/\s+$//;
        if (/^(\w+)\s(\w+)\s(\w+)\s(.*)$/) {
            my ($membase, $vbase, $usage, $modulename)= (hex($1), hex($2), hex($3), $4);
            $modules{$membase}= {
                membase => $membase,
                vbase => $vbase,
                usage => $usage,
                modulename => $modulename,
            };
        }
    }
    close PPS;
    return \%modules;
}

sub pmemdump {
    my ($ofs, $size)= @_;
    my $cmd= sprintf("pmemdump -f -x -4 0x%x 0x%x|", $ofs, $size);
    open PM, $cmd  or die "$cmd: $!\n";

    my @words;
    while (<PM>) {
        s/\s+$//;
        if (/([0-9a-f]{8}):\s([0-9a-f]{8}(?:\s[0-9a-f]{8})*)\s*$/) {
            my ($addr, $words)= ($1, $2);
            push @words, map { hex($_) } split /\s/, $words;
        }
        else {
            warn "$cmd\n$_\n";
        }
    }
    close PM;
    return \@words;
}

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

my $syms= readsymfile("c:\\local\\phones\\htc_typhoon\\os\\2_2_32_23\\symbols.txt");
$syms->{"cryptophone.exe"}= readmapfile("c:\\local\\cvsprj\\secphone\\build\\g10\\build\\CryptoPhone_debug.map");
$syms->{"spcore.exe"}= readmapfile("c:\\local\\cvsprj\\secphone\\build\\g10\\build\\spcore_debug.map");

my $threads= pps_threads();
my $processes= pps_processes();
my $modules= pps_modules();

for my $t (values %$threads) {
    $processes->{$t->{pid}}{threads}{$t->{tid}}= $t;
}

for my $p (values %$processes) {
    for my $m (values %$modules) {
        if ($p->{slot}<32 && ((1<<$p->{slot})&$m->{usage})!=0) {
            push @{$p->{modulelist}}, $m;
        }
    }
}

for my $p ( values %$processes) {
    printf("process - %d %s\n", $p->{slot}, $p->{commandline});
    for my $t (values %{$p->{threads}}) {
        $t->{stack}= pmemdump($t->{cursp}, ($t->{cursp}|0xfff)+1-$t->{cursp});

        printf("thread - start=%08lx ss=%04x: module=%s\n", $t->{start}, scalar @{$t->{stack}}, getmoduleoffset($p, $t->{start}));
        for my $val (@{$t->{stack}}) {
            printf("%08lx: %s\n", $val, getmoduleoffset($p, $val));
        }
    }
}

sub getmoduleoffset {
    my ($p, $ofs)= @_;
    if ($ofs>=$p->{vmbase} && $ofs<$p->{vmbase}+0x02000000) {
        $ofs-=$p->{vmbase};
    }
    if ($ofs<0x10000) {
        return "";
    }


    if ($ofs>=0x80000000 && $ofs<0xc0000000) {
        return sprintf("kernel:%08lx", $ofs);
    }
    elsif (($ofs>=0x02000000 && $ofs<0x04000000)
        ||($ofs>=0x7e000000 && $ofs<0x80000000)
        ||($ofs>=0xc2000000 && $ofs<0xc4000000)) {
        my $pm;
        for my $m (sort {$a->{membase} <=> $b->{membase}} values %$modules) {
            last if ($ofs < $m->{membase});
            $pm = $m;
        }
        if ($pm) {
            my $rva= $ofs-$pm->{membase};
            my $ps;
            for my $sym (sort {$a->{rva}<=>$b->{rva}} values %{$syms->{$pm->{modulename}}}) {
                last if ($rva < $sym->{rva});
                $ps= $sym;
            }
            if ($ps && $rva==$ps->{rva}) {
                return sprintf("%s:%s", $pm->{modulename}, $ps->{symbol});
            }
            elsif ($ps && $rva-$ps->{rva}<0x100000) {
                return sprintf("%s:%s+%08lx", $pm->{modulename}, $ps->{symbol}, $rva-$ps->{rva});
            }
            else {
                return sprintf("%s:%08lx", $pm->{modulename}, $rva);
            }
        }
    }
    elsif ($ofs<0x02000000) {
        my $ps;
        for my $sym (sort {$a->{rva}<=>$b->{rva}} values %{$syms->{$p->{processname}}}) {
            last if ($ofs < $sym->{rva});
            $ps= $sym;
        }
        if ($ps && $ofs==$ps->{rva}) {
            return sprintf("%s:%s", $p->{processname}, $ps->{symbol});
        }
        elsif ($ps && $ofs-$ps->{rva}<0x100000) {
            return sprintf("%s:%s+%08lx", $p->{processname}, $ps->{symbol}, $ofs-$ps->{rva});
        }
        else {
            return sprintf("%s:%08lx", $p->{processname}, $ofs);
        }
    }
    return "";
}