[Back to WIN-OS2 SWAG index] [Back to Main SWAG index] [Original]

    {
      WinDump : visualizzazione messaggi di debug.

      Written by:       Michele Mottini
                        TERA S.r.l.
                        CIS 100040,615
    }
    unit WinDump;

    {$S-}

    interface

    uses
      WinTypes,
      WinProcs,
      WinDos;

    const
      ScreenWidth = 80;

      WindowOrg: TPoint =                       { CRT window origin }
        (X: cw_UseDefault; Y: cw_UseDefault);
      WindowSize: TPoint =                      { CRT window size }
        (X: cw_UseDefault; Y: cw_UseDefault);
      ScreenSize: TPoint = (X: ScreenWidth; Y: 32000);   { Virtual screen dimensions }
      Cursor: TPoint = (X: 0; Y: 0);            { Cursor location }
      Origin: TPoint = (X: 0; Y: 0);            { Client area origin }
      InactiveTitle: PChar = '(Inactive %s)';   { Inactive window title }
      AutoTracking: Boolean = True;             { Track cursor on Write? }
      CheckEOF: Boolean = False;                { Allow Ctrl-Z for EOF? }
      CheckBreak: Boolean = True;               { Allow Ctrl-C for break? }

    var
      WindowTitle: array[0..79] of Char;        { CRT window title }

    procedure InitWinCrt;
    procedure DoneWinCrt;

    procedure WriteBuf(Buffer: PChar; Count: Word);
    procedure WriteChar(Ch: Char);

    function KeyPressed: Boolean;
    function ReadKey: Char;
    function ReadBuf(Buffer: PChar; Count: Word): Word;

    procedure GotoXY(X, Y: Integer);
    function WhereX: Integer;
    function WhereY: Integer;
    procedure ClrScr;
    procedure ClrEol;

    procedure CursorTo(X, Y: Integer);
    procedure ScrollTo(X, Y: Integer);
    procedure TrackCursor;

    procedure AssignCrt(var F: Text);

    implementation {==============================================================}

    uses
      Arit,
      Strings,
      Strings2,
      Streams;

    type

       { Double word record }

      LongRec = record
        Lo, Hi: Integer;
      end;

        { MinMaxInfo array }

      PMinMaxInfo = ^TMinMaxInfo;
      TMinMaxInfo = array[0..4] of TPoint;

    { CRT window procedure }

    function CrtWinProc(Window: HWnd;
                        Message, WParam: Word;
                        LParam: Longint): Longint; export; forward;

    { CRT window class }

    const
      CrtClass: TWndClass = (
        style: cs_HRedraw + cs_VRedraw;
        lpfnWndProc: @CrtWinProc;
        cbClsExtra: 0;
        cbWndExtra: 0;
        hInstance: 0;
        hIcon: 0;
        hCursor: 0;
        hbrBackground: 0;
        lpszMenuName: nil;
        lpszClassName: 'TPWinDump');

    const
      CrtWindow: HWnd = 0;                  { CRT window handle }
      FirstLine: Integer = 0;               { First line in circular buffer }
      KeyCount: Integer = 0;                { Count of keys in KeyBuffer }
      Created: Boolean = False;       	{ CRT window created? }
      Focused: Boolean = False;             { CRT window focused? }
      Reading: Boolean = False;             { Reading from CRT window? }
      Painting: Boolean = False;            { Handling wm_Paint? }

    var
      SaveExit: Pointer;                    { Saved exit procedure pointer }
      ScreenBuffer: TSCollection;           { Screen buffer }
      ClientSize: TPoint;                   { Client area dimensions }
      Range: TPoint;                        { Scroll bar ranges }
      CharSize: TPoint;                     { Character cell size }
      CharAscent: Integer;                  { Character ascent }
      DC: HDC;                              { Global device context }
      PS: TPaintStruct;                     { Global paint structure }
      SaveFont: HFont;                      { Saved device context font }
      KeyBuffer: array[0..63] of Char;      { Keyboard type-ahead buffer }

    {---------------------------------------------------------- Scroll keys table }

    type
      TScrollKey = record
        Key: Byte;
        Ctrl: Boolean;
        SBar: Byte;
        Action: Byte;
      end;

    const
      ScrollKeyCount = 12;
      ScrollKeys: array[1..ScrollKeyCount] of TScrollKey = (
        (Key: vk_Left;  Ctrl: False; SBar: sb_Horz; Action: sb_LineUp),
        (Key: vk_Right; Ctrl: False; SBar: sb_Horz; Action: sb_LineDown),
        (Key: vk_Left;  Ctrl: True;  SBar: sb_Horz; Action: sb_PageUp),
        (Key: vk_Right; Ctrl: True;  SBar: sb_Horz; Action: sb_PageDown),
        (Key: vk_Home;  Ctrl: False; SBar: sb_Horz; Action: sb_Top),
        (Key: vk_End;   Ctrl: False; SBar: sb_Horz; Action: sb_Bottom),
        (Key: vk_Up;    Ctrl: False; SBar: sb_Vert; Action: sb_LineUp),
        (Key: vk_Down;  Ctrl: False; SBar: sb_Vert; Action: sb_LineDown),
        (Key: vk_Prior; Ctrl: False; SBar: sb_Vert; Action: sb_PageUp),
        (Key: vk_Next;  Ctrl: False; SBar: sb_Vert; Action: sb_PageDown),
        (Key: vk_Home;  Ctrl: True;  SBar: sb_Vert; Action: sb_Top),
        (Key: vk_End;   Ctrl: True;  SBar: sb_Vert; Action: sb_Bottom));

    {------------------------------------------------------------- Configurazione }

    const
      SecName = 'WinDump';
      WindowKey = 'Window';

    procedure LoadConfig;
    var
      Buffer : array[0..80] of char;
      P : PChar;
    begin
      GetProfileString(SecName,WindowKey,'',Buffer,SizeOf(Buffer));
      P := Buffer;
      if P^ <> #0 then begin
        WindowOrg.X := StrToIntDef(StrToken(P,','),cw_UseDefault);
        if P^ <> #0 then begin
          WindowOrg.Y := StrToIntDef(StrToken(P,','),cw_UseDefault);
          if P^ <> #0 then begin
            WindowSize.X := StrToIntDef(StrToken(P,','),cw_UseDefault);
            if P^ <> #0 then begin
              WindowSize.Y := StrToIntDef(P,cw_UseDefault);
            end;
          end;
        end;
      end;
    end; { LoadConfig }

    procedure SaveConfig;
    var
      Buffer : array[0..80] of char;
    begin
      IntToStr(WindowOrg.X,Buffer);
      StrCat(Buffer,',');
      IntToStr(WindowOrg.Y,Buffer+StrLen(Buffer));
      StrCat(Buffer,',');
      IntToStr(WindowSize.X,Buffer+StrLen(Buffer));
      StrCat(Buffer,',');
      IntToStr(WindowSize.Y,Buffer+StrLen(Buffer));
      WriteProfileString(SecName,WindowKey,Buffer);
    end; { SaveConfig }

    {--------------------------------------------- Accesso al buffer dello schermo }

    var
      LineBuffer : array[0..ScreenWidth] of char;

    function ScreenPtr(X,Y : integer): PChar;
      {- Return pointer to location in screen buffer.}
    var
      L : integer;
    begin
      inc(Y, FirstLine);
      if Y >= ScreenSize.Y then dec(Y,ScreenSize.Y);
      if Y >= ScreenBuffer.Count then LineBuffer[0] := #0
      else StrCopy(LineBuffer,PChar(ScreenBuffer.At(Y)));
      L := StrLen(LineBuffer);
      FillChar(PChar(LineBuffer+L)^,ScreenWidth-L,' ');
      ScreenPtr := PChar(LineBuffer+X);
    end; { ScreenPtr }

    procedure ClearLine(Y : integer);
    var
      LinePtr : PChar;
    begin
      inc(Y, FirstLine);
      if Y >= ScreenSize.Y then dec(Y,ScreenSize.Y);
      if Y < ScreenBuffer.Count then begin
        LinePtr := PChar(ScreenBuffer.At(Y));
        FillChar(LinePtr^,StrLen(LinePtr),' ');
      end;
    end; { ClearLine }

    procedure ClearToEol(X,Y : integer);
    var
      LinePtr : PChar;
      L : integer;
    begin
      inc(Y, FirstLine);
      if Y >= ScreenSize.Y then dec(Y,ScreenSize.Y);
      if Y < ScreenBuffer.Count then begin
        LinePtr := PChar(ScreenBuffer.At(Y));
        L := StrLen(LinePtr);
        while X < L do begin
          LinePtr[X] := ' ';
          inc(X);
        end;
      end;
    end; { ClearToEol }

    procedure PutChar(X,Y : integer; C : char);
    var
      LinePtr,NewLinePtr : PChar;
      L : integer;
    begin
      inc(Y, FirstLine);
      if Y >= ScreenSize.Y then dec(Y,ScreenSize.Y);
      if Y >= ScreenBuffer.Count then begin
        FillChar(LineBuffer,succ(X),' ');
        LineBuffer[succ(X)] := #0;
        while Y >= ScreenBuffer.Count do ScreenBuffer.Insert(StrNew(LineBuffer));
      end;
      LinePtr := PChar(ScreenBuffer.At(Y));
      if X >= StrLen(LinePtr) then begin
        GetMem(NewLinePtr,X+2);
        StrCopy(NewLinePtr,LinePtr);
        L := StrLen(NewLinePtr);
        while L < X do begin
          NewLinePtr[L] := ' ';
          inc(L);
        end;
        NewLinePtr[X+1] := #0;
        StrDispose(LinePtr);
        LinePtr := NewLinePtr;
        ScreenBuffer.AtPut(Y,LinePtr);
      end;
      LinePtr[X] := C;
    end; { PutChar }

    {------------------------------------------------------------ Display context }

    procedure InitDeviceContext;
      {- Allocate device context }
    begin
      if Painting then
        DC := BeginPaint(CrtWindow, PS)
      else
        DC := GetDC(CrtWindow);
      SaveFont := SelectObject(DC, GetStockObject(System_Fixed_Font));
      SetTextColor(DC, GetSysColor(color_WindowText));
      SetBkColor(DC, GetSysColor(color_Window));
    end; { InitDeviceContext }

    procedure DoneDeviceContext;
      {- Release device context }
    begin
      SelectObject(DC, SaveFont);
      if Painting then
        EndPaint(CrtWindow, PS) else
        ReleaseDC(CrtWindow, DC);
    end; { DoneDeviceContext }

    procedure ShowCursor;
      {- Show caret }
    begin
      CreateCaret(CrtWindow, 0, CharSize.X, 2);
      SetCaretPos((Cursor.X - Origin.X) * CharSize.X,
        (Cursor.Y - Origin.Y) * CharSize.Y + CharAscent);
      ShowCaret(CrtWindow);
    end; { ShowCursor }

    procedure HideCursor;
      {- Hide caret }
    begin
      DestroyCaret;
    end; { HideCursor }

    procedure SetScrollBars;
      {- Update scroll bars }
    begin
      SetScrollRange(CrtWindow, sb_Horz, 0, Max(1, Range.X), False);
      SetScrollPos(CrtWindow, sb_Horz, Origin.X, True);
      SetScrollRange(CrtWindow, sb_Vert, 0, Max(1, Range.Y), False);
      SetScrollPos(CrtWindow, sb_Vert, Origin.Y, True);
    end; {SetScrollBars }

    procedure Terminate;
      {- Terminate CRT window.}
    begin
      if Focused and Reading then HideCursor;
      Halt(255);
    end;  { Terminate }

    procedure CursorTo(X, Y: Integer);
      {- Set cursor position }
    begin
      Cursor.X := Max(0, Min(X, ScreenSize.X - 1));
      Cursor.Y := Max(0, Min(Y, ScreenSize.Y - 1));
    end; { CursorTo }

    procedure ScrollTo(X,Y : Integer);
      {- Scroll window to given origin.}
    begin
      if Created then begin
        X := Max(0, Min(X, Range.X));
        Y := Max(0, Min(Y, Range.Y));
        if (X <> Origin.X) or (Y <> Origin.Y) then
        begin
          if X <> Origin.X then SetScrollPos(CrtWindow, sb_Horz, X, True);
          if Y <> Origin.Y then SetScrollPos(CrtWindow, sb_Vert, Y, True);
          ScrollWindow(CrtWindow,
    	(Origin.X - X) * CharSize.X,
    	(Origin.Y - Y) * CharSize.Y, nil, nil);
          Origin.X := X;
          Origin.Y := Y;
          UpdateWindow(CrtWindow);
        end;
      end;
    end; { ScrollTo }

    procedure TrackCursor;
      {- Scroll to make cursor visible.}
    begin
      ScrollTo(Max(Cursor.X - ClientSize.X + 1, Min(Origin.X, Cursor.X)),
        Max(Cursor.Y - ClientSize.Y + 1, Min(Origin.Y, Cursor.Y)));
    end; { TrackCursor }

    procedure ShowText(L, R : Integer);
      {- Update text on cursor line.}
    begin
      if L < R then begin
        InitDeviceContext;
        TextOut(DC, (L - Origin.X) * CharSize.X,
          (Cursor.Y - Origin.Y) * CharSize.Y,
          ScreenPtr(L, Cursor.Y), R - L);
        DoneDeviceContext;
      end;
    end; { ShowText }

    procedure WriteBuf(Buffer: PChar; Count: Word);
      {- Write text buffer to CRT window.}
    var
      L, R: Integer;

      procedure NewLine;
      begin
        ShowText(L, R);
        L := 0;
        R := 0;
        Cursor.X := 0;
        Inc(Cursor.Y);
        if Cursor.Y = ScreenSize.Y then begin
          Dec(Cursor.Y);
          Inc(FirstLine);
          if FirstLine = ScreenSize.Y then FirstLine := 0;
          ClearLine(Cursor.Y);
          ScrollWindow(CrtWindow, 0, -CharSize.Y, nil, nil);
          UpdateWindow(CrtWindow);
        end;
      end; { NewLine }

    begin { WriteBuf }
      InitWinCrt;
      L := Cursor.X;
      R := Cursor.X;
      while Count > 0 do begin
        case Buffer^ of
          #32..#255:
    	begin
    	  PutChar(Cursor.X, Cursor.Y,Buffer^);
    	  Inc(Cursor.X);
    	  if Cursor.X > R then R := Cursor.X;
    	  if Cursor.X = ScreenSize.X then NewLine;
    	end;
          #13:
    	NewLine;
          #8:
    	if Cursor.X > 0 then begin
    	  Dec(Cursor.X);
    	  PutChar(Cursor.X, Cursor.Y,' ');
    	  if Cursor.X < L then L := Cursor.X;
    	end;
          #7:
            MessageBeep(0);
        end;
        Inc(Buffer);
        Dec(Count);
      end;
      ShowText(L, R);
      if AutoTracking then TrackCursor;
    end; { WriteBuf }

    procedure WriteChar(Ch: Char);
      {- Write character to CRT window }
    begin
      WriteBuf(@Ch,1);
    end; { WriteChar }

    function KeyPressed: Boolean;
      {- Return keyboard status }
    var
      M: TMsg;
    begin
      InitWinCrt;
      while PeekMessage(M, 0, 0, 0, pm_Remove) do
      begin
        if M.Message = wm_Quit then Terminate;
        TranslateMessage(M);
        DispatchMessage(M);
      end;
      KeyPressed := KeyCount > 0;
    end; { KeyPressed }

    function ReadKey: Char;
      {- Read key from CRT window.}
    begin
      TrackCursor;
      if not KeyPressed then
      begin
        Reading := True;
        if Focused then ShowCursor;
        repeat WaitMessage until KeyPressed;
        if Focused then HideCursor;
        Reading := False;
      end;
      ReadKey := KeyBuffer[0];
      Dec(KeyCount);
      Move(KeyBuffer[1], KeyBuffer[0], KeyCount);
    end; { ReadKey }

    function ReadBuf(Buffer: PChar; Count: Word): Word;
      {- Read text buffer from CRT window.}
    var
      Ch: Char;
      I: Word;
    begin
      I := 0;
      repeat
        Ch := ReadKey;
        case Ch of
          #8:
    	if I > 0 then begin
    	  Dec(I);
    	  WriteChar(#8);
    	end;
          #32..#255:
    	if I < Count - 2 then
    	begin
    	  Buffer[I] := Ch;
    	  Inc(I);
    	  WriteChar(Ch);
    	end;
        end;
      until (Ch = #13) or (CheckEOF and (Ch = #26));
      Buffer[I] := Ch;
      Inc(I);
      if Ch = #13 then
      begin
        Buffer[I] := #10;
        Inc(I);
        WriteChar(#13);
      end;
      TrackCursor;
      ReadBuf := I;
    end; { ReadBuf }

    procedure GotoXY(X, Y: Integer);
      {- Set cursor position.}
    begin
      CursorTo(X - 1, Y - 1);
    end; { GotoXY }

    function WhereX: Integer;
      {- Return cursor X position.}
    begin
      WhereX := Cursor.X + 1;
    end; { WhereX }

    function WhereY: Integer;
      {- Return cursor Y position.}
    begin
      WhereY := Cursor.Y + 1;
    end; { WhereY }

    procedure ClrScr;
      {- Clear screen.}
    begin
      InitWinCrt;
      ScreenBuffer.FreeAll;
      Longint(Cursor) := 0;
      Longint(Origin) := 0;
      SetScrollBars;
      InvalidateRect(CrtWindow, nil, True);
      UpdateWindow(CrtWindow);
    end; { ClrScr }

    procedure ClrEol;
      {- Clear to end of line.}
    begin
      InitWinCrt;
      ClearToEol(Cursor.X, Cursor.Y);
      ShowText(Cursor.X, ScreenSize.X);
    end; { ClrEol }

    {-------------------------------------------------- Gestione messaggi Windows }

    procedure WindowCreate;
      {- wm_Create message handler.}
    begin
      Created := True;
      ScreenBuffer.Init(25,25);
      if not CheckBreak then
        EnableMenuItem(GetSystemMenu(CrtWindow, False), sc_Close,
          mf_Disabled + mf_Grayed);
    end; { WindowCreate }

    procedure WindowPaint;
      {- wm_Paint message handler.}
    var
      X1, X2, Y1, Y2: Integer;
    begin
      Painting := True;
      InitDeviceContext;
      X1 := Max(0, PS.rcPaint.left div CharSize.X + Origin.X);
      X2 := Min(ScreenSize.X,
        (PS.rcPaint.right + CharSize.X - 1) div CharSize.X + Origin.X);
      Y1 := Max(0, PS.rcPaint.top div CharSize.Y + Origin.Y);
      Y2 := Min(ScreenSize.Y,
        (PS.rcPaint.bottom + CharSize.Y - 1) div CharSize.Y + Origin.Y);
      while Y1 < Y2 do begin
        TextOut(DC, (X1 - Origin.X) * CharSize.X, (Y1 - Origin.Y) * CharSize.Y,
          ScreenPtr(X1, Y1), X2 - X1);
        Inc(Y1);
      end;
      DoneDeviceContext;
      Painting := False;
    end; { WindowPaint }

    procedure WindowScroll(Which, Action, Thumb: Integer);
      {- wm_VScroll and wm_HScroll message handler.}
    var
      X,Y : integer;

      function GetNewPos(Pos, Page, Range: Integer): Integer;
      begin
        case Action of
          sb_LineUp        : GetNewPos := Pos - 1;
          sb_LineDown      : GetNewPos := Pos + 1;
          sb_PageUp        : GetNewPos := Pos - Page;
          sb_PageDown      : GetNewPos := Pos + Page;
          sb_Top           : GetNewPos := 0;
          sb_Bottom        : GetNewPos := Range;
          sb_ThumbPosition : GetNewPos := Thumb;
        else
          GetNewPos := Pos;
        end;
      end; { GetNewPos }

    begin { WindowScroll }
      X := Origin.X;
      Y := Origin.Y;
      case Which of
        sb_Horz: X := GetNewPos(X, ClientSize.X div 2, Range.X);
        sb_Vert: Y := GetNewPos(Y, ClientSize.Y, Range.Y);
      end;
      ScrollTo(X, Y);
    end; { WindowScroll }

    procedure WindowResize(X, Y: Integer);
      {- wm_Size message handler.}
    begin
      if Focused and Reading then HideCursor;
      ClientSize.X := X div CharSize.X;
      ClientSize.Y := Y div CharSize.Y;
      Range.X := Max(0, ScreenSize.X - ClientSize.X);
      Range.Y := Max(0, ScreenSize.Y - ClientSize.Y);
      Origin.X := Min(Origin.X, Range.X);
      Origin.Y := Min(Origin.Y, Range.Y);
      SetScrollBars;
      if Focused and Reading then ShowCursor;
    end; { WindowResize }

    procedure WindowMinMaxInfo(MinMaxInfo: PMinMaxInfo);
      {- wm_GetMinMaxInfo message handler.}
    var
      X, Y: Integer;
      Metrics: TTextMetric;
    begin
      InitDeviceContext;
      GetTextMetrics(DC, Metrics);
      CharSize.X := Metrics.tmMaxCharWidth;
      CharSize.Y := Metrics.tmHeight + Metrics.tmExternalLeading;
      CharAscent := Metrics.tmAscent;
      X := Min(ScreenSize.X * CharSize.X + GetSystemMetrics(sm_CXVScroll),
        GetSystemMetrics(sm_CXScreen)) + GetSystemMetrics(sm_CXFrame) * 2;
      Y := GetSystemMetrics(sm_CYScreen) + GetSystemMetrics(sm_CYFrame) * 2;
      MinMaxInfo^[1].x := X;
      MinMaxInfo^[1].y := Y;
      MinMaxInfo^[3].x := CharSize.X * 16 + GetSystemMetrics(sm_CXVScroll) +
        GetSystemMetrics(sm_CXFrame) * 2;
      MinMaxInfo^[3].y := CharSize.Y * 4 + GetSystemMetrics(sm_CYHScroll) +
        GetSystemMetrics(sm_CYFrame) * 2 + GetSystemMetrics(sm_CYCaption);
      MinMaxInfo^[4].x := X;
      MinMaxInfo^[4].y := Y;
      DoneDeviceContext;
    end; { WindowMinMaxInfo }

    procedure WindowChar(Ch: Char);
      {- wm_Char message handler.}
    begin
      if CheckBreak and (Ch = #3) then Terminate;
      if KeyCount < SizeOf(KeyBuffer) then begin
        KeyBuffer[KeyCount] := Ch;
        Inc(KeyCount);
      end;
    end; { WindowChar }

    procedure WindowKeyDown(KeyDown: Byte);
      {- wm_KeyDown message handler.}
    var
      CtrlDown: Boolean;
      I: Integer;
    begin
      if CheckBreak and (KeyDown = vk_Cancel) then Terminate;
      CtrlDown := GetKeyState(vk_Control) < 0;
      for I := 1 to ScrollKeyCount do
        with ScrollKeys[I] do
          if (Key = KeyDown) and (Ctrl = CtrlDown) then begin
    	WindowScroll(SBar, Action, 0);
    	Exit;
          end;
    end; { WindowKeyDown }

    procedure WindowSetFocus;
      {- wm_SetFocus message handler }
    begin
      Focused := True;
      if Reading then ShowCursor;
    end; { WindowSetFocus }

    procedure WindowKillFocus;
      {- wm_KillFocus message handler }
    begin
      if Reading then HideCursor;
      Focused := False;
    end; { WindowKillFocus }

    procedure WindowDestroy;
      {- wm_Destroy message handler.}
    var
      Rect : TRect;
    begin
      GetWindowRect(CrtWindow,Rect);
      with Rect do begin
        WindowOrg.X  := Left;
        WindowOrg.Y  := Top;
        WindowSize.X := Right-Left;
        WindowSize.Y  := Bottom-Top;
      end;
      ScreenBuffer.Done;
      Longint(Cursor) := 0;
      Longint(Origin) := 0;
      Created := False;
    end; { WindowDestroy }

    function CrtWinProc(Window: HWnd;
                        Message, WParam: Word;
                        LParam: Longint): Longint;
      {- CRT window procedure }
    begin
      CrtWinProc := 0;
      CrtWindow := Window;
      case Message of
        wm_Create        : WindowCreate;
        wm_Paint         : WindowPaint;
        wm_VScroll       : WindowScroll(sb_Vert, WParam, LongRec(LParam).Lo);
        wm_HScroll       : WindowScroll(sb_Horz, WParam, LongRec(LParam).Lo);
        wm_Size          : WindowResize(LongRec(LParam).Lo, LongRec(LParam).Hi);
        wm_GetMinMaxInfo : WindowMinMaxInfo(PMinMaxInfo(LParam));
        wm_Char          : WindowChar(Char(WParam));
        wm_KeyDown       : WindowKeyDown(Byte(WParam));
        wm_SetFocus      : WindowSetFocus;
        wm_KillFocus     : WindowKillFocus;
        wm_Destroy       : WindowDestroy;
      else
        CrtWinProc := DefWindowProc(Window, Message, WParam, LParam);
      end;
    end; { CrtWinProc }

    {---------------------------------------------------- Text file device driver }

    function CrtOutput(var F: TTextRec): Integer; far;
      {- Text file device driver output function }
    begin
      if F.BufPos <> 0 then
      begin
        WriteBuf(PChar(F.BufPtr), F.BufPos);
        F.BufPos := 0;
        KeyPressed;
      end;
      CrtOutput := 0;
    end; { CrtOutput }

    function CrtInput(var F: TTextRec): Integer; far;
      {- Text file device driver input function }
    begin
      F.BufEnd := ReadBuf(PChar(F.BufPtr), F.BufSize);
      F.BufPos := 0;
      CrtInput := 0;
    end; { CrtInput }

    function CrtClose(var F: TTextRec): Integer; far;
      {- Text file device driver close function }
    begin
      CrtClose := 0;
    end; { CrtClose }

    function CrtOpen(var F: TTextRec): Integer; far;
      {- Text file device driver open function }
    begin
      if F.Mode = fmInput then
      begin
        F.InOutFunc := @CrtInput;
        F.FlushFunc := nil;
      end else
      begin
        F.Mode := fmOutput;
        F.InOutFunc := @CrtOutput;
        F.FlushFunc := @CrtOutput;
      end;
      F.CloseFunc := @CrtClose;
      CrtOpen := 0;
    end; { CrtOpen }

    procedure AssignCrt(var F: Text);
      {- Assign text file to CRT device }
    begin
      with TTextRec(F) do begin
        Handle := $FFFF;
        Mode := fmClosed;
        BufSize := SizeOf(Buffer);
        BufPtr := @Buffer;
        OpenFunc := @CrtOpen;
        Name[0] := #0;
      end;
    end; { AssignCrt }

    {----------------------------------------------- Apertura e chiusura finestra }

    procedure InitWinCrt;
      {- Create CRT window if required.}
    begin
      if not Created then begin
        CrtWindow := CreateWindow(
          CrtClass.lpszClassName,
          WindowTitle,
          ws_OverlappedWindow + ws_HScroll + ws_VScroll,
          WindowOrg.X, WindowOrg.Y,
          WindowSize.X, WindowSize.Y,
          0,
          0,
          HInstance,
          nil);
        ShowWindow(CrtWindow, CmdShow);
        UpdateWindow(CrtWindow);
      end;
    end; { InitWinCrt }

    procedure DoneWinCrt;
      {- Destroy CRT window if required }
    begin
      if Created then DestroyWindow(CrtWindow);
    end; { DoneWinCrt }

    procedure ExitWinCrt; far;
      {- WinCrt unit exit procedure.}
    begin
      ExitProc := SaveExit;
      SaveConfig;
      DoneWinCrt;
    end; { ExitWinCrt }

    {---------------------------------------------------------------------- Main }

    begin
      if HPrevInst = 0 then begin
        CrtClass.hInstance := HInstance;
        CrtClass.hIcon := LoadIcon(0, idi_Application);
        CrtClass.hCursor := LoadCursor(0, idc_Arrow);
        CrtClass.hbrBackground := color_Window + 1;
        RegisterClass(CrtClass);
      end;
      AssignCrt(Input);
      Reset(Input);
      AssignCrt(Output);
      Rewrite(Output);
      GetModuleFileName(HInstance, WindowTitle, SizeOf(WindowTitle));
      OemToAnsi(WindowTitle, WindowTitle);
      LoadConfig;
      SaveExit := ExitProc;
      ExitProc := @ExitWinCrt;
    end. { unit WinDump }

[Back to WIN-OS2 SWAG index] [Back to Main SWAG index] [Original]