From: "Dmitriy I. Balashov" <Dmitriy.I.Balashov@p1.f1481.n5020.z2.fidonet.org>
Date: Wed, 07 Feb 2001 00:22:49 +0300
Subj: FAQ (demo version)
--[ Что такое и где брать ]---------------------------------------------------
Q: Что такое VP?
Q: Какие версии VP были или есть на данный момент?
Q: Под какие платформы умеет компилировать?
Q: А где можно взять?
Q: А где брать TV 2.01 и Object Proffesional, которые требуются во время
установки?
--[ IDE ]---------------------------------------------------------------------
Q: Можно ли сделать в VP, чтобы программа запускалась не в отдельном окне, а в
основном?
Q: VP почему-то не видит директории с атрибутом "folder is ready for archi-
ving".
Q: Почему в VP после Ctrl+F9 пpограмма пеpеключается в фуллскpин, хотя выстав-
лено application type: compatible with GUI?
--[ Дополнительные модули, их ошибки и как с ними бороться ]------------------
Q: Какие есть библиотеки для доступа к базам данных на SQL?
Q: Какие есть библиотеки для работы с TCP/IP и где взять соответствующую доку-
ментацию по рпботе с функциями стека?
Q: Откуда в CRT.PAS берется утечка памяти?
--[ Что такое и где брать ]---------------------------------------------------
Q: Что такое VP?
A: VP - Virtual Pascal - это редактор и компилятор программ на языке Pascal.
а первый взгляд напоминает по интерфейсу Borland Pascal. Автором VP яв-
ляется Виталий Мирьянов (Vitaly Miryanov).
Q: Какие версии VP были или есть на данный момент?
A: Существует две версии VP: 1.10 - получивший наибольшее распростронение до
выхода второй версии VP, работающий и компилирующий программы исключительно
под OS/2. Также существует версия 2.1.231, которая свободно распространяет-
ся. Работает также под Win32 платформами.
Q: Под какие платформы умеет компилировать?
A: а данный момент VP может собирать программы при едином коде под 4-е плат-
формы: OS/2, Win32, Linux и DPMI32. Последнии две ставятся как дополнитель-
ные модули.
Q: А где можно взять?
A: Сам VP можно найти по адресу http://www.vpascal.com/bin. На сервере так же
есть ссылки на необходимые модули для сбора программ под DPMI32 и Linux.
DPMI32 модули можно найти по адресу http://141.43.1.21/~kannegv/vpascal.
Q: А где брать Object Proffesional, который требуется во время установки?
A: TV поставляется с Borland Bascal, а инсталлер VP пропатчит их под себя. А
OPro можно взять отсюда: http://raven66.newmail.ru/public/opro130.rar.
--[ IDE ]---------------------------------------------------------------------
Q: Можно ли сделать в VP, чтобы программа запускалась не в отдельном окне, а в
основном?
A: Можно, достаточно в VPDBGDLL.PAS исправить следующий кусок (но нельза будет
посмотреть User screen):
---------------------------------------------------------------------------
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
));
---------------------------------------------------------------------------
Здесь следует убрать "_ create_New_Console".
A: Можно, достаточно VPDBGDLL.PAS довести до следующего вида + еще подрихто-
вать и будет работать как в BP:
---------------------------------------------------------------------------
library vpDBGdll;
{
(q) by fPrint Co. UK, 19хз-1999.
(q) by sergey korowkin, 2000.
[fullscreen team] [ODAPI team]
2:6033/27@fidonet, http://www.mart.ru/~fidonet, sk@sp0raw.riddle.spb.ru
фичи: отлаживаемая пpога пускается в той же консоли, что и VP, пpи этом
свопятся экpаны ide/пpоги. пpи попапе по бpяку/экскепшену экpан пpоги
сохpаняется, восстанавливается IDEшный и тп. в ide pаботает alt-F5.
так, в общем, начинает окончательно напоминать BP :)
стpанности: попpобуйте написать пpогу "begin readln; end." - readln вообще
не отзывается =( то есть он обpабатывает нажатие, обновляет
внутpенние буфеpа, возвpащает pезультат, но на экpан он ничего не
выводит.
стpанное "Go" в пpавом веpхнем на экpане пpоги =)
его там не должно...
еще что-то, но все я не упомню.
коpоче, дописывайте этот пpоект, RU.VP'шники! я не буду пpодолжать это
делать по двум пpичинам:
a) сильная занятость (на многочасовую ловлю багов у меня пpосто
нет вpемени)
b) слабое знание WinApi и отсутствие хелпов по нему.
}
{&Z-,AlignRec-,Use32+,OrgName+}
uses
Windows,
Strings,
VPSysLow,
ExeHdr,
Objects;
type
TSwitchScreen = (ssNone, ssIDE, ssProgram, ssProgramAndClear);
PCell32 = ^TCell32;
TCell32 = record
Ch: SmallWord;
Attr: SmallWord;
end;
PCell = ^TCell;
TCell = packed record
Ch: Char;
Attr: Byte;
end;
PScreen = ^TScreen;
TScreen = object(TObject)
Cursor: TPoint;
BufSize, BufSize32: Word;
Buffer, Buffer32: Pointer;
UpLeft, Size: TCoord;
ReadFrom: TSmallRect;
Info: TConsoleScreenBufferInfo;
CursorInfo: TConsoleCursorInfo;
constructor Init;
procedure Clear;
procedure Store;
procedure Load;
destructor Done; virtual;
end;
constructor TScreen.Init;
begin
inherited Init;
Cursor.X:=0;
Cursor.Y:=0;
GetConsoleScreenBufferInfo(SysFileStdOut, Info);
BufSize:=(Info.dwSize.Y + 1) * (Info.dwSize.X + 1) * SizeOf(TCell);
BufSize32:=(Info.dwSize.Y + 1) * (Info.dwSize.X + 1) * SizeOf(TCell32);
GetMem(Buffer, BufSize);
Size.X:=Info.dwSize.X;
Size.Y:=Info.dwSize.Y;
UpLeft.X:=0;
UpLeft.Y:=0;
ReadFrom.Left:=0;
ReadFrom.Top:=0;
ReadFrom.Right:=Info.dwSize.X;
ReadFrom.Bottom:=Info.dwSize.Y;
Clear;
end;
procedure TScreen.Clear;
var
a: PCell;
Y, X: Longint;
begin
Cursor.X:=0;
Cursor.Y:=0;
a:=Buffer;
for Y:=0 to Info.dwSize.Y - 1 do
for X:=0 to Info.dwSize.X - 1 do
begin
a^.Ch:=' ';
a^.Attr:=$07;
Inc(a);
end;
CursorInfo.dwSize:=$0701;
CursorInfo.bVisible:=True;
end;
procedure TScreen.Store; { real -> virtual }
var
a: PCell32;
b: PCell;
X, Y: Longint;
begin
GetMem(Buffer32, BufSize32);
GetConsoleScreenBufferInfo(SysFileStdOut, Info);
Cursor.X:=Info.dwCursorPosition.X;
Cursor.Y:=Info.dwCursorPosition.Y;
ReadConsoleOutput(SysFileStdOut, Buffer32, Size, UpLeft, ReadFrom);
a:=Buffer32;
b:=Buffer;
for Y:=0 to Info.dwSize.Y - 1 do
for X:=0 to Info.dwSize.X - 1 do
begin
b^.Ch:=Chr(a^.Ch);
b^.Attr:=Byte(a^.Attr);
Inc(a);
Inc(b);
end;
FreeMem(Buffer32, BufSize32);
GetConsoleCursorInfo(SysFileStdOut, CursorInfo);
end;
procedure TScreen.Load; { virtual -> real }
var
a: PCell;
b: PCell32;
X, Y: Longint;
c: TCoord;
begin
GetMem(Buffer32, BufSize32);
a:=Buffer;
b:=Buffer32;
for Y:=0 to Info.dwSize.Y - 1 do
for X:=0 to Info.dwSize.X - 1 do
begin
b^.Ch:=Ord(a^.Ch);
b^.Attr:=a^.Attr;
Inc(a);
Inc(b);
end;
WriteConsoleOutput(SysFileStdOut, Buffer32, Size, UpLeft, ReadFrom);
c.X:=Cursor.X;
c.Y:=Cursor.Y;
SetConsoleCursorPosition(SysFileStdOut, c);
CursorInfo.bVisible:=True;
SetConsoleCursorInfo(SysFileStdOut, CursorInfo);
FreeMem(Buffer32, BufSize32);
end;
destructor TScreen.Done;
begin
FreeMem(Buffer, BufSize);
inherited Done;
end;
const
CurrentMode: TSwitchScreen = ssNone;
IDE: PScreen = nil;
Prg: PScreen = nil;
procedure SwitchScreen(const Mode: TSwitchScreen);
begin
if (IDE = nil) and (PRG = nil) then
begin
IDE:=New(PScreen, Init);
Prg:=New(PScreen, Init);
IDE^.Store;
end;
case Mode of
ssIDE:
begin
Prg^.Store;
IDE^.Load;
end;
ssProgram:
begin
IDE^.Store;
Prg^.Load;
end;
ssProgramAndClear:
begin
IDE^.Store;
Prg^.Clear;
Prg^.Load;
end;
ssNone:
begin
IDE^.Load;
Dispose(IDE, Done);
Dispose(Prg, Done);
IDE:=nil;
Prg:=nil;
end;
end;
CurrentMode:=Mode;
end;
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;
var
FlatInfo: TSysDbgFlatInfo;
DbgInterface: TSysDbgInterface;
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 := VPdbgdll.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);
ShowWindow(Param.swpWnd, sw_Restore);
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
SwitchScreen(ssNone);
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;
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
SwitchScreen(ssProgramAndClear);
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_UseStdHandles;
lpTitle := StrPCopy(TitleBuf, FileName + ' (VP debugging)');
hStdInput := SysFileStdIn;
hStdOutput := SysFileStdOut;
hStdError := SysFileStdErr;
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
else
SwitchScreen(ssNone);
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;
function SysDbgTerminateProcess: Longint;
var
Success: Boolean;
CX: TContext;
Regs: TSysDbgCPURegisters;
DbgEvent: TSysDbgEvent;
begin
if not ProcessTerminated then
begin
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);
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;
procedure SysDbgSetInterface(var DbgInt: TSysDbgInterface);
begin
DbgInterface := DbgInt;
end;
procedure SysDbgInitialize;
begin
SysDbgGetFlatInfo(FlatInfo);
end;
procedure SysDbgSwitchScreen(User: Boolean); forward;
procedure SysDbgGetIDEInterface(var IDEInt: TSysDbgIDEInterface); export;
begin
with IDEInt do
begin
SysDbgVersion := 3;
SysDbgPlatforms := [dpWin32];
SysDbgInitialize := vpDBGdll.SysDbgInitialize;
SysDbgGetFlatInfo := vpDBGdll.SysDbgGetFlatInfo;
SysDbgSetInterface := vpDBGdll.SysDbgSetInterface;
SysDbgStartProcess := vpDBGdll.SysDbgStartProcess;
SysDbgTerminateProcess := vpDBGdll.SysDbgTerminateProcess;
SysDbgSelToFlat := vpDBGdll.SysDbgSelToFlat;
SysDbgReadMemory := vpDBGdll.SysDbgReadMemory;
SysDbgWriteMemory := vpDBGdll.SysDbgWriteMemory;
SysDbgReadRegisters := vpDBGdll.SysDbgReadRegisters;
SysDbgWriteRegisters := vpDBGdll.SysDbgWriteRegisters;
SysDbgFreezeThread := vpDBGdll.SysDbgFreezeThread;
SysDbgResumeThread := vpDBGdll.SysDbgResumeThread;
SysDbgGetThreadState := vpDBGdll.SysDbgGetThreadState;
SysDbgSetWatchPoint := vpDBGdll.SysDbgSetWatchPoint;
SysDbgClearWatchPoint := vpDBGdll.SysDbgClearWatchPoint;
SysDbgExecute := vpDBGdll.SysDbgExecute;
SysDbgWaitUserScreen := vpDBGdll.SysDbgWaitUserScreen;
SysDbgSetHardMode := vpDBGdll.SysDbgSetHardMode;
SysDbgSwitchScreen := vpDBGdll.SysDbgSwitchScreen;
end;
end;
procedure SysDbgSwitchScreen(User: Boolean);
begin
if User then
SwitchScreen(ssProgram)
else
SwitchScreen(ssIDE);
end;
exports
SysDbgGetIDEInterface;
begin
end.
---------------------------------------------------------------------------
Q: VP почему-то не видит директории с атрибутом "folder is ready for archi-
ving".
A: Такой баг действительно есть и он проявляется под W2K и Win98. С чем это
связано, пока не установлено.
Q: Почему в VP после Ctrl+F9 пpограмма пеpеключается в фуллскpин, хотя выстав-
лено application type: compatible with GUI?
A: Следует поставить крестик здесь:
Options -> Debugger -> [ ] Run in VIO window
--[ Дополнительные модули, их ошибки и как с ними бороться ]------------------
Q: Какие есть библиотеки для доступа к базам данных на SQL?
A: Есть библиотеки для доступа к MySQL и mSQL. аходятся где-то в I-net'е.
Q: Какие есть библиотеки для работы с TCP/IP и где взять соответствующую доку-
ментацию по рпботе с функциями стека?
A: Существует достаточно модулей для написания программ по работе с TCP/IP
стеком. Соответствующий модуль есть и в VP: WINSOCK.PAS. Также модули по
работе с TCP/IP можно найти на http://www.vpascal.com или на
http://vv.os2.dhs.org.
о нормальная документация по работе со стеком есть только в Toolkit'е для
OS/2.
Q: Откуда в CRT.PAS берется утечка памяти?
A: Michail A.Baikov 2:5020/1305
Леак обнаpyжен в пpоцедypе опpеделения позиции кypсоpа. Модyль vpwin32 или
как там его. Конкpетно когда создается кypсоpный тpейд и добавляется пpоце-
дypа завеpшения тpейда, но почемy-то эта пpоцедypа не исполнятся (точнее не
очищает память). нда ... :( я подпpавил, но надеюсь vpшники о баге знают и
сами пофиксят:
procedure InitialiseCursorThread;
var
sbi: TConsoleScreenBufferInfo;
begin
if tidCursor = -1 then
begin
// Get initial cursor position
GetConsoleScreenBufferInfo(SysConOut, sbi);
CurXPos := sbi.dwCursorPosition.x;
CurYPos := sbi.dwCursorPosition.y;
>!
semCursor := SemCreateEvent(nil, false, false);
> BeginThread(nil, 16384, CursorThreadFunc, nil, 0, tidCursor );
SemPostEvent(semCursor);
>> AddExitProc(CursorThreadExitProc);
>!
end;
end;
создается вот тyт лик, и по идее во втоpом слyчае должен все очищать. Опи-
сание что такое AddExitProc я нашел в system.pas, это какой-то список пpо-
цедyp, котоpые должны запyскатся пpи завеpшении pаботы ...
вообщем вpеменный фикс коммент все от >! до >!
|