home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
vp21beta.zip
/
ARTLSRC.RAR
/
VPDBGAPI.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
2000-08-15
|
45KB
|
1,506 lines
unit VPDbgApi;
{&Z-,AlignRec-}
interface
uses Use32;
const
// Object Pascal Exception Codes
opecException = $0EEDFACE;
opecReRaise = $0EEDFACF;
opecExcept = $0EEDFAD0;
opecFinally = $0EEDFAD1;
opecTerminate = $0EEDFAD2;
opecUnhandled = $0EEDFAD3;
opecSysException = $0EEDFAD4;
// Debug Event Codes
decSingleStep = 0;
decBreakpoint = 1;
decWatchpoint = 2;
decException = 3;
decStop = 4;
decProcessEnded = 5;
decError = 6;
decLast = 6;
type
TSysDbgPlatform = (dpOS2, dpWin32);
TSysDbgPlatforms = set of TSysDbgPlatform;
PSysDbgFlatInfo = ^TSysDbgFlatInfo;
TSysDbgFlatInfo = record
Flat_CS: Word; // Flat code selector
Flat_DS: Word; // Flat data selector
end;
PSysDbgThreadIds = ^TSysDbgThreadIds;
TSysDbgThreadIds = record
ThreadID: Longint;
ThreadHandle: Longint;
ThreadOrdinal: Longint;
end;
TSysDbgSegDef = record
FlatOfs: Longint;
Size: Longint;
end;
PSysDbgEvent = ^TSysDbgEvent;
TSysDbgEvent = record
deCode: Integer;
deError: Integer;
deThreadID: Integer;
deXcptCode: Integer;
deXcptAddress: Longint;
deXcptParam1: Integer;
deXcptParam2: Integer;
deWatchPtMask: Integer;
end;
PSysDbgInterface = ^TSysDbgInterface;
TSysDbgInterface = record
GetThreadParam: function(No: Integer): PSysDbgThreadIds;
ThreadCreated: procedure(ThreadID,ThreadHandle,ThreadOrdinal: Longint);
ThreadExited: procedure(ThreadID,ExitCode: Longint);
DllLoaded: procedure(DllName: PChar; DllHandle,SegCount: Longint; const SegTable: array of TSysDbgSegDef);
DllUnloaded: procedure(DllHandle: Longint);
ProcessExited: procedure(ExitCode,ExitType: Integer);
NotifyException: procedure(const DbgEvent: TSysDbgEvent);
StopOnException: function(Code: Longint): Boolean;
end;
PSysDbgCPURegisters = ^TSysDbgCPURegisters;
TSysDbgCPURegisters = record
ThreadID: Longint;
ThreadHandle: Longint;
ThreadOrdinal: Longint;
EAX: Longint;
ECX: Longint;
EDX: Longint;
EBX: Longint;
ESP: Longint;
EBP: Longint;
ESI: Longint;
EDI: Longint;
EFlags: Longint;
EIP: Longint;
CS: SmallWord;
DS: SmallWord;
ES: SmallWord;
FS: SmallWord;
GS: SmallWord;
SS: SmallWord;
end;
PSysDbgFSaveFormat = ^TSysDbgFSaveFormat;
TSysDbgFSaveFormat = record
CW: SmallWord; // Control Word
Reserved1: SmallWord; // Reserved
SW: SmallWord; // Status word
Reserved2: SmallWord; // Reserved
Tag: SmallWord; // Tag Word
Reserved3: SmallWord; // Reserved
IPtrOffset: Longint; // Instruction Pointer Offset
IPtrSelector: SmallWord; // Instruction Pointer Selector
IPtrOpcode: SmallWord; // Instruction Opcode
DPtrOffset: Longint; // Data Pointer Offset
DPtrSelector: SmallWord; // Data Pointer Selector
Reserved4: SmallWord; // Reserved
Regs: array [0..7] of Extended; // Floating Point registers
end;
PSysDbgThreadState = ^TSysDbgThreadState;
TSysDbgThreadState = record
IsFrozen: Boolean;
Schedule: Byte;
Priority: SmallWord;
end;
TSysDbgIDEInterface = record
SysDbgVersion: Longint;
SysDbgPlatforms: TSysDbgPlatforms;
SysDbgInitialize: procedure;
SysDbgGetFlatInfo: procedure(var FlatInfo: TSysDbgFlatInfo);
SysDbgSetInterface: procedure(var DbgInt: TSysDbgInterface);
SysDbgStartProcess: function(const FileName,CmdLine: String; AppType: Longint; var ProcessID,SesID,EntryAddr: Longint): Longint;
SysDbgTerminateProcess: function: Longint;
SysDbgSelToFlat: function(Sel,Ofs: Longint): Longint;
SysDbgReadMemory: function(Sel,Ofs: Longint; Buffer: Pointer; Size: Longint): Longint;
SysDbgWriteMemory: function(Sel,Ofs: Longint; Buffer: Pointer; Size: Longint): Longint;
SysDbgReadRegisters: function(Regs: PSysDbgCPURegisters; FPUState: PSysDbgFSaveFormat): Boolean;
SysDbgWriteRegisters: function(Regs: PSysDbgCPURegisters; FPUState: PSysDbgFSaveFormat): Boolean;
SysDbgFreezeThread: function(const Regs: TSysDbgCPURegisters): Boolean;
SysDbgResumeThread: function(const Regs: TSysDbgCPURegisters): Boolean;
SysDbgGetThreadState: function(const Regs: TSysDbgCPURegisters; var State: TSysDbgThreadState): Boolean;
SysDbgSetWatchPoint: function(LinAddr: Longint; BkptLen,BkptType: Byte; ThreadID: Longint): Longint;
SysDbgClearWatchPoint: procedure(Id: Longint);
SysDbgExecute: procedure(Step: Boolean; Regs: TSysDbgCPURegisters; var DbgEvent: TSysDbgEvent);
SysDbgWaitUserScreen: procedure(Delay: Longint);
SysDbgSetHardMode: procedure(Hard: Boolean);
SysDbgSwitchScreen: procedure(User: Boolean);
end;
procedure SysDbgGetIDEInterface(var IDEInt: TSysDbgIDEInterface); orgname; {$IFDEF VPDBGDLL} export; {$ENDIF}
implementation
{$IFDEF Win32}
uses Windows,
{$ELSE}
uses Os2Def, Os2Base,
{$ENDIF}
Strings, VPSysLow, ExeHdr;
{$IFDEF VPDBGDLL}
var
FlatInfo: TSysDbgFlatInfo;
DbgInterface: TSysDbgInterface;
{$IFNDEF WIN32}
type
KeyPacket = record // Key packet record for Keyboard Monitor
MonFlags : SmallWord;
ASCII : Byte; // Fields that start here are equivalent
Scan : Byte; // to thoses defined in KbdTrans
IDontCare : array [1..8] of Byte;
DdFlags : Word;
end;
var
ProcessID: Longint;
SesID: Longint;
procedure SysDbgGetFlatInfo(var FlatInfo: TSysDbgFlatInfo);
begin
with FlatInfo do
begin
Flat_CS := CSeg; // GDT selectors, so they are common for all tasks
Flat_DS := DSeg;
end;
end;
procedure SysDbgWaitUserScreen(Delay: Longint);
var
RC,MSec,StartMSec: Longint;
MonHandle,ReadCount: SmallWord;
Kp: KeyPacket;
InBuf,OutBuf: array [0..63] of SmallWord;
procedure Wait;
begin
if MSec = 0 then
MSec := Delay;
SysCtrlSleep(MSec);
end;
begin
MSec := 0;
if DosMonOpen('\DEV\KBD$', MonHandle) <> 0 then
Wait
else
begin
InBuf[0] := SizeOf(InBuf);
OutBuf[0] := SizeOf(OutBuf); {Front} { Current screen Group }
if DosMonReg(MonHandle, @InBuf, @OutBuf, 1, SesID) <> 0 then
begin
DosMonClose(MonHandle);
Wait;
end
else
begin
StartMSec := SysSysMsCount;
repeat
ReadCount := SizeOf(KeyPacket);
RC := DosMonRead(@InBuf, 1, @Kp, ReadCount); // No Wait
if RC <> 0 then
begin
if (RC <> error_Mon_Buffer_Empty) and (MSec = 0) then
MSec := Delay;
Kp.DdFlags := 0;
end;
until ((MSec <> 0) and ((SysSysMsCount - StartMSec) >= MSec)) // Time elapsed
or (((Kp.DdFlags and $40) <> 0) and (Kp.Scan <> 0)); // or any key is pressed
DosMonClose(MonHandle);
end;
end;
end;
procedure SysDbgSetHardMode(Hard: Boolean);
var
HK: HotKey;
ParmLen,Handle: ULong;
const
HardDbgMode: Boolean = False;
begin
if (Hard <> HardDbgMode) and (SysFileOpen('\DEV\KBD$', $40, Handle) = 0) then
begin
HardDbgMode := Hard;
FillChar(HK, SizeOf(HK), 0);
HK.idHotKey := $FFFF; // Ctrl-Esc, Alt-Esc, Ctrl-Alt-Del
ParmLen := SizeOf(HK);
DosDevIOCtl(Handle, ioctl_Keyboard, kbd_SetSesMgrHotKey, @HK, SizeOf(HK),
@ParmLen, nil, 0, nil);
SysFileClose(Handle);
end;
end;
procedure SysDbgSwitchScreen(User: Boolean);
var
SID: Longint;
begin
if User then
SID := SesID
else
SID := 0;
DosSelectSession(SID);
end;
procedure HandleNotification(var DB: Debug_Buffer);
var
I: Integer;
SegTable: array[0..49] of TSysDbgSegDef;
Buffer: array[0..255] of Char;
DB1: Debug_Buffer;
begin
case DB.Cmd of
DBG_N_ModuleLoad:
begin
Buffer[0] := #0; // DB.Value = Module Handle
DosQueryModuleName(DB.Value, SizeOf(Buffer), Buffer);
I := 0;
repeat
DB1.Pid := ProcessID;
DB1.Value := I+1; // Object number 1,2...
DB1.MTE := DB.Value; // in module
DB1.Cmd := DBG_C_NumToAddr; // Get segment address
if (DosDebug(DB1) <> 0) or (DB1.Cmd <> DBG_N_SUCCESS) then
Break;
with SegTable[I] do
begin
FlatOfs := DB1.Addr;
Size := 0;
DB1.Cmd := DBG_C_AddrToObject;
if (DosDebug(DB1) = 0) and (DB1.Cmd = DBG_N_SUCCESS) then
Size := DB1.Len;
end;
Inc(I);
until I >= High(SegTable);
DbgInterface.DllLoaded(Buffer, DB.Value, I, SegTable);
end;
DBG_N_ModuleFree:
DbgInterface.DllUnloaded(DB.Value);
DBG_N_ThreadCreate:
DbgInterface.ThreadCreated(DB.Tid, DB.Tid, DB.Tid);
DBG_N_ThreadTerm:
DbgInterface.ThreadExited(DB.Tid, DB.Value);
DBG_N_ProcTerm:
DbgInterface.ProcessExited(DB.Value, DB.Index);
end;
end;
procedure HandlePendingNotifications;
var
RC: Longint;
DB: Debug_Buffer;
begin
repeat
DB.Pid := ProcessID;
DB.Cmd := DBG_C_Stop;
RC := DosDebug(DB);
if RC = 0 then
HandleNotification(DB);
until (RC <> 0) or (DB.Cmd = DBG_N_SUCCESS);
end;
function SysDbgSelToFlat(Sel,Ofs: Longint): Longint;
var
Selector: SmallWord;
DB: Debug_Buffer;
begin
Selector := Sel;
if (Selector = FlatInfo.Flat_DS) or (Selector = FlatInfo.Flat_CS) then
Result := Ofs
else
begin
DB.Pid := ProcessID;
DB.Value := Selector;
DB.Index := Ofs;
DB.Cmd := DBG_C_SelToLin;
DosDebug(DB);
Result := DB.Addr;
end;
end;
function SysDbgReadMemory(Sel,Ofs: Longint; Buffer: Pointer; Size: Longint): Longint;
var
DB: Debug_Buffer;
begin
DB.Addr := SysDbgSelToFlat(Sel, Ofs);
DB.Pid := ProcessID;
DB.Buffer := Longint(Buffer);
DB.Len := Size;
DB.Cmd := DBG_C_ReadMemBuf;
if (DosDebug(DB) <> 0) or (DB.Cmd <> DBG_N_SUCCESS) then
Result := 0
else
Result := Size;
end;
function SysDbgWriteMemory(Sel,Ofs: Longint; Buffer: Pointer; Size: Longint): Longint;
var
DB: Debug_Buffer;
begin
DB.Addr := SysDbgSelToFlat(Sel, Ofs);
DB.Pid := ProcessID;
DB.Buffer := Longint(Buffer);
DB.Len := Size;
DB.Cmd := DBG_C_WriteMemBuf;
if (DosDebug(DB) <> 0) or (DB.Cmd <> DBG_N_SUCCESS) then
Result := 0
else
Result := Size;
end;
function SysDbgStartProcess(const FileName,CmdLine: String; AppType: Longint; var ProcessID,SesID,EntryAddr: Longint): Longint;
var
SD: StartData;
DB: Debug_Buffer;
TitleBuf: array[0..259] of Char;
FileNameBuf: array[0..259] of Char;
CmdLineBuf: array[0..259] of Char;
begin
EntryAddr := 0; // The IDE determines it itself
FillChar(SD, SizeOf(StartData), 0);
SD.Length := 32; // So it can start session without PM
SD.Related := ssf_Related_Child; // Related
SD.FgBg := ssf_Fgbg_Back; // BackGround
SD.Traceopt := ssf_TraceOpt_Trace; // Debugging trace
SD.PgmTitle := StrPCopy(TitleBuf, 'VP debugging: ' + FileName);
SD.PgmName := StrPCopy(FileNameBuf, FileName);
SD.PgmInputs := StrPCopy(CmdLineBuf, CmdLine);
SD.TermQ := nil;
SD.Environment := nil; // Inherit
SD.InheritOpt := ssf_InhertOpt_Parent; // Parent environment
SD.SessionType := AppType;
Result := DosStartSession(SD, SesID, ProcessID);
if Result <> 0 then
begin
SesID := $FFFFFFFF;
ProcessID := $FFFFFFFF;
end
else
begin
DB.Pid := ProcessID; // Debuggee PID
DB.Tid := 0; // Reserved, must be 0
DB.Value := dbg_l_386; // Debugging Level Number
DB.Cmd := DBG_C_Connect;
Result := DosDebug(DB);
if (Result = 0) and (DB.Cmd <> DBG_N_SUCCESS) then
Result := DB.Value; // Error Code
end;
VPDbgAPI.ProcessID := ProcessID;
VPDbgAPI.SesID := SesID;
if Result = 0 then
HandlePendingNotifications;
end;
// Restores context of the debuggee (DB.Len should contain context address)
procedure RestoreContext(DB: Debug_Buffer);
var
XcptContext: ContextRecord;
begin
SysDbgReadMemory(FlatInfo.Flat_DS, DB.Len, @XcptContext, SizeOf(XcptContext));
DB.EAX := XcptContext.ctx_RegEAX;
DB.ECX := XcptContext.ctx_RegECX;
DB.EDX := XcptContext.ctx_RegEDX;
DB.EBX := XcptContext.ctx_RegEBX;
DB.ESP := XcptContext.ctx_RegESP;
DB.EBP := XcptContext.ctx_RegEBP;
DB.ESI := XcptContext.ctx_RegESI;
DB.EDI := XcptContext.ctx_RegEDI;
DB.EFlags := XcptContext.ctx_EFlags;
DB.EIP := XcptContext.ctx_RegEIP;
DB.CS := XcptContext.ctx_SegCS;
DB.DS := XcptContext.ctx_SegDS;
DB.ES := XcptContext.ctx_SegES;
DB.FS := XcptContext.ctx_SegFS;
DB.GS := XcptContext.ctx_SegGS;
DB.SS := XcptContext.ctx_SegSS;
DB.Cmd := DBG_C_WriteReg;
DosDebug(DB);
end;
procedure SysDbgExecute(Step: Boolean; Regs: TSysDbgCPURegisters; var DbgEvent: TSysDbgEvent);
var
Done: Boolean;
Value,Command,BytesRead: Longint;
DB: Debug_Buffer;
XcptReport: ExceptionReportRecord;
begin
if Step then
Command := DBG_C_SStep
else
Command := DBG_C_Go;
DB.Pid := ProcessID;
DB.Tid := Regs.ThreadID;
Done := False;
with DbgEvent do
begin
deWatchPtMask := 0;
deCode := decStop;
case Command of
DBG_C_Go: Value := XCPT_CONTINUE_SEARCH;
DBG_C_Stop: Value := XCPT_CONTINUE_STOP;
end;
repeat
DB.Cmd := Command;
DB.Value := Value;
deError := DosDebug(DB);
if deError <> 0 then
begin
DB.Cmd := DBG_N_Error;
DB.Value := deError;
end;
Command := DBG_C_Continue;
HandleNotification(DB);
case DB.Cmd of
DBG_N_ThreadTerm,DBG_N_ThreadCreate,DBG_N_NewProc,DBG_N_AliasFree,
DBG_N_ModuleLoad,DBG_N_ModuleFree: ; // Simply skip
DBG_N_ProcTerm: // Stop execution
begin
Value := XCPT_CONTINUE_STOP;
deCode := decProcessEnded;
end;
DBG_N_AsyncStop:
begin
deCode := decStop;
Done := True; // Exit
end;
DBG_N_Watchpoint: // Record watchpoint ID
begin
deWatchPtMask := deWatchPtMask or (1 shl DB.Index);
Value := XCPT_CONTINUE_STOP;
deCode := decWatchpoint;
end;
DBG_N_Error:
begin
deCode := decError;
deError := DB.Value;
Done := True;
end;
DBG_N_Exception:
begin
deXcptCode := DB.Buffer;
deXcptAddress := DB.Addr;
case DB.Value of // Exception Chance
0: // Prefirst chance exception
if deXcptCode = XCPT_SINGLE_STEP then
begin
Value := XCPT_CONTINUE_STOP;
deCode := decSingleStep;
end
else
if deXcptCode = XCPT_BREAKPOINT then
begin
Value := XCPT_CONTINUE_STOP;
deCode := decBreakpoint;
end;
1: // First chance exception
begin
deCode := decException;
SysDbgReadMemory(FlatInfo.Flat_DS, DB.Buffer, @XcptReport, SizeOf(XcptReport));
deXcptParam1 := XcptReport.ExceptionInfo[0];
deXcptParam2 := XcptReport.ExceptionInfo[1];
deXcptCode := XcptReport.ExceptionNum;
case deXcptCode of
opecReRaise..opecSysException:
begin
DbgInterface.NotifyException(DbgEvent);
Value := XCPT_CONTINUE_EXECUTION;
end;
else
if DbgInterface.StopOnException(deXcptCode) then
begin
Value := XCPT_CONTINUE_STOP; // Break
RestoreContext(DB);
end
else
Value := XCPT_CONTINUE_SEARCH; // Pass to exception handler
end;
end;
// Second chance exception
2: Value := XCPT_CONTINUE_SEARCH; // Perform default system action
// Invalid stack
3: Value := XCPT_CONTINUE_SEARCH;
end; // Case
end;
else // DBG_N_SUCCESS and others
Done := True;
end;
until Done;
deThreadID := DB.Tid;
end;
end;
function SysDbgTerminateProcess: Longint;
var
DB: Debug_Buffer;
begin
DB.Pid := ProcessID;
DB.Cmd := DBG_C_Term;
Result := DosDebug(DB);
if (Result = 0) and (DB.Cmd <> DBG_N_SUCCESS) then
Result := DB.Value;
end;
function SysDbgReadRegisters(Regs: PSysDbgCPURegisters; FPUState: PSysDbgFSaveFormat): Boolean;
var
DB: Debug_Buffer;
begin
with Regs^ do
begin
DB.PID := ProcessID;
DB.TID := ThreadID;
if FPUState = nil then
begin
DB.Cmd := DBG_C_ReadReg;
Result := (DosDebug(DB) = 0) and (DB.Cmd = DBG_N_SUCCESS);
if Result then
begin
EAX := DB.EAX;
ECX := DB.ECX;
EDX := DB.EDX;
EBX := DB.EBX;
ESP := DB.ESP;
EBP := DB.EBP;
ESI := DB.ESI;
EDI := DB.EDI;
EFlags:= DB.EFlags;
EIP := DB.EIP;
CS := DB.CS;
DS := DB.DS;
ES := DB.ES;
FS := DB.FS;
GS := DB.GS;
SS := DB.SS;
end;
end
else
begin
DB.Value := dbg_co_387; // Coprocessor type 80387
DB.Len := SizeOf(TSysDbgFSaveFormat); // Length of the coprcessor context
DB.Buffer := Longint(FPUState); // Address of the Ncp context buffer
DB.Index := 0; // Reserved, must be 0
DB.Cmd := dbg_c_ReadCoRegs;
Result := (DosDebug(DB) = 0) and (DB.Cmd = DBG_N_SUCCESS);
end;
end;
end;
function SysDbgWriteRegisters(Regs: PSysDbgCPURegisters; FPUState: PSysDbgFSaveFormat): Boolean;
var
DB: Debug_Buffer;
begin
FillChar(DB, SizeOf(DB), 0);
with Regs^ do
begin
DB.PID := ProcessID;
DB.TID := ThreadID;
if FPUState = nil then
begin
DB.Cmd := DBG_C_WriteReg;
DB.EAX := EAX;
DB.ECX := ECX;
DB.EDX := EDX;
DB.EBX := EBX;
DB.ESP := ESP;
DB.EBP := EBP;
DB.ESI := ESI;
DB.EDI := EDI;
DB.EFlags := EFlags;
DB.EIP := EIP;
DB.CS := CS;
DB.DS := DS;
DB.ES := ES;
DB.FS := FS;
DB.GS := GS;
DB.SS := SS;
Result := (DosDebug(DB) = 0) and (DB.Cmd = DBG_N_SUCCESS);
end
else
begin
DB.Value := dbg_co_387; // Coprocessor type 80387
DB.Len := SizeOf(TSysDbgFSaveFormat); // Length of the coprcessor context
DB.Buffer := Longint(FPUState); // Address of the Ncp context buffer
DB.Index := 0; // Reserved, must be 0
DB.Cmd := DBG_C_WriteCoRegs;
Result := (DosDebug(DB) = 0) and (DB.Cmd = DBG_N_SUCCESS);
end;
end;
end;
function SysDbgFreezeThread(const Regs: TSysDbgCPURegisters): Boolean;
var
DB: Debug_Buffer;
begin
DB.Pid := ProcessID;
DB.Tid := Regs.ThreadID;
DB.Cmd := DBG_C_Freeze;
Result := (DosDebug(DB) = 0) and (DB.Cmd = DBG_N_SUCCESS);
end;
function SysDbgResumeThread(const Regs: TSysDbgCPURegisters): Boolean;
var
DB: Debug_Buffer;
begin
DB.Pid := ProcessID;
DB.Tid := Regs.ThreadID;
DB.Cmd := DBG_C_Resume;
Result := (DosDebug(DB) = 0) and (DB.Cmd = DBG_N_SUCCESS);
end;
function SysDbgGetThreadState(const Regs: TSysDbgCPURegisters; var State: TSysDbgThreadState): Boolean;
var
DB: Debug_Buffer;
begin
DB.Pid := ProcessID;
DB.Tid := Regs.ThreadID;
DB.Buffer := Longint(@State);
DB.Len := 4; // IsFrozen db ? ; State db ? ; Priority dw ?
DB.Cmd := DBG_C_ThrdStat;
Result := (DosDebug(DB) = 0) and (DB.Cmd = DBG_N_SUCCESS);
end;
function SysDbgSetWatchPoint(LinAddr: Longint; BkptLen,BkptType: Byte; ThreadID: Longint): Longint;
var
DB: Debug_Buffer;
begin
DB.Pid := ProcessID;
DB.Addr := LinAddr;
DB.Len := BkptLen;
DB.Index := 0; // Reserved, must be 0
DB.Value := 2+Longint(BkptType) shl 16; // Watchpoint type and Scope
DB.Cmd := DBG_C_SetWatch; // Scope = Local (2)
if (DosDebug(DB) <> 0) or (DB.Cmd <> DBG_N_SUCCESS) then
Result := 0
else
Result := DB.Index;
end;
procedure SysDbgClearWatchPoint(Id: Longint);
var
DB: Debug_Buffer;
begin
DB.Pid := ProcessID;
DB.Index := Id;
DB.Cmd := DBG_C_ClearWatch;
DosDebug(DB);
end;
{$ELSE}
const
DBG_EXCEPTION_NOT_HANDLED = $80010001;
DBG_CONTINUE = $00010002;
DBG_TERMINATE_PROCESS = $40010004;
var
ProcessInfo: TProcessInformation;
ProcessName: array[0..259] of Char;
DebugEvent: TDebugEvent;
ThreadNumber: Longint;
ProcessStartAddr: Longint;
const
WatchPtCount: Longint = 0;
ProcessTerminated: Boolean = True;
function SetResult(Success: Boolean): Longint;
begin
Result := 0;
if not Success then
Result := GetLastError;
end;
function GethThread(ThreadId: Longint): Longint;
var
P: PSysDbgThreadIds;
I: Integer;
begin
I := 0;
repeat
P := DbgInterface.GetThreadParam(I);
if (P <> nil) and (P^.ThreadId = ThreadId) then
begin
Result := P^.ThreadHandle;
Exit;
end;
Inc(I);
until P = nil;
Result := 0;
end;
function GetIdThread(ThreadHandle: Longint): Longint;
var
P: PSysDbgThreadIds;
I: Integer;
begin
I := 0;
repeat
P := DbgInterface.GetThreadParam(I);
if (P <> nil) and (P^.ThreadHandle = ThreadHandle) then
begin
Result := P^.ThreadID;
Exit;
end;
Inc(I);
until P = nil;
Result := 0;
end;
procedure SysDbgGetFlatInfo(var FlatInfo: TSysDbgFlatInfo);
begin
FlatInfo := VPDbgAPI.FlatInfo;
end;
procedure SetupFlatInfo;
var
CX: TContext;
begin
CX.ContextFlags := CONTEXT_SEGMENTS or CONTEXT_CONTROL;
GetThreadContext(ProcessInfo.hThread, CX);
FlatInfo.Flat_CS := CX.SegCs;
FlatInfo.Flat_DS := CX.SegDs;
end;
procedure SysDbgWaitUserScreen(Delay: Longint);
begin
SysCtrlSleep(Delay);
end;
procedure SysDbgSetHardMode(Hard: Boolean);
begin
end;
type
TWindowTitle = array[0..259] of Char;
PSearchWindowParam = ^TSearchWindowParam;
TSearchWindowParam = record
swpPID: DWord;
swpWnd: HWnd;
swpConsoleTitle: TWindowTitle;
end;
function EnumWindowFunc(Wnd: HWnd; Param: PSearchWindowParam): Bool; stdcall;
var
PID: DWord;
WindowTitle: TWindowTitle;
begin
with Param do
begin
GetWindowThreadProcessId(Wnd, @PID);
Result := swpPID <> PID;
if swpConsoleTitle[0] <> #0 then
begin
GetWindowText(Wnd, WindowTitle, SizeOf(WindowTitle));
Result := StrIComp(swpConsoleTitle, WindowTitle) <> 0;
end;
if not Result then
Param.swpWnd := Wnd;
end;
end;
procedure SysDbgSwitchScreen(User: Boolean);
var
Param: TSearchWindowParam;
begin
with Param do
begin
swpWnd := 0;
swpConsoleTitle[0] := #0;
swpPID := ProcessInfo.dwProcessId;
if not User then
swpPID := GetCurrentProcessId;
EnumWindows(@EnumWindowFunc, DWord(@Param));
if not User and (swpWnd = 0) then
begin
GetConsoleTitle(swpConsoleTitle, SizeOf(swpConsoleTitle));
EnumWindows(@EnumWindowFunc, DWord(@Param));
end;
if Param.swpWnd <> 0 then
begin
SetForegroundWindow(Param.swpWnd);
end;
end;
end;
function SysDbgSelToFlat(Sel,Ofs: Longint): Longint;
var
Selector: SmallWord;
begin
Selector := Sel;
if (Selector = FlatInfo.Flat_DS) or (Selector = FlatInfo.Flat_CS) then
Result := Ofs
else
Result := 0;
end;
function SysDbgReadMemory(Sel,Ofs: Longint; Buffer: Pointer; Size: Longint): Longint;
begin
if not ReadProcessMemory(ProcessInfo.hProcess, Pointer(SysDbgSelToFlat(Sel, Ofs)),
Buffer, Size, Result) then
Result := 0;
end;
function SysDbgWriteMemory(Sel,Ofs: Longint; Buffer: Pointer; Size: Longint): Longint;
begin
if not WriteProcessMemory(ProcessInfo.hProcess, Pointer(SysDbgSelToFlat(Sel, Ofs)),
Buffer, Size, Result) then
Result := 0;
end;
procedure ReadPChar(Ofs: Longint; Buffer: PChar; BufSize: Longint; Unicode: Boolean);
var
I: Integer;
WordBuffer: array[0..1024] of SmallWord;
begin
I := 0;
if Unicode then
begin
while (I < BufSize-1) and (SysDbgReadMemory(FlatInfo.Flat_CS, Ofs+I*2, @WordBuffer[I], 2) = 2) and (WordBuffer[I] <> 0) do
Inc(I);
WordBuffer[I] := 0;
WideCharToMultiByte(0, 0, @WordBuffer, I, Buffer, BufSize, nil, nil);
end
else
begin
while (I < BufSize-1) and (SysDbgReadMemory(FlatInfo.Flat_CS, Ofs+I, @Buffer[I], 1) = 1) and (Buffer[I] <> #0) do
Inc(I);
Buffer[I] := #0;
end;
end;
function ReadDWord(Ofs: Longint): Longint;
begin
if SysDbgReadMemory(FlatInfo.Flat_CS, Ofs, @Result, 4) <> 4 then
Result := 0;
end;
type
PDLLData = ^TDLLData;
TDLLData = record
// Input
hFile: THandle;
BaseOfs: Longint;
// Output
Name: array[0..255] of Char;
Size: Longint;
end;
procedure GetDLLParams(var DLLData: TDllData);
var
I,Ofs: Longint;
Actual: Longint;
ExeHdr: TImageDosHeader;
PEHdr: record
Signature: Longint;
FileHdr: TImageFileHeader;
OptionalHdr: TImageOptionalHeader;
end;
ExpDir: TImageExportDirectory;
begin
with DLLData do
begin
Name[0] := #0;
Size := 0;
SysFileSeek(hFile, 0, 0, Actual);
SysFileRead(hFile, ExeHdr, SizeOf(ExeHdr), Actual);
if (ExeHdr.e_magic = image_DOS_Signature) and (ExeHdr.e_lfanew <> 0) and (Actual = SizeOf(ExeHdr)) then
begin
SysFileSeek(hFile, ExeHdr.e_lfanew, 0, Actual);
SysFileRead(hFile, PEHdr, SizeOf(PEHdr), Actual);
if (PEHdr.Signature = image_NT_Signature) and (Actual = SizeOf(PEHdr)) then
begin
Ofs := BaseOfs + PEHdr.OptionalHdr.DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT].VirtualAddress;
if SysDbgReadMemory(FlatInfo.Flat_CS, Ofs, @ExpDir, SizeOf(ExpDir)) = SizeOf(ExpDir) then
ReadPChar(BaseOfs + ExpDir.Name, Name, SizeOf(Name), False);
Ofs := 0;
with PEHdr.OptionalHdr do
begin
I := Low(DataDirectory);
while I <= High(DataDirectory) do
with DataDirectory[I] do
begin
if Ofs < VirtualAddress + Size then
Ofs := VirtualAddress + Size;
Inc(I);
end;
end;
Size := Ofs;
end;
end;
end;
end;
procedure HandleEvent(var Event: TDebugEvent);
var
I: Integer;
SegEntry: TSysDbgSegDef;
DLLData: TDLLData;
begin
with Event do
case dwDebugEventCode of
CREATE_THREAD_DEBUG_EVENT:
begin
Inc(ThreadNumber);
DbgInterface.ThreadCreated(dwThreadId, CreateThread.hThread, ThreadNumber);
end;
EXIT_THREAD_DEBUG_EVENT:
DbgInterface.ThreadExited(dwThreadId, ExitThread.dwExitCode);
EXIT_PROCESS_DEBUG_EVENT:
begin
ProcessTerminated := True;
DbgInterface.ThreadExited(ProcessInfo.dwThreadId, ProcessInfo.hThread);
DbgInterface.ProcessExited(ExitProcess.dwExitCode, 0);
ContinueDebugEvent(DebugEvent.dwProcessId, DebugEvent.dwThreadId, dbg_Continue);
end;
LOAD_DLL_DEBUG_EVENT:
begin
DLLData.hFile := LoadDll.hFile;
DLLData.BaseOfs := Longint(LoadDll.lpBaseOfDll);;
GetDLLParams(DLLData);
SegEntry.FlatOfs := DLLData.BaseOfs;
SegEntry.Size := DLLData.Size;
DbgInterface.DllLoaded(DLLData.Name, DLLData.BaseOfs, 1, SegEntry);
if DLLData.Name[0] = #0 then
ReadPChar(ReadDWord(Longint(LoadDll.lpImageName)), DLLData.Name,
SizeOf(DLLData.Name), LoadDll.fUnicode <> 0);
end;
UNLOAD_DLL_DEBUG_EVENT:
DbgInterface.DllUnloaded(Longint(UnloadDll.lpBaseOfDll));
CREATE_PROCESS_DEBUG_EVENT:
begin
DLLData.hFile := CreateProcessInfo.hFile;
DLLData.BaseOfs := Longint(CreateProcessInfo.lpBaseOfImage);
GetDLLParams(DLLData);
SegEntry.FlatOfs := DLLData.BaseOfs;
SegEntry.Size := DLLData.Size;
StrCopy(DLLData.Name, ProcessName);
DbgInterface.DllLoaded(DLLData.Name, DLLData.BaseOfs, 1, SegEntry);
ProcessStartAddr := Longint(CreateProcessInfo.lpStartAddress);
end;
end;
end;
// The starting point of the program is not reported properly, because
// the entry point resides in Pharlap ETS code, not in VP generated code as
// the VP debugger expects it to be. To workaround this, the following hack
// is used: the code at the reported starting point is as follows:
//
// cs:215669C pushfd
// cs:21567 60 pushad
// cs:21568 06 push es
// cs:21569 E8220F0000 call 22490h
// cs:2156E 07 pop es
// cs:2156F 61 popad
// cs:21570 9D popfd
// cs:21571 E981EBFFFF jmp 200F7h
// where the last JMP instruction goes to the actual starting entry point
// of the program. Calculate the target address of JMP and report it
// as the entry address. Unfortunately, this technique might not work in
// future if Pharlap decide to change this startup code.
{$IFDEF PharlapETS}
procedure PharlapHack;
var
JmpInstr: record
Opcode: Byte;
Disp: Longint;
end;
begin
if (SysDbgReadMemory(FlatInfo.Flat_CS, ProcessStartAddr+11, @JmpInstr, SizeOf(JmpInstr)) = SizeOf(JmpInstr)) and
(JmpInstr.Opcode = $E9) then
Inc(ProcessStartAddr, 11 + JmpInstr.Disp + 5);
end;
{$ENDIF}
function SysDbgStartProcess(const FileName,CmdLine: String; AppType: Longint; var ProcessID,SesID,EntryAddr: Longint): Longint;
var
StartupInfo: TStartupInfo;
TitleBuf: array[0..259] of Char;
FileNameBuf: array[0..259] of Char;
CmdLineBuf: array[0..512] of Char;
QuotedName: String;
begin
WatchPtCount := 0;
ProcessStartAddr := 0;
if Pos(' ',FileName) > 0 then
QuotedName := '"' + FileName + '"'
else
QuotedName := FileName;
StrPCopy(CmdLineBuf, QuotedName + ' ');
StrPCopy(StrEnd(CmdLineBuf), CmdLine);
StrPCopy(ProcessName, FileName);
FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
with StartupInfo do
begin
cb := SizeOf(TStartupInfo);
dwFlags := startf_UseShowWindow;
if AppType = 1 then
dwFlags := dwFlags or StartF_RunFullScreen;
wShowWindow := sw_ShowNormal;
lpTitle := StrPCopy(TitleBuf, 'VP debugging: ' + FileName);
end;
Result := SetResult(CreateProcess(
StrPCopy(FileNameBuf, FileName) , // FileName
CmdLineBuf , // Command Line
nil , // Process attributes
nil , // Thread attributes
False , // Inherit handles
debug_Only_This_Process + create_New_Console,
nil , // Environment
nil , // Current directory
StartupInfo ,
ProcessInfo
));
if Result = 0 then
begin
SetUpFlatInfo;
ProcessTerminated := False;
ThreadNumber := 1;
DbgInterface.ThreadCreated(ProcessInfo.dwThreadId, ProcessInfo.hThread, 1);
ProcessID := ProcessInfo.hProcess;
SesID := ProcessInfo.hProcess;
while WaitForDebugEvent(DebugEvent, Infinite) do
begin
HandleEvent(DebugEvent);
if DebugEvent.dwDebugEventCode = EXCEPTION_DEBUG_EVENT then
Break;
ContinueDebugEvent(DebugEvent.dwProcessId, DebugEvent.dwThreadId, dbg_Continue);
end;
end;
{$IFDEF PharlapETS}
PharlapHack;
{$ENDIF}
EntryAddr := ProcessStartAddr;
end;
procedure SysDbgExecute(Step: Boolean; Regs: TSysDbgCPURegisters; var DbgEvent: TSysDbgEvent);
var
Done: Boolean;
hThread: THandle;
DbgContinueFlag: Longint;
CX: TContext;
begin
DbgContinueFlag := dbg_Continue;
if Step then
begin
hThread := GethThread(DebugEvent.dwThreadId);
CX.ContextFlags := CONTEXT_CONTROL;
GetThreadContext(hThread, CX);
CX.EFlags := CX.EFlags or $0100; // Set Trap Flag
SetThreadContext(hThread, CX);
end;
with DebugEvent,DbgEvent do
repeat
Done := True;
deCode := decError;
deError := SetResult(ContinueDebugEvent(DebugEvent.dwProcessId, DebugEvent.dwThreadId, DbgContinueFlag));
DbgContinueFlag := dbg_Continue;
if deError <> 0 then
Exit;
deError := SetResult(WaitForDebugEvent(DebugEvent, Infinite));
HandleEvent(DebugEvent);
deThreadID := DebugEvent.dwThreadId;
if deError <> 0 then
Exit;
case dwDebugEventCode of
EXCEPTION_DEBUG_EVENT:
begin
deXcptCode := Exception.ExceptionRecord.ExceptionCode;
deXcptAddress := Longint(Exception.ExceptionRecord.ExceptionAddress);
case deXcptCode of
STATUS_SINGLE_STEP:
deCode := decSingleStep;
STATUS_BREAKPOINT:
begin
deCode := decBreakpoint;
CX.ContextFlags := CONTEXT_CONTROL;
hThread := GethThread(DebugEvent.dwThreadId);
GetThreadContext(hThread, CX);
Dec(CX.EIP);
SetThreadContext(hThread, CX);
end;
else
if Exception.dwFirstChance = 0 then
Done := False
else
begin
deCode := decException;
deXcptParam1 := Exception.ExceptionRecord.ExceptionInformation[0];
deXcptParam2 := Exception.ExceptionRecord.ExceptionInformation[1];
case deXcptCode of
opecReRaise..opecSysException:
begin
DbgInterface.NotifyException(DbgEvent);
Done := False;
end;
else
if not DbgInterface.StopOnException(deXcptCode) then
begin
DbgContinueFlag := dbg_Exception_Not_Handled;
Done := False;
end;
end;
end;
end;
end;
EXIT_PROCESS_DEBUG_EVENT:
deCode := decProcessEnded;
RIP_EVENT:
deError := RipInfo.dwError
else
Done := False;
end;
until Done;
end;
{$IFDEF PharlapETS}
function ETSTerminateProcess(hThread: THandle; ExitCode: Longint): LongBool; StdCall; external 'etsdebug.dll' name '_ETSTerminateProcess@8';
{$ENDIF}
function SysDbgTerminateProcess: Longint;
var
Success: Boolean;
CX: TContext;
Regs: TSysDbgCPURegisters;
DbgEvent: TSysDbgEvent;
begin
if not ProcessTerminated then
begin
{$IFDEF PharlapETS}
ETSTerminateProcess(ProcessInfo.hThread, 1);
{$ELSE}
Regs.ThreadHandle := ProcessInfo.hThread;
Regs.ThreadID := ProcessInfo.dwThreadId;
CX.ContextFlags := CONTEXT_CONTROL;
GetThreadContext(ProcessInfo.hThread, CX);
CX.EIP := Longint(GetProcAddress(GetModuleHandle('kernel32.dll'), 'ExitProcess'));
SetThreadContext(ProcessInfo.hThread, CX);
SysDbgExecute(False, Regs, DbgEvent);
if not ProcessTerminated then
repeat
Success := ContinueDebugEvent(DebugEvent.dwProcessId, DebugEvent.dwThreadId, dbg_Terminate_Process);
if Success then
begin
Success := WaitForDebugEvent(DebugEvent, Infinite);
HandleEvent(DebugEvent);
end;
until not Success or
(DebugEvent.dwDebugEventCode = EXIT_PROCESS_DEBUG_EVENT) or
(DebugEvent.dwDebugEventCode = RIP_EVENT);
{$ENDIF}
end;
Result := 0;
end;
function SysDbgReadRegisters(Regs: PSysDbgCPURegisters; FPUState: PSysDbgFSaveFormat): Boolean;
var
CX: TContext;
begin
if FPUState = nil then
CX.ContextFlags := CONTEXT_FULL
else
CX.ContextFlags := CONTEXT_FLOATING_POINT;
with Regs^ do
begin
Result := GetThreadContext(ThreadHandle, CX);
if Result then
if FPUState <> nil then
Move(CX.FloatSave, FPUState^, SizeOf(FPUState^))
else
begin
GS := CX.SegGs;
FS := CX.SegFs;
ES := CX.SegEs;
DS := CX.SegDs;
EDI := CX.Edi;
ESI := CX.Esi;
EBX := CX.Ebx;
EDX := CX.Edx;
ECX := CX.Ecx;
EAX := CX.Eax;
EBP := CX.Ebp;
EIP := CX.Eip;
CS := CX.SegCs;
EFlags := CX.EFlags;
ESP := CX.Esp;
SS := CX.SegSs;
end;
end;
end;
function SysDbgWriteRegisters(Regs: PSysDbgCPURegisters; FPUState: PSysDbgFSaveFormat): Boolean;
var
CX: TContext;
begin
with Regs do
begin
if FPUState = nil then
begin
CX.ContextFlags := CONTEXT_FULL;
CX.SegGs := GS;
CX.SegFs := FS;
CX.SegEs := ES;
CX.SegDs := DS;
CX.Edi := EDI;
CX.Esi := ESI;
CX.Ebx := EBX;
CX.Edx := EDX;
CX.Ecx := ECX;
CX.Eax := EAX;
CX.Ebp := EBP;
CX.Eip := EIP;
CX.SegCs := CS;
CX.EFlags := EFlags;
CX.Esp := ESP;
CX.SegSs := SS;
end
else
begin
FillChar(CX, SizeOf(CX), 0);
CX.ContextFlags := CONTEXT_FLOATING_POINT;
Move(FPUState^, CX.FloatSave, SizeOf(FPUState^));
end;
Result := SetThreadContext(ThreadHandle, CX);
end;
end;
function SysDbgFreezeThread(const Regs: TSysDbgCPURegisters): Boolean;
begin
Result := SuspendThread(Regs.ThreadHandle) <> $FFFFFFFF;
end;
function SysDbgResumeThread(const Regs: TSysDbgCPURegisters): Boolean;
begin
Result := ResumeThread(Regs.ThreadHandle) <> $FFFFFFFF;
end;
function SysDbgGetThreadState(const Regs: TSysDbgCPURegisters; var State: TSysDbgThreadState): Boolean;
var
Count: Integer;
begin
with State, Regs do
begin
Count := SuspendThread(ThreadHandle);
Result := Count <> $FFFFFFFF;
IsFrozen := Count > 0;
Schedule := 0;
Priority := GetThreadPriority(ThreadHandle);
ResumeThread(ThreadHandle);
end;
end;
type
PDRs = ^TDRs;
TDRs = array [0..3] of DWord;
function SysDbgSetWatchPoint(LinAddr: Longint; BkptLen,BkptType: Byte; ThreadID: Longint): Longint;
var
I,W: Integer;
Success: Bool;
P: PSysDbgThreadIds;
CX: TContext;
const // Execute,Write,Read-Write
DR7Types: array[1..3] of Byte = (0, 1, 3);
begin
if WatchPtCount >= 4 then
Result := 0
else
begin
I := 0;
repeat
P := DbgInterface.GetThreadParam(I);
if (P <> nil) and ((ThreadID = 0) or (P^.ThreadId = ThreadID)) then
begin
CX.ContextFlags := CONTEXT_DEBUG_REGISTERS;
Success := GetThreadContext(P^.ThreadHandle, CX);
if Success then
begin
W := WatchPtCount;
PDRs(@CX.DR0)^[W] := LinAddr;
CX.DR7 := (CX.DR7 and not ($F shl (16 + (W*4)))) or ($0001 shl (W*2)) or
(DR7Types[BkptType] shl (16 + W*4)) or ((BkptLen-1) shl (18 + W*4));
Success := SetThreadContext(P^.ThreadHandle, CX);
end;
if not Success then
begin
Result := 0;
Exit;
end;
end;
Inc(I);
until P = nil;
Inc(WatchPtCount);
Result := WatchPtCount;
end;
end;
procedure SysDbgClearWatchPoint(Id: Longint);
var
I: Integer;
P: PSysDbgThreadIds;
CX: TContext;
begin
Dec(Id);
I := 0;
repeat
P := DbgInterface.GetThreadParam(I);
if P <> nil then
begin
CX.ContextFlags := CONTEXT_DEBUG_REGISTERS;
if GetThreadContext(P^.ThreadHandle, CX) then
begin
PDRs(@CX.DR0)^[Id] := 0;
CX.DR7 := CX.DR7 and not (($1 shl (Id*2)) or ($F shl (16 + (Id*4))));
SetThreadContext(P^.ThreadHandle, CX);
end;
end;
Inc(I);
until P = nil;
Dec(WatchPtCount);
end;
{$ENDIF}
procedure SysDbgSetInterface(var DbgInt: TSysDbgInterface);
begin
DbgInterface := DbgInt;
end;
procedure SysDbgInitialize;
begin
SysDbgGetFlatInfo(FlatInfo);
end;
procedure SysDbgGetIDEInterface(var IDEInt: TSysDbgIDEInterface);
begin
with IDEInt do
begin
SysDbgVersion := 3;
{$IFDEF WIN32}
SysDbgPlatforms := [dpWin32];
{$ELSE}
SysDbgPlatforms := [dpOS2];
{$ENDIF}
SysDbgInitialize := VPDbgAPI.SysDbgInitialize;
SysDbgGetFlatInfo := VPDbgAPI.SysDbgGetFlatInfo;
SysDbgSetInterface := VPDbgAPI.SysDbgSetInterface;
SysDbgStartProcess := VPDbgAPI.SysDbgStartProcess;
SysDbgTerminateProcess := VPDbgAPI.SysDbgTerminateProcess;
SysDbgSelToFlat := VPDbgAPI.SysDbgSelToFlat;
SysDbgReadMemory := VPDbgAPI.SysDbgReadMemory;
SysDbgWriteMemory := VPDbgAPI.SysDbgWriteMemory;
SysDbgReadRegisters := VPDbgAPI.SysDbgReadRegisters;
SysDbgWriteRegisters := VPDbgAPI.SysDbgWriteRegisters;
SysDbgFreezeThread := VPDbgAPI.SysDbgFreezeThread;
SysDbgResumeThread := VPDbgAPI.SysDbgResumeThread;
SysDbgGetThreadState := VPDbgAPI.SysDbgGetThreadState;
SysDbgSetWatchPoint := VPDbgAPI.SysDbgSetWatchPoint;
SysDbgClearWatchPoint := VPDbgAPI.SysDbgClearWatchPoint;
SysDbgExecute := VPDbgAPI.SysDbgExecute;
SysDbgWaitUserScreen := VPDbgAPI.SysDbgWaitUserScreen;
SysDbgSetHardMode := VPDbgAPI.SysDbgSetHardMode;
SysDbgSwitchScreen := VPDbgAPI.SysDbgSwitchScreen;
end;
end;
{$ELSE}
type
TGetIDEInterface = procedure(var IDEInt: TSysDbgIDEInterface);
var
GetIDEInterface: Pointer;
DllHandle: HModule;
LoadError: Longint;
procedure SysDbgGetIDEInterface(var IDEInt: TSysDbgIDEInterface);
begin
IDEInt.SysDbgVersion := - LoadError; // Not loaded
if Assigned(GetIDEInterface) then
TGetIDEInterface(GetIDEInterface)(IDEInt);
end;
{$IFDEF WIN32}
initialization
DllHandle := LoadLibrary('VPDBGDLL.DLL');
if DllHandle = 0 then
LoadError := GetLastError;
GetIDEInterface := GetProcAddress(DllHandle, 'SysDbgGetIDEInterface');
finalization
FreeLibrary(DllHandle);
{$ELSE}
var
FullDllName: array[0..260] of Char;
DllNameStr: ShortString absolute FullDllName;
function MakeFullDllName(FileName: PChar): PChar;
var
I: Integer;
begin
DllNameStr := ParamStr(0);
I := Length(DllNameStr);
while (I > 1) and not (DllNameStr[I] in [':', '\']) do
Dec(I);
repeat
Inc(I);
DllNameStr[I] := FileName^;
Inc(FileName);
until (FileName-1)^ = #0;
Result := @DllNameStr[1];
end;
initialization
LoadError := DosLoadModule(nil, 0, MakeFullDllName('VPDBGDLL.DLL'), DllHandle);
DosQueryProcAddr(DllHandle, 0, 'SysDbgGetIDEInterface', GetIDEInterface);
finalization
DosFreeModule(DllHandle);
{$ENDIF}
{$ENDIF}
end.