Главная > Програмное обеспечение > Редакторы/Офисы >
VP FAQ

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еменный фикс коммент все от >! до >!



Украинская Баннерная Сеть

Главная  Алфавитный индекс  Справка  Добавить FAQ  E-mail
Новости  Поиск по сайту

Copyright © 2001 - 2002 Olexandr Slobodyan.
Сайт создан в системе uCoz