#!/usr/bin/env perl
# win/xbox KD client
#
# Copyright (C) 2007 SecureWorks, Inc.
# Copyright (C) 2013 espes
#
# This program is free software subject to the terms of the GNU General 
# Public License.  You can use, copy, redistribute and/or modify the 
# program under the terms of the GNU General Public License as published 
# by the Free Software Foundation; either version 3 of the License, or 
# (at your option) any later version. You should have received a copy of 
# the GNU General Public License along with this program.  If not, 
# please see http://www.gnu.org/licenses/ for a copy of the GNU General 
# Public License.
#
# The program is subject to a disclaimer of warranty and a limitation of 
# liability, as disclosed below.
#
# Disclaimer of Warranty.
#
# THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
# APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
# HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT 
# WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT 
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 
# PARTICULAR PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE 
# OF THE PROGRAM IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU 
# ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, CORRECTION OR 
# RECOVERY FROM DATA LOSS OR DATA ERRORS.
#
# Limitation of Liability.
#
# IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
# WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR 
# CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 
# INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES 
# ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT 
# NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES 
# SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE 
# WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN 
# ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.

use IO::Select;
use IO::Socket;
use File::stat;
use Fcntl ':mode';
use strict;

$| = 1;
my $dev = $ARGV[0];
$dev ||= "/dev/ttyS0";
$SIG{'ALRM'} = sub { die "timeout" };
my $timeout = 10;    # max time to wait on packet
my $running = 1;

my $pcontext;        # global process context
my %kernelcontext;
$kernelcontext{'peb'}      = 0;
$kernelcontext{'pid'}      = 0;
$kernelcontext{'eprocess'} = 0;
$kernelcontext{'dtb'}      = 0;
my %processcontext;
$processcontext{'peb'}      = 0;
$processcontext{'pid'}      = 0;
$processcontext{'eprocess'} = 0;
$processcontext{'dtb'}      = 0;
$pcontext                   = \%kernelcontext;

my $version;
my $kernelbase;

my $nextpid = 1;
my %breakpoints;
my $curbp = 1;
my $controlspace;
my $controlspacesent;

my $isserial;
my $serial;
my $socket;
my $ds = stat($dev) || die "$!";
if (S_ISCHR($ds->mode)) {
    require Device::SerialPort;
    $serial = tie( *FH, 'Device::SerialPort', "$dev" ) || die "Can't tie: $!";
    $serial->baudrate(115200);
    $serial->parity("none");
    $serial->databits(8);
    $serial->stopbits(1);
    $serial->handshake("none");
    $serial->write_settings || die "failed writing settings";
    FH->blocking(0);
} elsif (S_ISSOCK($ds->mode)) {
    $socket = IO::Socket::UNIX->new(
        Type => SOCK_STREAM,
        Peer => $dev
    ) || die "Can't create socket $!";
} else {
    die "$dev not a character device or a socket\n";
}

sub writeDev {
    my $data = shift;
    if ($serial) {
        $serial->write($data);
    } else {
        $socket->syswrite($data);
    }
}

sub readLoop {
    my $wanted = shift;
    my $total  = 0;
    my $count;
    my $outbuf;
    while ( $total < $wanted ) {
        my $buf;
        if ($serial) {
            ( $count, $buf ) = $serial->read(1);
        } else {
            #FH->blocking(1);
            $count = $socket->sysread($buf, 1);
            if ($count == 0) {
                die "eof";
            }
            # printf "readLoop $count %x\n", ord($buf);
            #FH->blocking(0);
        }
        
        if ($count) {
            $total += $count;
            $outbuf .= $buf;
        }
    }
    return $outbuf;
}

sub hexformat {
    my $buf = shift;
    my $len = length($buf);
    return unless $len;
    my $b = "0000  ";
    my $c = 0;
    for ( split( //, $buf ) ) {
        $c++;
        $b .= sprintf( "%02x ", ord );
        unless ( $c % 16 ) {
            if ( $c < $len ) {
                $b .= sprintf( "\n%04x ", $c );
            }
            else {
                $b .= sprintf( "\n", $c );
            }
        }
    }
    $b .= "\n" unless substr( $b, -1, 1 ) eq "\n";
    return $b;
}

sub cksum {
    my $sum;
    for ( split( //, shift ) ) {
        $sum += ord;
    }
    return $sum;
}

my $PACKET_LEADER = 0x30303030;
my $CONTROL_PACKET_LEADER = 0x69696969;

my $PACKET_TYPE_UNUSED              = 0;
my $PACKET_TYPE_KD_STATE_CHANGE32   = 1;
my $PACKET_TYPE_KD_STATE_MANIPULATE = 2;
my $PACKET_TYPE_KD_DEBUG_IO         = 3;
my $PACKET_TYPE_KD_ACKNOWLEDGE      = 4;
my $PACKET_TYPE_KD_RESEND           = 5;
my $PACKET_TYPE_KD_RESET            = 6;
my $PACKET_TYPE_KD_STATE_CHANGE64   = 7;
my $PACKET_TYPE_MAX                 = 8;

sub handlePacket {
    my $quiet = shift;

    my ($ptype, $buf) = getPacket($quiet);
    
    if (!$buf) {
        return;
    }

    if ($ptype == $PACKET_TYPE_KD_STATE_MANIPULATE) {
        handleStateManipulate($buf, $quiet);
    } elsif ($ptype == $PACKET_TYPE_KD_DEBUG_IO) {
        handleDebugIO($buf, $quiet);
    } elsif ($ptype == $PACKET_TYPE_KD_STATE_CHANGE64) {
        handleStateChange($buf, $quiet);
    }

    return ($ptype, $buf);
}

sub getPacket {
    my $payload;
    my $quiet = shift;

    my $ptype;

    my $buf   = readLoop(4);
    my $plh = unpack( "I", $buf );
    if ( $plh == $PACKET_LEADER || $plh == $CONTROL_PACKET_LEADER ) {
        printf "Got packet leader: %08x\n", $plh unless $quiet;
        
        $buf = readLoop(2);
        $ptype = unpack( "S", $buf );
        print "Packet type: $ptype\n" unless $quiet;
        
        $buf = readLoop(2);
        my $bc = unpack( "S", $buf );
        print "Byte count: $bc\n" unless $quiet;
        
        $buf = readLoop(4);
        my $pid = unpack( "I", $buf );
        $nextpid = $pid;
        printf "Packet ID: %08x\n", $pid unless $quiet;
        
        $buf = readLoop(4);
        my $ck = unpack( "I", $buf );
        printf "Checksum: %08x\n", $ck unless $quiet;

        if ($bc) {
            $payload = readLoop($bc);
        }

        # send ack if it's a non-control packet
        if ( $plh == 0x30303030 ) {

            # packet trailer
            my $trail = readLoop(1);
            # print hexformat($trail) unless $quiet;
            if ( $trail eq "\xaa" ) {
                # print "sending Ack\n";# unless $quiet;
                sendAck();
            }
        }
    }
    return ($ptype, $payload);
}

# PACKET_TYPE_KD_DEBUG_IO apis
# DBGKD_DEBUG_IO
my $DbgKdPrintStringApi = 0x00003230;
my $DbgKdGetStringApi = 0x00003231;
sub handleDebugIO {
    my $buf = shift;
    my $quiet = shift;

    my $apiNumber = unpack("I", substr($buf, 0, 4));
    if ($apiNumber == $DbgKdPrintStringApi) {
        print "DBG PRINT STRING: ".substr($buf, 0x10);
    }
}

# PACKET_TYPE_KD_STATE_CHANGE states
# X86_NT5_DBGKD_WAIT_STATE_CHANGE64
my $DbgKdExceptionStateChange   = 0x00003030;
my $DbgKdLoadSymbolsStateChange = 0x00003031;

sub handleStateChange {
    my $buf = shift;
    my $quiet = shift;

    my $newState = unpack("I", substr($buf, 0, 4));
    printf "State Change: %08x\n", $newState unless $quiet;
    
    if ($newState == $DbgKdExceptionStateChange) {
        my %exceptions = (
            0xc0000005 => "EXCEPTION_ACCESS_VIOLATION",
            0xc000008c => "EXCEPTION_ARRAY_BOUNDS_EXCEEDED",
            0x80000003 => "EXCEPTION_BREAKPOINT",
            0x80000002 => "EXCEPTION_DATATYPE_MISALIGNMENT",
            0xc000008d => "EXCEPTION_FLT_DENORMAL_OPERAND",
            0xc000008e => "EXCEPTION_FLT_DIVIDE_BY_ZERO",
            0xc000008f => "EXCEPTION_FLT_INEXACT_RESULT",
            0xc0000030 => "EXCEPTION_FLT_INVALID_OPERATION",
            0xc0000091 => "EXCEPTION_FLT_OVERFLOW",
            0xc0000032 => "EXCEPTION_FLT_STACK_CHECK",
            0xc0000033 => "EXCEPTION_FLT_UNDERFLOW",
            0x80000001 => "EXCEPTION_GUARD_PAGE",
            0xc000001d => "EXCEPTION_ILLEGAL_INSTRUCTION",
            0xc0000006 => "EXCEPTION_IN_PAGE_ERROR",
            0xc0000094 => "EXCEPTION_INT_DIVIDE_BY_ZERO",
            0xc0000035 => "EXCEPTION_INT_OVERFLOW",
            0xc00000fd => "EXCEPTION_STACK_OVERFLOW"
        );


        # DBGKM_EXCEPTION64
        my $ex = substr($buf, 32);

        my $code = unpack("I", substr($ex,0,4));
        my $flags = unpack("I", substr($ex,4,4));
        my $record = unpack("I", substr($ex,8,4));
        my $address = unpack("I", substr($ex,16,4));
        my $parameters = unpack("I", substr($ex,24,4));

        if ( $exceptions{$code} ) {
            printf "*** %s ", $exceptions{$code};
        }
        else {
            printf "*** Exception %08x ", $code;
        }
        printf "at %08x\n", $address;

        printf "Exception flags = %08x\n", $flags;
        printf "Exception record = %08x\n", $record;
        printf "Exception address = %08x\n", $address;
        printf "Number parameters = %08x\n", $parameters;

        $running = 0;

        # my @v = getVersionInfo();
        # $version    = $v[0];
        # $kernelbase = $v[2];
    } elsif ($newState == $DbgKdLoadSymbolsStateChange) {
        #DBGKD_LOAD_SYMBOLS64

        my $file = substr($buf, 0x3b8);
        chop $file;
        print "Load Symbols for $file\n";

        #nothing to do...

        sendDbgKdContinue2();

    }
}

# PACKET_TYPE_KD_STATE_MANIPULATE api numbers
# DBGKD_MANIPULATE_STATE64
my $DbgKdReadVirtualMemoryApi           = 0x00003130;
my $DbgKdWriteVirtualMemoryApi          = 0x00003131;
my $DbgKdGetContextApi                  = 0x00003132;
my $DbgKdSetContextApi                  = 0x00003133;
my $DbgKdWriteBreakPointApi             = 0x00003134;
my $DbgKdRestoreBreakPointApi           = 0x00003135;
my $DbgKdContinueApi                    = 0x00003136;
my $DbgKdReadControlSpaceApi            = 0x00003137;
my $DbgKdWriteControlSpaceApi           = 0x00003138;
my $DbgKdReadIoSpaceApi                 = 0x00003139;
my $DbgKdWriteIoSpaceApi                = 0x0000313A;
my $DbgKdRebootApi                      = 0x0000313B;
my $DbgKdContinueApi2                   = 0x0000313C;
my $DbgKdReadPhysicalMemoryApi          = 0x0000313D;
my $DbgKdWritePhysicalMemoryApi         = 0x0000313E;
my $DbgKdSetSpecialCallApi              = 0x00003140;
my $DbgKdClearSpecialCallsApi           = 0x00003141;
my $DbgKdSetInternalBreakPointApi       = 0x00003142;
my $DbgKdGetInternalBreakPointApi       = 0x00003143;
my $DbgKdReadIoSpaceExtendedApi         = 0x00003144;
my $DbgKdWriteIoSpaceExtendedApi        = 0x00003145;
my $DbgKdGetVersionApi                  = 0x00003146;
my $DbgKdWriteBreakPointExApi           = 0x00003147;
my $DbgKdRestoreBreakPointExApi         = 0x00003148;
my $DbgKdCauseBugCheckApi               = 0x00003149;
my $DbgKdSwitchProcessor                = 0x00003150;
my $DbgKdPageInApi                      = 0x00003151;
my $DbgKdReadMachineSpecificRegister    = 0x00003152;
my $DbgKdWriteMachineSpecificRegister   = 0x00003153;
my $DbgKdSearchMemoryApi                = 0x00003156;
my $DbgKdGetBusDataApi                  = 0x00003157;
my $DbgKdSetBusDataApi                  = 0x00003158;
my $DbgKdCheckLowMemoryApi              = 0x00003159;

sub handleStateManipulate {
    my $buf   = shift;
    my $quiet = shift;

    my $apiNumber = unpack("I", substr($buf, 0, 4));
    printf "State Manipulate: %08x\n", $apiNumber;

    if ( $apiNumber == $DbgKdWriteBreakPointApi ) {
        my $bp = sprintf( "%08x", unpack( "I", substr( $buf, 16, 4 ) ) );
        my $handle = unpack( "I", substr( $buf, 20, 4 ) );
        print "Breakpoint $handle set at $bp\n";
        $breakpoints{$bp} = $handle;
    }
    elsif ( $apiNumber == $DbgKdRestoreBreakPointApi ) {
        my $handle = unpack( "I", substr( $buf, 16, 4 ) );
        print "Breakpoint $handle cleared\n";
    }
    elsif ( $apiNumber == $DbgKdGetVersionApi ) {
        my $version = substr( $buf, 16 );
        print "VERS: ", hexformat($version) unless $quiet;
    }
    elsif ( $apiNumber == $DbgKdReadVirtualMemoryApi ) {
        my $vmem = substr( $buf, 56 );
        print "VMEM:\n", hexasc($vmem) unless $quiet;
    }
    elsif ( $apiNumber == $DbgKdReadPhysicalMemoryApi ) {
        my $pmem = substr( $buf, 56 );
        print "PMEM:\n", hexasc($pmem) unless $quiet;
    }
    elsif ( $apiNumber == $DbgKdReadControlSpaceApi ) {
        $controlspace = substr( $buf, 56 );
        print "CNTL: ", hexformat($controlspace) unless $quiet;
    }
    else {
        print "UNKN: ", hexasc($buf) unless $quiet;
    }
}










sub packetHeader {
    my $d      = shift;
    my $header = "\x30\x30\x30\x30" .    # packet leader
      "\x02\x00" .    # packet type PACKET_TYPE_KD_STATE_MANIPULATE
      pack( "S", length($d) ) .    # sizeof data
      pack( "I", $nextpid ) .      # packet id
      pack( "I", cksum($d) );      # checksum of data
    return $header;
}

sub sendAck {
    my $ack =
      "\x69\x69\x69\x69\x04\x00\x00\x00\x00\x00\x80\x80\x00\x00\x00\x00";
    substr( $ack, 8, 4 ) = pack( "I", $nextpid );

    #print hexformat($ack);
    writeDev($ack);
}

sub sendReset {
    my $rst =
      "\x69\x69\x69\x69\x06\x00\x00\x00\x00\x00\x80\x80\x00\x00\x00\x00";

    # print "Sending reset packet\n";
    # print hexformat($rst);
    writeDev($rst);
}


sub getContext {
    my %context;
    sendDbgKdGetContext();
    my $buf = waitStateManipulate($DbgKdGetContextApi);
    if ( length($buf) > 204 ) {
        my $ctx = substr( $buf, 56 );

        #print "CTXT: ", hexformat($context);
        $context{'ContextFlags'}     = unpack( "I", substr( $ctx, 0,  4 ) );
        $context{'DR0'}              = unpack( "I", substr( $ctx, 4,  4 ) );
        $context{'DR1'}              = unpack( "I", substr( $ctx, 8,  4 ) );
        $context{'DR2'}              = unpack( "I", substr( $ctx, 12, 4 ) );
        $context{'DR3'}              = unpack( "I", substr( $ctx, 16, 4 ) );
        $context{'DR6'}              = unpack( "I", substr( $ctx, 20, 4 ) );
        $context{'DR7'}              = unpack( "I", substr( $ctx, 24, 4 ) );
        $context{'fp.ControlWord'}   = unpack( "I", substr( $ctx, 28, 4 ) );
        $context{'fp.StatusWord'}    = unpack( "I", substr( $ctx, 32, 4 ) );
        $context{'fp.TagWord'}       = unpack( "I", substr( $ctx, 36, 4 ) );
        $context{'fp.ErrorOffset'}   = unpack( "I", substr( $ctx, 40, 4 ) );
        $context{'fp.ErrorSelector'} = unpack( "I", substr( $ctx, 44, 4 ) );
        $context{'fp.DataOffset'}    = unpack( "I", substr( $ctx, 48, 4 ) );
        $context{'fp.DataSelector'}  = unpack( "I", substr( $ctx, 52, 4 ) );
        $context{'fp.RegisterArea'} = substr( $ctx, 56, 80 );
        $context{'fp.Cr0NpxState'} = unpack( "I", substr( $ctx, 136, 4 ) );
        $context{'GS'}             = unpack( "I", substr( $ctx, 140, 4 ) );
        $context{'FS'}             = unpack( "I", substr( $ctx, 144, 4 ) );
        $context{'ES'}             = unpack( "I", substr( $ctx, 148, 4 ) );
        $context{'DS'}             = unpack( "I", substr( $ctx, 152, 4 ) );
        $context{'EDI'}            = unpack( "I", substr( $ctx, 156, 4 ) );
        $context{'ESI'}            = unpack( "I", substr( $ctx, 160, 4 ) );
        $context{'EBX'}            = unpack( "I", substr( $ctx, 164, 4 ) );
        $context{'EDX'}            = unpack( "I", substr( $ctx, 168, 4 ) );
        $context{'ECX'}            = unpack( "I", substr( $ctx, 172, 4 ) );
        $context{'EAX'}            = unpack( "I", substr( $ctx, 176, 4 ) );
        $context{'EBP'}            = unpack( "I", substr( $ctx, 180, 4 ) );
        $context{'EIP'}            = unpack( "I", substr( $ctx, 184, 4 ) );
        $context{'CS'}             = unpack( "I", substr( $ctx, 188, 4 ) );
        $context{'Eflags'}         = unpack( "I", substr( $ctx, 192, 4 ) );
        $context{'ESP'}            = unpack( "I", substr( $ctx, 196, 4 ) );
        $context{'SS'}             = unpack( "I", substr( $ctx, 200, 4 ) );
        $context{'leftovers'} = substr( $ctx, 204 );
        return %context;
    }
}

sub setContext {
    my %context = @_;
    my $ctx = pack( "I", $context{'ContextFlags'} );
    $ctx .= pack( "I", $context{'DR0'} );
    $ctx .= pack( "I", $context{'DR1'} );
    $ctx .= pack( "I", $context{'DR2'} );
    $ctx .= pack( "I", $context{'DR3'} );
    $ctx .= pack( "I", $context{'DR6'} );
    $ctx .= pack( "I", $context{'DR7'} );
    $ctx .= pack( "I", $context{'fp.ControlWord'} );
    $ctx .= pack( "I", $context{'fp.StatusWord'} );
    $ctx .= pack( "I", $context{'fp.TagWord'} );
    $ctx .= pack( "I", $context{'fp.ErrorOffset'} );
    $ctx .= pack( "I", $context{'fp.ErrorSelector'} );
    $ctx .= pack( "I", $context{'fp.DataOffset'} );
    $ctx .= pack( "I", $context{'fp.DataSelector'} );
    $ctx .= $context{'fp.RegisterArea'};
    $ctx .= pack( "I", $context{'fp.Cr0NpxState'} );
    $ctx .= pack( "I", $context{'GS'} );
    $ctx .= pack( "I", $context{'FS'} );
    $ctx .= pack( "I", $context{'ES'} );
    $ctx .= pack( "I", $context{'DS'} );
    $ctx .= pack( "I", $context{'EDI'} );
    $ctx .= pack( "I", $context{'ESI'} );
    $ctx .= pack( "I", $context{'EBX'} );
    $ctx .= pack( "I", $context{'EDX'} );
    $ctx .= pack( "I", $context{'ECX'} );
    $ctx .= pack( "I", $context{'EAX'} );
    $ctx .= pack( "I", $context{'EBP'} );
    $ctx .= pack( "I", $context{'EIP'} );
    $ctx .= pack( "I", $context{'CS'} );
    $ctx .= pack( "I", $context{'Eflags'} );
    $ctx .= pack( "I", $context{'ESP'} );
    $ctx .= pack( "I", $context{'SS'} );
    $ctx .= $context{'leftovers'};
    sendDbgKdSetContext($ctx);
    waitStateManipulate($DbgKdSetContextApi);
}

sub getVersionInfo {
    print "getVersionInfo\n";
    # os version, protocol version, kernel base, module list, debugger data
    sendDbgKdGetVersion();
    my $buf = waitStateManipulate($DbgKdGetVersionApi);
    if ( length($buf) > 32 ) {
        my $v = substr( $buf, 16 );
        my $osv = sprintf "%d.%d", unpack( "S", substr( $v, 4, 2 ) ),
          unpack( "S", substr( $v, 6, 2 ) );
        my $pv          = unpack( "S", substr( $v, 8,  2 ) );
        my $machinetype = unpack( "S", substr( $v, 12, 2 ) );
        my $kernbase    = unpack( "I", substr( $v, 16, 4 ) );
        my $modlist     = unpack( "I", substr( $v, 24, 4 ) );
        my $ddata       = unpack( "I", substr( $v, 32, 4 ) );
        if ( $pv < 5 ) {
            printf "Debug protocol version %d not supported\n", $pv;
            exit;
        }
        if ( $machinetype && ( $machinetype != 0x2d ) ) {
            printf "Processor architecture %04x not supported\n", $machinetype;
            exit;
        }

        printf "Windows version = %s\n",  $osv;
        printf "Protocol version = %d\n", $pv;
        printf "Kernel base = %08x\n",    $kernbase;
        printf "Module list = %08x\n",    $modlist;
        printf "Debugger data = %08x\n",  $ddata;

        return ( $osv, $pv, $kernbase, $modlist, $ddata );
    }
    return ( "0.0", 0, 0, 0, 0 );
}

sub printVersionData {
    my @v = getVersionInfo();
    printf "Windows version = %s\n",  $v[0];
    printf "Protocol version = %d\n", $v[1];
    printf "Kernel base = %08x\n",    $v[2];
    printf "Module list = %08x\n",    $v[3];
    printf "Debugger data = %08x\n",  $v[4];
}

sub getKernelModules {
    my $save = $pcontext;
    $pcontext = \%kernelcontext;    # this procedure is kernel context only
    my %modules;
    my @v       = getVersionInfo();
    my $flink   = readDword( $v[3] );
    my @modlist = walkList($flink);
    for my $mod (@modlist) {

        #printf "module at %08x\n", $mod;
        my $buf = readVirtualMemory( $mod, 0x34 );
        if ( length($buf) == 0x34 ) {
            my $base = unpack( "I", substr( $buf, 0x18, 4 ) );
            next if $base == 0;
            my $entry = unpack( "I", substr( $buf, 0x1c, 4 ) );
            my $size = unpack( "I", substr( $buf, 0x20, 4 ) );
            my $path = substr( $buf, 0x24, 8 );
            my $name = substr( $buf, 0x2c, 8 );
            $modules{$base}{'name'}  = unicodeStructToAscii($name);
            $modules{$base}{'path'}  = unicodeStructToAscii($path);
            $modules{$base}{'size'}  = $size;
            $modules{$base}{'entry'} = $entry;
        }
    }
    $pcontext = $save;
    return %modules;
}

sub unicodeStructToAscii {
    my $struct = shift;
    return if length($struct) != 8;
    my $len = unpack( "S", substr( $struct, 0, 2 ) );
    my $vaddr = unpack( "I", substr( $struct, 4, 4 ) );
    my $buf = readVirtualMemory( $vaddr, $len );
    if ( length($buf) == $len ) {
        $buf =~ s/\x00//g;    # ok not really Unicode to Ascii
        return $buf;
    }
}

sub hexasc {
    my $buf = shift;
    my $len = length($buf);
    return unless $len;
    my $count = 0;
    my $ascii;
    my $out = "0000  ";
    for ( split( //, $buf ) ) {
        my $c = ord;
        $out .= sprintf( "%02x ", $c );
        if ( ( $c > 0x1f ) && ( $c < 0x7f ) ) {
            $ascii .= $_;
        }
        else {
            $ascii .= ".";
        }
        unless ( ++$count % 16 ) {
            if ( $count < $len ) {
                $out .= sprintf( " %s\n%04x  ", $ascii, $count );
            }
            else {
                $out .= sprintf( " %s\n", $ascii );
            }
            $ascii = "";
        }
    }
    if ($ascii) {
        my $padding = 48 - ( ( $count % 16 ) * 3 );
        $out .= " " x $padding;
        $out .= " $ascii\n";
    }
    return $out;
}

sub sendManipulateStatePacket {
    my $d = shift;
    my $h = packetHeader($d);

    #print "SEND: ", hexformat($h),
    #       hexformat($d);
    writeDev($h);
    writeDev($d);
    writeDev("\xaa");
}

sub sendDbgKdContinue2 {

    #print "Sending DbgKdContinue2Api packet\n";
    my $d = "\x00" x 56;
    substr( $d, 0,  4 ) = pack( "I", $DbgKdContinueApi2 );
    substr( $d, 8,  4 ) = pack( "I", 0x00010001 );
    substr( $d, 16, 4 ) = pack( "I", 0x00010001 );
    substr( $d, 24, 4 ) = pack( "I", 0x400 );        # TraceFlag
    substr( $d, 28, 4 ) = pack( "I", 0x01 );         # Dr7
    sendManipulateStatePacket($d);
}

sub sendDbgKdGetVersion {

    #print "Sending DbgKdGetVersionApi packet\n";
    my $d = "\x00" x 56;
    substr( $d, 0, 4 ) = pack( "I", $DbgKdGetVersionApi );
    sendManipulateStatePacket($d);
}

sub sendDbgKdWriteBreakPoint {
    my $bp = hex(shift);

    #print "Sending DbgKdWriteBreakPointApi packet\n";
    my $d = "\x00" x 56;
    substr( $d, 0,  4 ) = pack( "I", $DbgKdWriteBreakPointApi );
    substr( $d, 16, 4 ) = pack( "I", $bp );
    substr( $d, 20, 4 ) = pack( "I", $curbp++ );
    sendManipulateStatePacket($d);
}

sub sendDbgKdRestoreBreakPoint {
    my $bp = shift;
    if ( defined( $breakpoints{$bp} ) ) {

        #print "Sending DbgKdRestoreBreakPointApi packet\n";
        my $d = "\x00" x 56;
        substr( $d, 0,  4 ) = pack( "I", $DbgKdRestoreBreakPointApi );
        substr( $d, 16, 4 ) = pack( "I", $breakpoints{$bp} );
        sendManipulateStatePacket($d);
        delete( $breakpoints{$bp} );
    }
    else {
        print "Breakpoint not set at $bp\n";
    }
}

sub sendDbgKdReadControlSpace {

    #print "Sending DbgKdReadControlSpaceApi packet\n";
    my $d = "\x00" x 56;
    substr( $d, 0,  4 ) = pack( "I", 0x3137 );
    substr( $d, 16, 4 ) = pack( "I", 0x02cc );
    substr( $d, 24, 4 ) = pack( "I", 84 );
    sendManipulateStatePacket($d);
}

sub sendDbgKdWriteControlSpace {

    #print "Sending DbgKdWriteControlSpaceApi packet\n";
    my $d = "\x00" x 56;
    substr( $d, 0,  4 ) = pack( "I", 0x3138 );
    substr( $d, 16, 4 ) = pack( "I", 0x02cc );
    substr( $d, 24, 4 ) = pack( "I", 84 );
    $d .= $controlspace;
    sendManipulateStatePacket($d);
    $controlspacesent = 1;
}

sub sendDbgKdGetContext {

    #print "Sending DbgKdGetContextApi packet\n";
    my $d = "\x00" x 56;
    substr( $d, 0, 4 ) = pack( "I", $DbgKdGetContextApi );
    sendManipulateStatePacket($d);
}

sub sendDbgKdSetContext {
    my $ctx = shift;

    #print "Sending DbgKdSetContextApi packet\n";
    my $d = "\x00" x 56;
    substr( $d, 0, 4 ) = pack( "I", $DbgKdSetContextApi );
    substr( $d, 16, 4 ) = substr( $ctx, 0, 4 );
    $d .= $ctx;
    sendManipulateStatePacket($d);
}

sub sendDbgKdReadPhysicalMemory {
    my $addr    = shift;
    my $readlen = shift;

    #print "Sending DbgKdReadPhysicalMemoryApi packet\n";
    my $d = "\x00" x 56;
    substr( $d, 0,  4 ) = pack( "I", $DbgKdReadPhysicalMemoryApi );
    substr( $d, 16, 4 ) = pack( "I", $addr );
    substr( $d, 24, 4 ) = pack( "I", $readlen );
    sendManipulateStatePacket($d);
}

sub sendDbgKdReadVirtualMemory {
    my $vaddr   = shift;
    my $readlen = shift;

    #print "Sending DbgKdReadVirtualMemoryApi packet\n";
    my $d = "\x00" x 56;
    substr( $d, 0,  4 ) = pack( "I", $DbgKdReadVirtualMemoryApi );
    substr( $d, 16, 4 ) = pack( "I", $vaddr );
    substr( $d, 24, 4 ) = pack( "I", $readlen );
    sendManipulateStatePacket($d);
}

sub sendDbgKdWriteVirtualMemory {
    my $vaddr    = shift;
    my $data     = shift;
    my $writelen = length($data);

    #print "Sending DbgKdWriteVirtualMemoryApi packet\n";
    my $d = "\x00" x 56;
    substr( $d, 0,  4 ) = pack( "I", $DbgKdWriteVirtualMemoryApi );
    substr( $d, 16, 4 ) = pack( "I", $vaddr );
    substr( $d, 24, 4 ) = pack( "I", $writelen );
    $d .= $data;
    sendManipulateStatePacket($d);
}

sub readDword {
    my $addr = shift;

    #print "Reading dword at %08x\n", $addr;
    my $buf = readVirtualMemory( $addr, 4 );
    if ( length($buf) == 4 ) {
        return unpack( "I", $buf );
    }
    return "failed";
}

sub readPhysicalMemory {
    my $addr      = shift;
    my $len       = shift;
    my $chunksize = 0x800;    # max to request in one packet
    my $out;
    while ( $len > 0 ) {

        if ( $len < $chunksize ) {
            sendDbgKdReadPhysicalMemory( $addr, $len );
            my $buf = waitStateManipulate($DbgKdReadPhysicalMemoryApi);
            if ( length($buf) > 56 ) {
                $out .= substr( $buf, 56 );
            }
            $len = 0;
        }
        else {
            sendDbgKdReadPhysicalMemory( $addr, $chunksize );
            my $buf = waitStateManipulate($DbgKdReadPhysicalMemoryApi);
            if ( length($buf) > 56 ) {
                $out .= substr( $buf, 56 );
            }
            $len -= $chunksize;
            $addr += $chunksize;
        }
    }
    return $out;
}

sub writePhysicalMemory {
    my $addr      = shift;
    my $buf       = shift;
    my $len       = length($buf);
    my $chunksize = 0x800;          # max to send in one packet
    my $offset    = 0;
    while ( $len > 0 ) {

        if ( $len < $chunksize ) {
            sendDbgKdWritePhysicalMemory( $addr, $buf );
            waitStateManipulate(0x313e);
            $len = 0;
        }
        else {
            sendDbgKdWritePhysicalMemory( $addr,
                substr( $buf, $offset, $chunksize ) );
            waitStateManipulate(0x313e);
            $len -= $chunksize;
            $offset += $chunksize;
            $addr   += $chunksize;
        }
    }
    return;
}

sub writeVirtualMemory {
    my $addr = shift;
    my $buf  = shift;
    my $len  = length($buf);
    return unless $addr && $len;
    my $chunksize = 0x800;    # max to send in one packet
    my $offset    = 0;
    if ( $pcontext->{'pid'} == 0 ) {
        while ( $len > 0 ) {

            if ( $len < $chunksize ) {
                sendDbgKdWriteVirtualMemory( $addr, $buf );
                waitStateManipulate($DbgKdWriteVirtualMemoryApi);
                $len = 0;
            }
            else {
                sendDbgKdWriteVirtualMemory( $addr,
                    substr( $buf, $offset, $chunksize ) );
                waitStateManipulate($DbgKdWriteVirtualMemoryApi);
                $len -= $chunksize;
                $offset += $chunksize;
                $addr   += $chunksize;
            }
        }
    }
    else {
        my $distance_to_page_boundary = 0x1000 - ( $addr & 0xfff );
        if ( $distance_to_page_boundary > $len ) {
            my $physaddr = logical2physical($addr);
            writePhysicalMemory( $physaddr, $buf );
            return;
        }
        else {
            my $physaddr = logical2physical($addr);
            $buf =
              writePhysicalMemory( $physaddr,
                substr( $buf, 0, $distance_to_page_boundary ) );
            $addr   += $distance_to_page_boundary;
            $offset += $distance_to_page_boundary;
            my $remainder = $len - $distance_to_page_boundary;

            while ( $remainder > 0 ) {
                if ( $remainder < 0x1000 ) {
                    my $physaddr = logical2physical($addr);
                    writePhysicalMemory( $physaddr,
                        substr( $buf, $offset, $remainder ) );
                    $remainder = 0;
                }
                else {
                    my $physaddr = logical2physical($addr);
                    writePhysicalMemory( $physaddr,
                        substr( $buf, $offset, 0x1000 ) );
                    $addr   += 0x1000;
                    $offset += 0x1000;
                    $remainder -= 0x1000;
                }
            }
            return;
        }

    }
}

sub readVirtualMemory {
    my $addr = shift;
    my $len  = shift;
    return unless $addr && $len;
    my $chunksize = 0x800;    # max to request in one packet
    my $out;
    my $buf;
    if ( $pcontext->{'pid'} == 0 ) {
        while ( $len > 0 ) {

            if ( $len < $chunksize ) {
                sendDbgKdReadVirtualMemory( $addr, $len );
                $buf = waitStateManipulate($DbgKdReadVirtualMemoryApi);
                if ( length($buf) > 56 ) {
                    $out .= substr( $buf, 56 );
                }
                $len = 0;
            }
            else {
                sendDbgKdReadVirtualMemory( $addr, $chunksize );
                $buf = waitStateManipulate($DbgKdReadVirtualMemoryApi);
                if ( length($buf) > 56 ) {
                    $out .= substr( $buf, 56 );
                }
                $len -= $chunksize;
                $addr += $chunksize;
            }
        }
        return $out;
    }
    else {
        my $distance_to_page_boundary = 0x1000 - ( $addr & 0xfff );
        if ( $distance_to_page_boundary > $len ) {
            my $physaddr = logical2physical($addr);
            return readPhysicalMemory( $physaddr, $len );
        }
        else {
            my $physaddr = logical2physical($addr);
            $buf = readPhysicalMemory( $physaddr, $distance_to_page_boundary );
            $addr += $distance_to_page_boundary;
            my $remainder = $len - $distance_to_page_boundary;
            while ( $remainder > 0 ) {
                if ( $remainder < 0x1000 ) {
                    my $physaddr = logical2physical($addr);
                    $buf .= readPhysicalMemory( $physaddr, $remainder );
                    $remainder = 0;
                }
                else {
                    my $physaddr = logical2physical($addr);
                    $buf .= readPhysicalMemory( $physaddr, 0x1000 );
                    $addr += 0x1000;
                    $remainder -= 0x1000;
                }
            }
            return $buf;
        }

    }
}

sub sendDbgKdReboot {
    print "Sending DbgKdRebootApi packet\n";
    my $d = "\x00" x 56;
    substr( $d, 0, 4 ) = pack( "I", 0x313b );
    sendManipulateStatePacket($d);
}


sub waitStateManipulate {
    return if $running;
    my $wanted = shift;
    my $quiet = shift;
    
    my $ptype;
    my $buf;
    alarm($timeout);
    eval {
        while (1) {
            ($ptype, $buf) = handlePacket(1);
            if ($ptype == $PACKET_TYPE_KD_STATE_MANIPULATE) {
                my $api = unpack( "I", substr( $buf, 0, 4 ) );
                if ($api == $wanted) {
                    last;
                }
            }
        }
    };
    alarm(0);
    if ($@) {
        if ( $@ !~ /timeout/ ) {
            die "Fatal: $@\n";
        }
        else {
            printf "Timeout waiting for %04x packet reply\n", $wanted;
        }
    }
    return $buf;
}

sub getPspCidTable {
    my $pspcidtable = 0;
    my $save        = $pcontext;
    $pcontext = \%kernelcontext;    # this procedure is kernel context only
    sendDbgKdGetVersion();
    my $buf = waitStateManipulate($DbgKdGetVersionApi);
    my $pddata = unpack( "I", substr( $buf, 48, 4 ) );
    if ($pddata) {

        #printf "Pointer to debugger data struct is at %08x\n", $pddata;
        my $ddata = readDword($pddata);
        if ( $ddata ne "failed" ) {

            #printf "debugger data struct is at %08x\n", $ddata;
            $pspcidtable = readDword( $ddata + 88 );
            if ( $pspcidtable ne "failed" ) {

                #printf "PspCidTable is %08x\n", $pspcidtable;
                $pcontext = $save;
                return $pspcidtable;
            }
        }
    }
    $pcontext = $save;
    return 0;
}

sub getEprocess {
    my $pid  = shift;
    my $j    = ( $pid >> 18 ) & 0xff;
    my $k    = ( $pid >> 10 ) & 0xff;
    my $l    = ( $pid >> 2 ) & 0xff;
    my $save = $pcontext;
    $pcontext = \%kernelcontext;    # this procedure is kernel context only
                                    #print "Finding eprocess[$j][$k][$l]\n";
    my $pspcidtable = getPspCidTable();

    if ($pspcidtable) {
        my $subtable;
        if ( $version >= 6.0 ) {
            $subtable = readDword($pspcidtable);
        }
        else {
            my $table;
            my $ptable = readDword($pspcidtable);
            if ( $ptable ne "failed" ) {

                #printf "ptable: %08x\n", $ptable;
                $table = readDword( $ptable + 8 );
            }
            if ( $table ne "failed" ) {

                #printf "table: %08x\n", $table;
                $subtable = readDword( $table + ( $j * 4 ) );
            }
        }
        if ( ($subtable) && ( $subtable ne "failed" ) ) {

            #printf "subtable: %08x\n", $subtable;
            my $subsubtable = readDword( $subtable + ( $k * 4 ) );
            if ( $subsubtable ne "failed" ) {

                #printf "subsubtable: %08x\n", $subsubtable;
                my $entry = readDword( $subsubtable + ( $l * 8 ) );
                if ( $entry ne "failed" ) {
                    if ( $version < 6 ) {
                        $entry |= 0x80000000;    # lock bit
                    }
                    else {
                        $entry &= 0xfffffffe;    # lock bit
                    }

                  #printf "eprocess of pid 0x%x starts at %08x\n", $pid, $entry;
                    $pcontext = $save;
                    return $entry;
                }
            }
        }
    }
    $pcontext = $save;
    return 0;
}

sub getProcessList {
    my $ep;
    my %prochash;
    my ( $listoffset, $pidoffset, $nameoffset, $timeoffset );
    my ( $threadoffset, $peboffset, $dtboffset );
    my $save = $pcontext;
    $pcontext = \%kernelcontext;    # this procedure is kernel context only
    if ( $version >= 6.0 ) {

        # xp, vista
        $ep           = getEprocess(4);
        $listoffset   = 0x88;
        $pidoffset    = 0x84;
        $nameoffset   = 0x174;
        $timeoffset   = 0x70;
        $threadoffset = 0x1b0;
        $peboffset    = 0x1b0;
        $dtboffset    = 0x18;
    }
    else {

        # win2k
        $ep           = getEprocess(8);
        $listoffset   = 0xa0;
        $pidoffset    = 0x9c;
        $nameoffset   = 0x1fc;
        $timeoffset   = 0x88;
        $threadoffset = 0x1a4;
        $peboffset    = 0x1b0;
        $dtboffset    = 0x18;
    }

    #printf "System ep: %08x\n", $ep;
    unless ($ep) { $pcontext = $save; return }
    my @procs = walkList( $ep + $listoffset, $listoffset );
    for my $eproc (@procs) {
        my $e = readVirtualMemory( $eproc, 0x21c );
        if ( length($e) == 0x21c ) {

            #print hexformat($e);
            my $name = substr( $e, $nameoffset, 16 );
            $name =~ s/\x00//g;
            my $pid = unpack( "I", substr( $e, $pidoffset, 4 ) );
            next unless ($pid) && ( $pid < 0xffff );
            my $dtb = unpack( "I", substr( $e, $dtboffset, 4 ) );
            my $peb = unpack( "I", substr( $e, $peboffset, 4 ) );
            my $created = ft2Time( substr( $e, $timeoffset, 8 ) );

            my @threads =
              walkList( unpack( "I", substr( $e, 0x50, 4 ) ), $threadoffset );
            if (@threads) {
                $prochash{$eproc}{'pid'}     = $pid;
                $prochash{$eproc}{'name'}    = $name;
                $prochash{$eproc}{'created'} = $created;
                $prochash{$eproc}{'dtb'}     = $dtb;
                $prochash{$eproc}{'peb'}     = $peb;
                @{ $prochash{$eproc}{'threads'} } = @threads;
            }
        }
    }
    $pcontext = $save;
    return %prochash;
}

sub ft2Time {
    my $ft = shift;
    return 0 unless length($ft) == 8;
    my $ch = 0x019db1de;
    my $cl = 0xd53e8000;
    my $lo = unpack( "I", substr( $ft, 0, 4 ) );
    my $hi = unpack( "I", substr( $ft, 4, 4 ) );
    return 0 if ( $hi < $ch ) || ( ( $hi == $ch ) && ( $lo < $cl ) );
    return ( ( ( ( $hi * 0x10000 ) * 0x10000 ) + $lo ) -
          ( ( ( $ch * 0x10000 ) * 0x10000 ) + $cl ) ) / 10000000;
}

sub walkList {
    my @ret;
    my $flink  = shift;    # address of LIST_ENTRY in struct
    my $offset = shift;    # offset to LIST_ENTRY from beginning of struct
    my $top    = $flink;
    while ( $flink != 0 ) {
        push( @ret, $flink - $offset );
        $flink = readDword($flink);
        last if ( $flink == $top ) || ( $flink eq "failed" );
    }
    return @ret;
}

sub injectSUSShellcode {
    my $title     = shift;
    my $message   = shift;
    my $userbase  = 0x7ffe0800;
    my $ring0base = 0xffdf0800;
    my $save      = $pcontext;
    $pcontext = \%kernelcontext;    # this procedure is kernel context only
    my $messageboxa = getProcAddress( "user32.dll", "MessageBoxA" );

    my $sc =
        "\x6a\x00\x68\x00\x00\x00\x00\x68\x00\x00\x00\x00"
      . "\x6A\x00\xE8\x00\x00\x00\x00\xc3$title\x00$message\x00";
    substr( $sc, 3,  4 ) = pack( "I", $userbase + 20 );
    substr( $sc, 8,  4 ) = pack( "I", $userbase + 21 + length($title) );
    substr( $sc, 15, 4 ) = pack( "I", $messageboxa - ( $userbase + 19 ) );

    writeVirtualMemory( $ring0base, $sc );
    printf "Shellcode injected at %08x (%08x)\n", $ring0base, $userbase;
    $pcontext = $save;
}

sub insertApc {
    print "Searching for thread in explorer.exe\n";
    my %procs = getProcessList();
    my $thread;
    for ( sort keys %procs ) {
        my $n = lc( $procs{$_}{'name'} );
        print "Found $n\n";
        if ( $n eq "explorer.exe" ) {

            #printf "Found explorer.exe\n";
            $thread = shift( @{ $procs{$_}{'threads'} } );
            last;
        }
    }
    unless ($thread) {
        print "Failed to find thread\n";
        return;
    }
    printf "Using thread object at %08x\n", $thread;
    my $kernelret = findRet();
    my $shellcode = 0x7ffe0800;
    my $apc       = "\x00" x 48;
    my $putme     = 0xffdf0900;
    my $save      = $pcontext;
    $pcontext = \%kernelcontext;    # this procedure is kernel context only
    substr( $apc, 0,  2 ) = pack( "S", 0x12 );       # type = Apc object
    substr( $apc, 2,  2 ) = pack( "S", 0x30 );       # size of object = 48 bytes
    substr( $apc, 8,  4 ) = pack( "I", $thread );    # ethread ptr
    substr( $apc, 20, 4 ) = pack( "I", $kernelret ); # ret command in kernel
    substr( $apc, 28, 4 ) = pack( "I", $shellcode ); # shellcode vaddr
    substr( $apc, 36, 4 ) = pack( "I", $putme + 0x50 );    # system arg 1
    substr( $apc, 40, 4 ) = pack( "I", $putme + 0x54 );    # system arg 2
    substr( $apc, 46, 1 ) = "\x01";    # Apc mode = user mode
    substr( $apc, 47, 1 ) = "\x01";    # Inserted = true (well, it will be)

    printf "Built APC object for thread at %08x\n", $thread;

    #print hexformat($apc);
    printf "Inserting into APC list at %08x\n", $thread + 0x3c;
    my $oldflink = readDword( $thread + 0x3c );
    printf "Replacing old Apc flink: %08x\n", $oldflink;
    if ( $oldflink ne "failed" ) {
        substr( $apc, 12, 4 ) = pack( "I", $oldflink );         # flink
        substr( $apc, 16, 4 ) = pack( "I", $thread + 0x3c );    # blink

        # write APC object to SharedUserSpace
        writeVirtualMemory( $putme, $apc );

        # insert our APC into the list
        writeVirtualMemory( $thread + 0x3c, pack( "I", $putme + 12 ) );

        # set UserApcPending = TRUE
        writeVirtualMemory( $thread + 0x4a, "\x01" );
        printf "Inserted APC into thread at %08x\n", $thread;
    }
    else {
        print "Failed to insert APC\n";
    }
    $pcontext = $save;
}

sub parsePE {

    # Some PE parsing code borrowed from Metasploit PE module
    my %pe_hdr;
    my $crap;
    my $base = shift;
    my $data = readVirtualMemory( $base, 0x800 );
    $data .= readVirtualMemory( $base + 0x800, 0x800 );

    #printf "Read %d bytes of PE header at %08x\n", length($data),$base;
    return unless length($data) == 0x1000;

    return unless substr( $data, 0, 2 ) eq "MZ";
    my $peo = unpack( "I", substr( $data, 0x3c, 4 ) );
    return unless substr( $data, $peo, 2 ) eq "PE";

    $pe_hdr{"MachineID"}            = unpack( "S", substr( $data, $peo + 4 ) );
    $pe_hdr{"NumberOfSections"}     = unpack( "S", substr( $data, $peo + 6 ) );
    $pe_hdr{"TimeDateStamp"}        = unpack( "L", substr( $data, $peo + 8 ) );
    $pe_hdr{"PointerToSymbolTable"} = unpack( "L", substr( $data, $peo + 12 ) );
    $pe_hdr{"NumberOfSymbols"}      = unpack( "L", substr( $data, $peo + 16 ) );
    $pe_hdr{"SizeOfOptionalHeader"} = unpack( "S", substr( $data, $peo + 20 ) );
    $pe_hdr{"Characteristics"}      = unpack( "S", substr( $data, $peo + 22 ) );

    if ( $pe_hdr{"SizeOfOptionalHeader"} < 224 ) {
        return 0;
    }
    my $opthdr = substr( $data, $peo + 24, $pe_hdr{"SizeOfOptionalHeader"} );
    $pe_hdr{"Magic "}              = unpack( "S", substr( $opthdr, 0 ) );
    $pe_hdr{"MajorLinker"}         = unpack( "C", substr( $opthdr, 2 ) );
    $pe_hdr{"MinorLinker"}         = unpack( "C", substr( $opthdr, 3 ) );
    $pe_hdr{"SizeOfCode"}          = unpack( "L", substr( $opthdr, 4 ) );
    $pe_hdr{"SizeOfInitialized"}   = unpack( "L", substr( $opthdr, 8 ) );
    $pe_hdr{"SizeOfUninitialized"} = unpack( "L", substr( $opthdr, 12 ) );

    $pe_hdr{"EntryPoint"} = unpack( "L", substr( $opthdr, 16 ) );
    $pe_hdr{"BaseOfCode"} = unpack( "L", substr( $opthdr, 20 ) );
    $pe_hdr{"BaseOfData"} = unpack( "L", substr( $opthdr, 24 ) );

    $pe_hdr{"ImageBase"}    = unpack( "L", substr( $opthdr, 28 ) );
    $pe_hdr{"SectionAlign"} = unpack( "L", substr( $opthdr, 32 ) );
    $pe_hdr{"FileAlign"}    = unpack( "L", substr( $opthdr, 36 ) );

    $pe_hdr{"MajorOS"}    = unpack( "S", substr( $opthdr, 38 ) );
    $pe_hdr{"MinorOS"}    = unpack( "S", substr( $opthdr, 40 ) );
    $pe_hdr{"MajorImage"} = unpack( "S", substr( $opthdr, 42 ) );
    $pe_hdr{"MinorImage"} = unpack( "S", substr( $opthdr, 44 ) );
    $pe_hdr{"MajorSub"}   = unpack( "S", substr( $opthdr, 46 ) );
    $pe_hdr{"MinorSub"}   = unpack( "S", substr( $opthdr, 48 ) );

    $pe_hdr{"Reserved"}            = unpack( "L", substr( $opthdr, 52 ) );
    $pe_hdr{"SizeOfImage"}         = unpack( "L", substr( $opthdr, 56 ) );
    $pe_hdr{"SizeOfHeaders"}       = unpack( "L", substr( $opthdr, 60 ) );
    $pe_hdr{"Checksum"}            = unpack( "L", substr( $opthdr, 64 ) );
    $pe_hdr{"Subsystem"}           = unpack( "S", substr( $opthdr, 68 ) );
    $pe_hdr{"DllCharacteristics"}  = unpack( "S", substr( $opthdr, 70 ) );
    $pe_hdr{"SizeOfStackReserve"}  = unpack( "L", substr( $opthdr, 72 ) );
    $pe_hdr{"SizeOfStackCommit"}   = unpack( "L", substr( $opthdr, 76 ) );
    $pe_hdr{"SizeOfHeapReserve"}   = unpack( "L", substr( $opthdr, 80 ) );
    $pe_hdr{"SizeOfHeapCommit"}    = unpack( "L", substr( $opthdr, 84 ) );
    $pe_hdr{"LoaderFlags"}         = unpack( "L", substr( $opthdr, 88 ) );
    $pe_hdr{"NumberOfRvaAndSizes"} = unpack( "L", substr( $opthdr, 92 ) );

    my @RVAMAP = qw(export import resource exception certificate basereloc
      debug archspec globalptr tls load_config boundimport importaddress
      delayimport comruntime none);

    # parse the rva data
    my $rva_data = substr( $opthdr, 96, $pe_hdr{"NumberOfRvaAndSizes"} * 8 );
    my %RVA;
    for ( my $x = 0 ; $x < $pe_hdr{"NumberOfRvaAndSizes"} ; $x++ ) {
        if ( !$RVAMAP[$x] ) { $RVAMAP[$x] = "unknown_$x" }
        $RVA{ $RVAMAP[$x] } = [
            unpack( "L", substr( $rva_data, ( $x * 8 ) ) ),
            unpack( "L", substr( $rva_data, ( $x * 8 ) + 4 ) ),
        ];
    }

    # parse the section headers
    my $sec_begn = $peo + 24 + $pe_hdr{"SizeOfOptionalHeader"};
    my $sec_data = substr( $data, $sec_begn );

    for ( my $x = 0 ; $x < $pe_hdr{"NumberOfSections"} ; $x++ ) {
        my $sec_head = $sec_begn + ( $x * 40 );
        my $sec_name = substr( $data, $sec_head, 8 );
        $sec_name =~ s/\x00//g;
        if ( $sec_name eq "" ) { $sec_name = ".sec$x" }

        #my $sec_name = ".sec$x";
        my $vsize   = unpack( "L", substr( $data, $sec_head + 8 ) );
        my $voffset = unpack( "L", substr( $data, $sec_head + 12 ) );
        my $rsize   = unpack( "L", substr( $data, $sec_head + 16 ) );
        my $roffset = unpack( "L", substr( $data, $sec_head + 20 ) );
        my $type;
        if    ( $voffset == $pe_hdr{"BaseOfCode"} ) { $type = "CODE" }
        elsif ( $voffset == $pe_hdr{"BaseOfData"} ) { $type = "DATA" }
        else                                        { $type = "UNKNOWN" }
    }
    $pe_hdr{'import'}     = $RVA{'import'}->[0];
    $pe_hdr{'export'}     = $RVA{'export'}->[0];
    $pe_hdr{'importsize'} = $RVA{'import'}->[1];
    $pe_hdr{'exportsize'} = $RVA{'export'}->[1];
    return %pe_hdr;
}

sub getImports {
    my $base    = shift;    # base address of module
    my $ioffset = shift;    # offset to import table
    my $size    = shift;    # size of import table
    my $crap;

    my $imports = readVirtualMemory( $base + $ioffset, $size );

    for ( my $i = 0 ; $i < $size ; $i += 20 ) {
        last if substr( $imports, $i, 20 ) eq "\x00" x 20;
        my $rvaILT         = unpack( "L", substr( $imports, $i,      4 ) );
        my $timestamp      = unpack( "L", substr( $imports, $i + 4,  4 ) );
        my $forwarderchain = unpack( "L", substr( $imports, $i + 8,  4 ) );
        my $rvaModuleName  = unpack( "L", substr( $imports, $i + 12, 4 ) );
        my $rvaIAT         = unpack( "L", substr( $imports, $i + 16, 4 ) );
        my $modname = readVirtualMemory( $base + $rvaModuleName );
        $modname =~ s/\x00.*//;

        if ($rvaILT) {
            my $count = 0;
            my $ibuf = readVirtualMemory( $base + $rvaILT, 4 );
          IGRAB: while ( $ibuf ne "\x00\x00\x00\x00" ) {
                my $importthunkRVA = unpack( "L", $ibuf );
                last IGRAB if $importthunkRVA == 0;

                if ( $importthunkRVA & 0x8000000 ) {
                    printf "ORD: 0x%x\n", $importthunkRVA & ~0x80000000;
                }
                else {
                    my $importname =
                      readVirtualMemory( $importthunkRVA & ~0x80000000, 255 );
                    $importname = substr( $importname, 2 );
                    ( $importname, $crap ) = split( /\x00/, $importname );
                    my $thunk = $base + $rvaIAT + ( $count * 4 );
                    my ( $mod, $suff ) = split( /\./, lc($modname) );
                    printf "%s (0x%x)\n", $importname, $thunk;
                }
                $count++;
                $ibuf =
                  readVirtualMemory( $base + ( $rvaILT + $count * 4 ), 4 );
            }    # end while
        }    # end if rvaILT
        else {
            my $count = 0;
            my $ibuf = readVirtualMemory( $base + $rvaIAT, 4 );
          IGRAB: while ( $ibuf ne "\x00\x00\x00\x00" ) {
                my $importthunkRVA = unpack( "L", $ibuf );
                last IGRAB if $importthunkRVA == 0;
                my $importname =
                  readVirtualMemory( $base + $importthunkRVA, 255 );
                $importname = substr( $importname, 2 );
                ( $importname, $crap ) = split( /\x00/, $importname );
                my $thunk = $base + $rvaIAT + ( $count * 4 );
                my ( $mod, $suff ) = split( /\./, lc($modname) );
                printf "%s (0x%x)\n", $importname, $thunk;

                $count++;
                $ibuf = readVirtualMemory( $base + $rvaIAT, 4 );
            }    # end while
        }    # end if rvaILT
    }    # end if import module
}

sub locateExportNameInTable {
    my $procname = shift;
    my $base     = shift;
    my $eoffset  = shift;
    my $size     = shift;
    my %exp      = getExports( $base, $eoffset, $size );
    for ( keys %exp ) {
        if ( $exp{$_} eq $procname ) {
            return $_;
        }
    }
}

sub getExports {
    my $base    = shift;
    my $eoffset = shift;
    my $size    = shift;
    my %exportlist;

    return unless $base && $eoffset && $size;
    my $exports = readVirtualMemory( $base + $eoffset, $size );

    my $ebase     = unpack( "I", substr( $exports, 16, 4 ) );
    my $enumfuncs = unpack( "I", substr( $exports, 20, 4 ) );
    my $enumnames = unpack( "I", substr( $exports, 24, 4 ) );
    my $EATrva    = unpack( "I", substr( $exports, 28, 4 ) );
    my $ENTrva    = unpack( "I", substr( $exports, 32, 4 ) );
    my $EOTrva    = unpack( "I", substr( $exports, 36, 4 ) );
    my ( @exportnames, @exportordinals, @exportfunctions );

    # get ascii name table boundaries
    my $nbegin   = readDword( $base + $ENTrva );
    my $nend     = readDword( $base + $ENTrva + ( ( $enumnames - 1 ) * 4 ) );
    my $lastname = readVirtualMemory( $nend + $base, 255 );
    my $term     = index( $lastname, "\x00" );
    $nend += $term;
    my $namebuf = readVirtualMemory( $nbegin + $base, $nend - $nbegin );

    #print hexasc($namebuf);

    my $nametable = readVirtualMemory( $ENTrva + $base, $enumnames * 4 );
    my $functable = readVirtualMemory( $EATrva + $base, $enumfuncs * 4 );
    my $ordtable  = readVirtualMemory( $EOTrva + $base, $enumfuncs * 2 );

    for ( 0 .. $enumnames - 1 ) {
        my $n = unpack( "L", substr( $nametable, $_ * 4, 4 ) );
        if ( $n >= $nbegin ) {
            my $ename = substr( $namebuf, $n - $nbegin, 255 );
            $ename =~ s/\x00.*//g;
            push( @exportnames, $ename );

            #printf "Adding name index %d (begins at %08x: raw %08x) %s\n",
            #$_, $n, $n-$nbegin, $ename;
        }
    }
    for ( 0 .. $enumfuncs - 1 ) {
        my $eord = unpack( "S", substr( $ordtable, $_ * 2, 2 ) );
        push( @exportordinals, $eord );
    }
    for ( 0 .. $enumfuncs - 1 ) {
        my $eaddr = unpack( "L", substr( $functable, $_ * 4, 4 ) );
        push( @exportfunctions, $eaddr );
    }

    for my $o ( 0 .. $#exportnames ) {
        my $name = $exportnames[$o];
        my $ord  = $exportordinals[$o];
        my $addr = $exportfunctions[$ord];
        $name ||= $ord;
        $exportlist{ $addr + $base } = $name;
    }
    return %exportlist;
}

sub findRet {
    my $hp;
    my $pos;
    my $save = $pcontext;
    $pcontext = \%kernelcontext;    # this procedure is kernel context only
    for ( 0 .. 100 ) {
        $hp = $_;
        my $buf =
          readVirtualMemory( $kernelbase + 0x1000 + ( $hp * 0x800 ), 0x800 );
        $pos = index( $buf, "\xc3" );
        last unless $pos == -1;
    }
    my $ret = $kernelbase + 0x1000 + ( $hp * 0x800 ) + $pos;
    printf "Found RETN instruction at %08x", $ret;
    $pcontext = $save;
    return $ret;
}

sub logical2physical {
    my $logical = shift;                # a virtual address in a process
    my $pdb     = $pcontext->{'dtb'};
    return unless $pdb;
    my $offset = $logical & 0xfff;                            # save byte offset
    my $pde    = ( $logical >> 22 ) & 0x3ff;
    my $pte    = ( $logical >> 12 ) & 0x3ff;
    my $buf    = readPhysicalMemory( $pdb + ( $pde * 4 ), 4 );
    my $valid  = unpack( "I", $buf ) & 0x1;
    if ($valid) {
        my $ptb = unpack( "I", $buf ) & 0xfffff000;

#printf "Seeking to PTB %08x + PTE %03x * 4 = %08x\n", $ptb, $pte, $ptb + ($pte * 4);
        $buf = readPhysicalMemory( $ptb + ( $pte * 4 ), 4 );
        $valid = unpack( "I", $buf ) & 0x1;
        if ($valid) {
            my $phys = unpack( "I", $buf ) & 0xfffff000;
            return ( $phys | $offset );    #restore byte offset
        }
    }
    printf "Invalid PTE found for va %08x: %08x\n", $logical,
      unpack( "I", $buf );
    return 0;
}

sub listExports {
    my $base = shift;
    my %pe   = parsePE($base);
    if ( $pe{'export'} && $pe{'exportsize'} ) {
        printf "Exports found in PE file at %08x:\n", $base;
        my %exp = getExports( $base, $pe{'export'}, $pe{'exportsize'} );
        for ( sort keys %exp ) {
            printf "%08x:%s\n", $_, $exp{$_};
        }
    }
    else {
        print "No export table found\n";
    }
}

sub getProcAddress {
    my $module   = shift;
    my $procname = shift;
    my $save     = $pcontext;
    my $addr;

    # get eprocess list, start with bottom process
    my %procs = getProcessList();
    for ( sort keys %procs ) {
        my $dtb      = $procs{$_}{'dtb'};
        my $peb      = $procs{$_}{'peb'};
        my $pid      = $procs{$_}{'pid'};
        my $eprocess = $_;
        next unless $peb;
        printf "Searching for %s in modules of pid %x (eprocess is %08x)\n",
          $procname, $pid, $eprocess;

        # set process context
        $processcontext{'dtb'}      = $dtb;
        $processcontext{'pid'}      = $pid;
        $processcontext{'peb'}      = $peb;
        $processcontext{'eprocess'} = $eprocess;

        $pcontext = \%processcontext;

        my %modules = getUserModules();
        for ( sort keys %modules ) {
            if (   ( $modules{$_}{'name'} =~ /^$module$/i )
                || ( $modules{$_}{'name'} =~ /^$module\.dll/i ) )
            {
                printf "Found instance of %s at %08x\n", $module, $_;
                my %pe = parsePE($_);
                $addr =
                  locateExportNameInTable( $procname, $_, $pe{'export'},
                    $pe{'exportsize'} );
                goto DONEGOTPROC;
            }
        }
    }
  DONEGOTPROC:

    # back to original process context
    $pcontext = $save;
    return $addr;
}

sub getUserModules {
    my %modules;

    # read PEB into buf
    my $peb = $pcontext->{'peb'};
    my $pebdata = readVirtualMemory( $peb, 0x300 );
    next unless length($pebdata) == 0x300;

    # get module list
    my $mptr = unpack( "I", substr( $pebdata, 0x0c, 4 ) );
    my $modulelist = readDword( $mptr + 0x14, 4 );
    my @modlist = walkList($modulelist);
    for my $mod (@modlist) {
        my $buf = readVirtualMemory( $mod, 0x34 );
        if ( length($buf) == 0x34 ) {
            my $base = unpack( "I", substr( $buf, 0x10, 4 ) );
            next if $base == 0;
            my $entry = unpack( "I", substr( $buf, 0x14, 4 ) );
            my $size = unpack( "I", substr( $buf, 0x18, 4 ) );
            my $path = substr( $buf, 0x1c, 8 );
            my $name = substr( $buf, 0x24, 8 );
            $modules{$base}{'name'}  = unicodeStructToAscii($name);
            $modules{$base}{'path'}  = unicodeStructToAscii($path);
            $modules{$base}{'size'}  = $size;
            $modules{$base}{'entry'} = $entry;
        }
    }
    return %modules;
}















my $s = IO::Select->new();
$s->add( \*STDIN );
if ($serial) {
    $s->add( \*FH );
} elsif ($socket) {
    $s->add($socket);
}

my @ready;
sendReset();
while ( @ready = $s->can_read ) {
    for my $fh (@ready) {
        if ( $fh == \*STDIN ) {
            my $line = <$fh>;
            if ( $line =~ /break/ ) {
                print "Sending break...\n";
                writeDev("b");
            }
            elsif ( $running == 1 ) {
                print "Kernel is busy (send break command)\n";
            }
            elsif ( $line =~ /processcontext ([0-9A-Fa-f]+)/ ) {
                my $pid = hex($1);
                if ( $pid == 0 ) {
                    $pcontext = \%kernelcontext;
                    print "Process context is kernel\n";
                }
                else {
                    my $eproc = getEprocess($pid);
                    my $dtb   = readDword( $eproc + 0x18 );
                    my $peb   = readDword( $eproc + 0x1b0 );

                    if ($peb) {
                        $processcontext{'eprocess'} = $eproc;
                        $processcontext{'dtb'}      = $dtb;
                        $processcontext{'peb'}      = $peb;
                        $processcontext{'pid'}      = $pid;
                        $pcontext                   = \%processcontext;
                        printf "Implicit process is now %x\n", $pid;
                    }
                    else {
                        print "Invalid PID (PEB not found in eprocess)\n";
                    }
                }

            }
            elsif ( $line =~ /getprocaddress (\S+) (\S+)/ ) {
                my $dll    = $1;
                my $export = $2;
                my $addr   = getProcAddress( $dll, $export );
                if ($addr) {
                    printf "%s!%s:%08x\n", $dll, $export, $addr;
                }
                else {
                    printf "%s!%s not found\n", $dll, $export;
                }
            }
            elsif ( $line =~ /listexports ([0-9A-Fa-f]+)/ ) {
                listExports( hex($1) );
            }
            elsif ( $line =~ /^logical2physical ([0-9A-Fa-f]+)/ ) {
                printf "%08x -> %08x\n", hex($1), logical2physical( hex($1) );
            }
            elsif ( $line =~ /^parsepe ([0-9A-Fa-f]+)/ ) {
                my %PE       = parsePE( hex($1) );
                my $compiled = localtime( $PE{"TimeDateStamp"} );
                print "Compiled on $compiled\n";
            }
            elsif ( $line =~
                /^writevirtualmemory ([0-9A-Fa-f]+) [0-9A-Fa-f][0-9A-Fa-f]/ )
            {
                chomp($line);
                my ( $c, $addr, @bytes ) = split( /\s+/, $line );
                sendDbgKdWriteVirtualMemory( hex($addr),
                    join( "", map { chr(hex) } @bytes ) );
            }
            elsif ( $line =~ /^(?:messagebox|mb)\s+(.*)\|(.*)/ ) {
                my $title   = $1;
                my $message = $2;
                injectSUSShellcode( $title, $message );
                insertApc();
            }
            elsif ( $line =~ /^processlist|^listprocess/ ) {
                print "Walking process list...\n";
                my %procs = getProcessList();
                for ( reverse sort keys %procs ) {
                    my $c = localtime( $procs{$_}{'created'} );
                    printf "%04x %s\n", $procs{$_}{'pid'}, $procs{$_}{'name'};
                    printf
                      "Eprocess: %08x  DTB: %08x  PEB: %08x  Created: %s\n", $_,
                      $procs{$_}{'dtb'}, $procs{$_}{'peb'}, $c;
                    print "Threads: ";
                    print join( " ",
                        map { sprintf "%08x", $_ } @{ $procs{$_}{'threads'} } );
                    print "\n\n";
                }
            }
            elsif ( $line =~ /^module|^listmodules/ ) {
                my %modules;
                if ( $pcontext->{'pid'} == 0 ) {
                    %modules = getKernelModules();
                }
                else {
                    %modules = getUserModules();
                }
                for ( sort keys %modules ) {
                    printf "%s\tPath:%s\n", $modules{$_}{'name'},
                      $modules{$_}{'path'};
                    printf "base:%08x  " . "size:%08x entry:%08x\n\n", $_,
                      $modules{$_}{'size'}, $modules{$_}{'entry'};
                }
            }
            elsif ( $line =~ /^findprocessbyname (\S+)/ ) {
                my $name  = $1;
                my %procs = getProcessList();
              PROCFIND:
                for ( sort keys %procs ) {
                    my $c = localtime( $procs{$_}{'created'} );
                    my $n = $procs{$_}{'name'};
                    if ( lc($name) eq lc($n) ) {
                        printf "%04x %s\n", $procs{$_}{'pid'},
                          $procs{$_}{'name'};
                        printf
                          "Eprocess: %08x  DTB: %08x  PEB: %08x  Created: %s\n",
                          $_, $procs{$_}{'dtb'}, $procs{$_}{'peb'}, $c;
                        print "Threads: ";
                        print join( " ",
                            map { sprintf "%08x", $_ }
                              @{ $procs{$_}{'threads'} } );
                        print "\n";
                        last PROCFIND;
                    }
                }
            }
            elsif ( $line =~ /^eprocess ([0-9A-Fa-f]+)/ ) {
                my $ep = getEprocess( hex($1) );
                sendDbgKdReadVirtualMemory( $ep, 648 );
                my $buf = waitStateManipulate($DbgKdReadVirtualMemoryApi);
                if ( length($buf) > 56 ) {
                    my $eproc = substr( $buf, 56 );
                    if ( length($eproc) > 0x20c ) {
                        my $name;
                        if ( $version > 5 ) {
                            $name = substr( $eproc, 0x174, 16 );
                        }
                        else {
                            $name = substr( $eproc, 0x1fc, 16 );
                        }
                        $name =~ s/\x00//g;
                        print "Process name is $name\n";
                        my $next = unpack( "I", substr( $eproc, 0xa0, 4 ) );
                    }

                }
            }
            elsif ( $line =~ /^bp ([0-9A-Fa-f]+)/ ) {
                sendDbgKdWriteBreakPoint($1);
            }
            elsif ( $line =~ /^bc ([0-9A-Fa-f]+)/ ) {
                sendDbgKdRestoreBreakPoint($1);
            }
            elsif ( $line =~ /^bl/ ) {
                print "Breakpoints:\n", join( "\n", sort keys %breakpoints ),
                  "\n";
            }
            elsif ( $line =~ /^continue/ ) {
                sendDbgKdContinue2();
                $running = 1;
            }
            elsif ( $line =~ /^getpspcidtable/ ) {
                getPspCidTable();
            }
            elsif ( $line =~ /^(autocontinue|g)$/ ) {

                # get/set context to update EIP before continuing
                my %context = getContext();
                $context{'EIP'}++;
                setContext(%context);
                sendDbgKdContinue2();
                $running = 1;
            }
            elsif ( $line =~ /^version/ ) {
                printVersionData();
            }
            elsif ( $line =~ /^readcontrolspace/ ) {
                sendDbgKdReadControlSpace();
            }
            elsif ( $line =~ /^writecontrolspace/ ) {
                if ($controlspace) {
                    sendDbgKdWriteControlSpace();
                }
                else {
                    print "Haven't gotten control space yet!\n";
                }
            }
            elsif ( $line =~ /^r (.*)=(.*)/ ) {
                my $reg     = $1;
                my $val     = $2;
                my %context = getContext();
                if ( length($reg) < 4 ) {
                    $reg = uc($reg);
                }
                if ( exists $context{$reg} ) {
                    if ( $reg eq "fp.RegisterArea" ) {
                        printf "Not supported yet.\n";
                    }
                    elsif ( $reg eq "leftovers" ) {
                        printf "Not supported.\n";
                    }
                    else {
                        $context{$reg} = hex($val);
                        setContext(%context);
                        %context = getContext();
                        printf "New value of %s is %08x\n", $reg,
                          $context{$reg};
                    }
                }
                else {
                    print "Register $reg unknown\n";
                }
            }
            elsif ( $line =~ /^r (.*)/ ) {
                my $reg     = $1;
                my %context = getContext();
                if ( length($reg) < 4 ) {
                    $reg = uc($reg);
                }
                if ( exists $context{$reg} ) {
                    if ( $reg eq "fp.RegisterArea" ) {
                        printf "%s = \n%s\n", $reg, hexprint($reg);
                    }
                    else {
                        printf "%s = %08x\n", $reg, $context{$reg};
                    }
                }
                else {
                    print "Register $reg unknown\n";
                }
            }
            elsif ( $line =~ /^r$|^getcontext/ ) {
                my %context = getContext();
                for ( sort keys %context ) {
                    if (   ( $_ ne "fp.RegisterArea" )
                        && ( $_ ne "leftovers" ) )
                    {
                        printf "%s=%08x\n", $_, $context{$_};
                    }
                }
                # print "\n";
            }
            elsif ( $line =~ /^dw ([0-9A-Fa-f]+)/ ) {
                printf "%08x: %08x\n", hex($1), readDword( hex($1) );
            }
            elsif ( $line =~ /^(?:readvirtualmem|d) ([0-9A-Fa-f]+)/ ) {
                my $vaddr = $1;
                my $readlen;
                if ( $line =~
                    /(?:readvirtualmem|d) ([0-9A-Fa-f]+) ([0-9A-Fa-f]+)/ )
                {
                    $readlen = hex($2);
                }
                $readlen ||= 4;
                my $buf = readVirtualMemory( hex($vaddr), $readlen );
                print hexasc($buf);
            }
            elsif ( $line =~ /^(?:readphysicalmem|dp) ([0-9A-Fa-f]+)/ ) {
                my $addr = $1;
                my $readlen;
                if ( $line =~
                    /(?:readphysicalmem|dp) ([0-9A-Fa-f]+) ([0-9A-Fa-f]+)/ )
                {
                    $readlen = hex($2);
                }
                $readlen ||= 4;
                sendDbgKdReadPhysicalMemory( hex($addr), $readlen );
            }
            elsif ( $line =~ /^reboot/ ) {
                sendDbgKdReboot();
            }
            elsif ( $line =~ /^quit|^exit/ ) {
                untie *FH;
                exit;
            }
            elsif ( $line =~ /^reset/ ) {
                sendReset();
            }
        }
        elsif ( $fh == \*FH || $fh == $socket ) {
            handlePacket(0);
        }
        print "\n\n";
    }
}