#!perl -w
$|=1;
# z:/sources/wince500/PRIVATE/WINCEOS/COREOS/CORE/LMEM/heap.h
# 7c070000: 50616548  DWORD   dwSig;                  // 00: heap signature "HeaP"
#           00000000  pvaitem pvaList;                // 04: list of VirtualAlloc'ed items
#           0a120000  pheap   phpNext;                // 08: next heap in linked list of all heaps
#           00001000  WORD    flOptions;              // 0C: options from HeapCreate
# 7c070010: 00000000  DWORD   cbMaximum;              // 10: maximum size of this heap (0 == growable)
#           03f01c20  PFN_AllocHeapMem pfnAlloc;      // 14: allocator
#           03f01c4c  PFN_FreeHeapMem pfnFree;        // 18: de-allocator
#           00000001  CRITICAL_SECTION cs;            // 1c: critical section controlling this heap.
# 7c070020: 00000000                                                                                   
#           8f68bd30                                                                                   
#           00000000                                                                                   
#           00000000                                                                                   
#                      region  rgn;                    // 30: first memory region in this heap
# 7c070030: 7c0833e8     pitem   pitFree;                // 00: ptr to next available allocation
#           7c070030     pregion prgnLast;               // 04: ptr to last region (only valid for the original region)
#           00000ff1     int     cbMaxFree;              // 08: size of largest free item in this region
#           7c0833e8     pitem   pitLast;                // 0C: last free item proceeding end-marker (or end-marker itself)
# 7c070040: 7c070000     pheap   phpOwner;               // 10: ptr to heap this region is part of
#           00000000     pregion prgnNext;               // 14: ptr to next region in the heap
#           00000000     DWORD   dwRgnData;              // 18: data for allocator
#           00000000     DWORD   pad;                    // 1c: padding
# 7c070050: 00000000 00000000                  
# 

#   pvaitem pvaFwd;         // ptr to next VA'ed item in heap
#   pvaitem pvaBak;         // ptr to previous VA'ed item
#   DWORD   dwData;         // data for allocator
#   DWORD   pad;            // padding
#   item    it;             // item info


# sms3.mem  - after login
# sms2.mem  - after open inbox + contacts
# sms1.mem  - after lock

# todo: merge this into 'parsecrash.pl'

package MemImage;
use strict;
use IO::File;
sub new {
    my ($class, $filename, $base)= @_;
    my $fh= IO::File->new($filename, "r") or die "$filename: $!\n";
    my $self= {
        filename=>$filename,
        base=>$base,
        fh=>$fh,
    };
    return bless $self, $class;
}
sub readdata {
    my ($self, $ofs, $len)= @_;
    if ($ofs>=$self->{base} && $ofs<$self->{base}+0x02000000) {
        $ofs-=$self->{base};
    }
    if ($ofs>=0x02000000) {
        warn sprintf("unknown offset: %08lx\n", $ofs);
        return;
    }
    my $data;
    $self->{fh}->seek($ofs, SEEK_SET);
    $self->{fh}->read($data, $len);
    return $data;
}
sub readdw {
    my ($self, $ofs)= @_;
    return unpack("V", $self->readdata($ofs, 4));
}

package main;
use strict;
use Getopt::Long;
# from startheap, follow phpNext
#   for each heap:
#      follow prgnNext
#   for each region:
#      dump block list
#   calc free space, used space
#
sub parseHeapHeader {
    my %hdr;
    (
        $hdr{dwSig},
        $hdr{pvaList},
        $hdr{phpNext},
        $hdr{flOptions},
        $hdr{cbMaximum},
        $hdr{pfnAlloc},
        $hdr{pfnFree},
        $hdr{cs},
    )= unpack("V7a20", $_[0]);
    return \%hdr;
}
sub parseRegionHeader {
    my %hdr;
    (
        $hdr{pitFree},
        $hdr{prgnLast},
        $hdr{cbMaxFree},
        $hdr{pitLast},
        $hdr{phpOwner},
        $hdr{prgnNext},
        $hdr{dwRgnData},
        $hdr{pad},
    )= unpack("V8", $_[0]);
    return \%hdr;
}
sub parseVirtualAllocHeader {
    my %hdr;
    (
        $hdr{pvaFwd},
        $hdr{pvaBak},
        $hdr{dwData},
        $hdr{pad},
        $hdr{itsize},
        $hdr{itinfo},
    )= unpack("V6", $_[0]);
    return \%hdr;
}

my $g_outputformat=0;
GetOptions(
    "x"=> sub { $g_outputformat= 1; },
);
my $filename=shift;

my $mem= MemImage->new($filename, 0);
my @heaps;
my $base;

# note: we find heaps by scanning memory,
# another way would be to find the 'firstheap' ptr in the coredll.dll data section
# this however depends on the exact version of coredll.dll used.
for (my $hofs=0 ; $hofs<0x02000000 ; $hofs+=0x10000)
{
    my $hdrdata= $mem->readdata($hofs, 0x50);
    my ($magic, $unused, $selfptr)= unpack("a4a60V", $hdrdata);
    if ($magic eq "HeaP" && (($selfptr&0x01ffffff)==$hofs || ($selfptr&0x01ffffff)==$hofs+0x70000)) {
        if (!defined $base) {
            $base= ($selfptr&0xfe000000) + ($selfptr&0x01ffffff)-$hofs;
        }
        elsif ($base != ($selfptr&0xfe000000)) {
            printf("NOTE: base inconsistency: %08lx .. %08lx\n", $base, $selfptr&0xfe000000);
        }
        push @heaps, $selfptr;
    }
}
if (!defined $base) {
    printf("NOTE: could not find base of memory image\n");
}
if (!@heaps) {
    printf("NOTE: no heap blocks found\n");
}

sub datastr {
    return asciistr(@_) if ($g_outputformat==0);
    return dwordstr(@_) if ($g_outputformat==1);
    return "?";
}
sub asciistr {
    my $data=shift;

    my $s="";
    my $ppos=0;
    while ($data =~ /(?:[\x20-\x7e]\x00){3,}|[\x20-\x7e]{3,}/g) {
        my $match=$&;
        my $pos=pos($data)-length($match);

        if ($ppos&3) {
            $s .= sprintf(" %s", $ppos, unpack("H*", substr($data, $ppos, 4-($ppos&3))));
            $ppos += 4-($ppos&3);
        }
        $s .= sprintf(" [%04x]: %s", $ppos, join " ", map { sprintf("%08lx", $_) } unpack("V*", substr($data, $ppos, ($pos&~3)-$ppos)));
        $ppos += ($pos&~3)-$ppos;
        if ($pos&3) {
            $s .= sprintf(" %s", $ppos, unpack("H*", substr($data, $ppos, $pos-$ppos)));
        }

        if ($match =~ /\x00/) {
            $s .= sprintf(" [%04x]:L\"%s\"", $pos, pack 'U*', unpack 'v*', $match);
        }
        else {
            $s .= sprintf(" [%04x]:\"%s\"", $pos, $match);
        }

        $ppos= $pos+length($match);
    }
    if ($ppos&3) {
        $s .= sprintf(" %s", unpack("H*", substr($data, $ppos, 4-($ppos&3))));
        $ppos += 4-($ppos&3);
    }

    $s .= sprintf(" [%04x]: %s", $ppos, join " ", map { sprintf("%08lx", $_) } unpack("V*", substr($data, $ppos)));
    return $s;
}
sub dwordstr {
    my $data=shift;

    my $s="";
    my $ppos= 0;
    while ($ppos<length($data)) {
        if (substr($data,$ppos,4) =~ /^[0-9a-zA-Z_]+$/) {
            $s .= sprintf(" [%04x]:\"%s\"", $ppos, substr($data,$ppos,4));
        }
        else {
            $s .= sprintf(" %08lx", unpack("V", substr($data,$ppos,4)));
        }
        $ppos+=4;
    }

    if ($ppos < length($data)) {
        $s .= sprintf(" [%04x]: %s", $ppos, join " ", map { sprintf("%08lx", $_) } unpack("V*", substr($data, $ppos)));
    }
    return $s;
}
# set base in memimage
$mem->{base}= $base;
my %stats;
for my $hofs (@heaps)
{
    printf("---h:%08lx\n", $hofs);
    my $hdata= $mem->readdata($hofs, 48);
    my $heap= parseHeapHeader($hdata);
    printf("heapsig: %08lx\n", $heap->{dwSig}) if ($heap->{dwSig}!=0x50616548);
    printf("heap: %08lx %08lx %08lx %08lx %08lx %08lx %08lx\n", $heap->{dwSig},     $heap->{pvaList},   $heap->{phpNext},   $heap->{flOptions}, $heap->{cbMaximum}, $heap->{pfnAlloc}, $heap->{pfnFree});
    my $va= $heap->{pvaList};
    while ($va) {
        my $vdata= $mem->readdata($va, 24);
        my $vaitem= parseVirtualAllocHeader($vdata);

        printf("%08lx: va  : %08lx %08lx %08lx %08lx %08lx %08lx\n",
            $va+0x20, $vaitem->{pvaFwd}, $vaitem->{pvaBak}, $vaitem->{dwData}, $vaitem->{pad}, $vaitem->{itsize}, $vaitem->{itinfo});
       
        $va= $vaitem->{pvaFwd};
    }
    my $rofs= $hofs+0x30;
    while ($rofs)
    {
        printf("---r:%08lx\n", $rofs);
        my $rdata= $mem->readdata($rofs, 0x20);
        my $region= parseRegionHeader($rdata);
        printf("rgn : %08lx %08lx %08lx %08lx %08lx %08lx %08lx %08lx\n", $region->{pitFree}, $region->{prgnLast}, $region->{cbMaxFree}, $region->{pitLast}, $region->{phpOwner}, $region->{prgnNext}, $region->{dwRgnData}, $region->{pad});

        my $iofs= $rofs+0x28;
        while ($iofs<$region->{pitLast}) {
            my $idata= $mem->readdata($iofs, 8);
            my ($size, $ptr)= unpack("lV", $idata);
            my $type;
            if ($size>0 && $ptr==$rofs) {
                $type= 'busy';
            }
            elsif ($size<0) {
                $type= 'free';
                $size = -$size;
            }
            elsif ($size>0 && $ptr==0) {
                $type= 'hole';
            }
            elsif ($size==0 && $ptr==0) {
                $type= 'unkn';
                printf("!!! HEAP CORRUPT !!!\n");
                $size= 0x10;
            }
            elsif ($size==0) {
                $type= 'tail';
                $size= $ptr;
            }
            else {
                printf("!!! unhandled case: %08lx: size=%08lx ptr=%08lx\n", $iofs, $size, $ptr);
            }

            printf("%08lx-%08lx: %s : %s\n", $iofs+8, $iofs+8+$size, $type, datastr($mem->readdata($iofs+8, $size-8)));

            # todo: add option to hexdump heap blocks
            $stats{$type}{total} += $size;
            $stats{$type}{hdr} += 8;
            $stats{$type}{x}{$size}++;
            $iofs+=$size;

            while (($iofs&0xf)!=8) {
                $iofs++;
            }
        }
        printf("region: %08lx-%08lx\n", $rofs, $iofs);
        $rofs= $region->{prgnNext};
    }
    if ($heap->{phpNext}>0 && ($heap->{phpNext}<$base || $heap->{phpNext}>=$base+0x02000000)) {
        printf("NOTE: heap %08lx is not in the saved image\n", $heap->{phpNext});
    }
}
printf("\n");
for my $t (qw(busy free hole tail)) {
    next unless $stats{$t}{hdr};
    printf("%s : user:%08lx hdr:%08lx  -> %08lx\n", $t, $stats{$t}{total}, $stats{$t}{hdr}, $stats{$t}{total}+$stats{$t}{hdr});
    for my $x (sort { $a<=>$b } keys %{$stats{$t}{x}}) {
        printf("    %8x : %8d\n", $x, $stats{$t}{x}{$x});
    }
}