Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TVCOM.ZIP/TVCOM.PAS

Pascal/Delphi Source File | 1992-12-06 | 21.3 KB | 730 lines

{
  TVCOM - a program that demonstrates one way of using Async Professional
  within a Turbo Vision program.

  This program provides a TTerminalWindow object derived from TWindow. The
  interior of this object is derived TTerminal. Such an object offers a handy
  way of adding text to the end of a scroller and navigating (using cursor
  keys or mouse) around the scroller.

  We also derive a new application object from TApplication called TComApp.
  The actual application, TMyApp is then derived from TComApp. In your
  programs, you might want to consolidate TComApp and TMyApp into one object.
  We broke it into two objects in case you wanted to move TComApp and
  TTerminalWindow objects into their own units.

  Serial port output is handled by TTerminalWindow's interior. Whenever it
  receives a evKeyDown message it sends that character to the serial port with
  PutChar.

  Serial port input is handled by TComApp's Idle method. Each time that method
  is called (which is once for every generated message) it checks the com port
  for characters waiting in the input buffer. If it finds that a character is
  ready, it will retreive that character, format an event record with a custom
  event code of evComChar and passes that event directly to the
  TTerminalWindow's HandleEvent method. It will process up to 10 characters
  each time Idle is called (speeding things up a bit whenever a large block of
  characters arrives at the serial port).

  TTerminalWindow's TInterior is the object that actually processes the
  evComChar event. To do so, it calls TTerminal's CharWrite method to add that
  character to the end of the scroller buffer and display it.

  Note this is a rather "bare bones" implementation. The TTerminal ancestor of
  TTerminalWindow's interior doesn't have the necessary methods to easily add
  terminal emulation (which would need to modify colors, position the cursor
  anywhere within the scroller buffer, etc.). To add emulation, you'll either
  need to add methods to TTerminalWindow's interior, or perhaps, choose a
  different ancestor than Turbo Vision's TTerminal.

  Additionally, this example gives little consideration to performance. You
  may want to consider processing characters in blocks rather than generating
  an event for each character. That is, the TComApp Idle method would collect
  a block of input characters, place a pointer to that block in the event
  record's InfoPtr field, and have the TTerminalWindow's HandleEvent method
  process that entire block at once.

  Released to the public domain

  Written by Terry Hughes, TurboPower Software
  Version 1.0 - 6-10-91
    initial release

  1.01 - 8-24-92 : wasn't releasing comport memory when terminal window closed
  1.02 - 12-5-92 : updated for BP7

}

{$X+}
program TVCom;
uses
  {.................rtl}
  Dos,
  {.................turbo vision}
  Objects,
  Drivers,
  Memory,
  Views,
  TextView,
  Menus,
  Dialogs,
  StdDlg,
  MsgBox,
  App,
  {$IFNDEF VER70}                                                      {!!.02}
  Buffers,
  {$ENDIF}                                                             {!!.02}
  Editors,
  {.................async professional}
  ApMisc,
  ApPort,
  ApUart,
  OoCom;

const
  {Change these parameters for the comport you're using}
  ComPort = Com2;
  ComBaud = 9600;

  evComChar   = $1000;      {Character received at serial port}

  HeapSize = 32 * (1024 div 16);

  cmOpen       = 100;
  cmNew        = 101;
  cmChangeDir  = 102;
  cmDosShell   = 103;
  cmCalculator = 104;
  cmShowClip   = 105;
  cmTermOpen   = 106;
  cmTermStart  = 107;
  cmTermStop   = 108;
  cmComChar    = 109;

type
  PInterior = ^TInterior;
  TInterior = object(TTerminal)
    AP     : AbstractPortPtr;           {Pointer to port object}
    SWidth : Byte;                      {Logical screen width}

    constructor Init(var Bounds : TRect;
                     AHScrollBar, AVScrollBar : PScrollBar;
                     ABufSize : Word; APort : AbstractPortPtr);
      {-Instantiate the interior view of the TerminalWindow}
    procedure HandleEvent(var Event: TEvent); virtual;
      {-Custom event handler -- also transmits keystrokes out com port}
    procedure CharWrite(C : Char);
      {-Add and display one character (handle line wrapping)}
  end;

  PTerminalWindow = ^TTerminalWindow;
  TTerminalWindow = object(TWindow)
    constructor Init(Bounds: TRect; WinTitle: String;
                     WindowNo: Word; ABufSize: Word;
                     APort : AbstractPortPtr);
      {-Instantiate a TerminalWindow}
    destructor Done; virtual;
      {-Destroy the TTerminalWindow}
    function MakeInterior(Bounds: TRect; ABufSize: Word;
                          APort : AbstractPortPtr): PInterior;
      {-Make an interior subview}
  end;

  PComApp = ^TComApp;
  TComApp = object(TApplication)
    TW          : PTerminalWindow;     {Pointer to a TerminalWindow}
    UP          : UartPortPtr;         {Pointer to the port object}
    DoComEvents : Boolean;             {True if a TermWin is open}

    constructor Init;
      {-Instantiate the com application}
    procedure Idle; virtual;
      {-Override Idle to handle incoming characters}
  end;

  PMyApp = ^TMyApp;
  TMyApp = object(TComApp)
    constructor Init;
      {-Instantiate the main application}
    procedure HandleEvent(var Event : TEvent); virtual;
      {-Override HandleEvent to process custom desktop commands}
    procedure InitMenuBar; virtual;
      {-Insert a custom menu bar}
    procedure InitStatusLine; virtual;
      {-Insert a custom status line}
    procedure OutOfMemory; virtual;
      {-Insert an outofmemory handler}
  end;

var
  MyMain: TMyApp;
  ClipWindow: PEditWindow;

{TInterior}
constructor TInterior.Init(var Bounds: TRect;
                           AHScrollBar, AVScrollBar : PScrollBar;
                           ABufSize : Word; APort : AbstractPortPtr);
begin
  TTerminal.Init(Bounds, AHScrollBar, AvScrollBar, ABufSize);
  EventMask := EventMask or evComChar;
  AP := APort;
  SWidth := 80;
end;

procedure TInterior.CharWrite(C : Char);
var
  CurPos : Word;
  ScreenLines: Word;
  Count : Byte;

  procedure InsertChar(C : Char);
  var
    I : Word;
  begin
    if QueFront+1 > BufSize then begin
      Buffer^[0] := C;
      QueFront := 1;
    end else begin
      Buffer^[QueFront] := C;
      Inc(QueFront);
    end;
  end;

begin
  {Don't store received line feeds}
  if C = cLF then
    Exit;

  {Handle end-of-line (TTextDevice requires cLFs)}
  ScreenLines := Limit.Y;
  if C = cCR then begin
    C := cLF;
    Inc(ScreenLines);
  end;

  {Make sure there's room for at least two more characters}
  while not CanInsert(2) do begin
    QueBack := NextLine(QueBack);
    Dec(ScreenLines);
  end;

  {Get current horizontal cursor position}
  CurPos := PrevLines(QueFront, 1);
  if CurPos <= QueFront then
    CurPos := QueFront - CurPos
  else
    CurPos := BufSize - (CurPos - QueFront);

  {Force a new line if we are at the end of the current line}
  if CurPos > SWidth then begin
    InsertChar(cLF);
    Inc(ScreenLines);
    CurPos := 1;
  end;

  {Add this character to the buffer}
  InsertChar(C);
  if C = cLF then
    CurPos := 0
  else
    Inc(CurPos);

  {Get length of longest line and recalibrate the scroll bar limits}
  SetLimit(CalcWidth, ScreenLines);

  {Scroll to the last line and move to the current horiz cursor position}
  ScrollTo(0, ScreenLines+1);
  SetCursor(CurPos, ScreenLines-Delta.Y-1);

  {Update the view}
  DrawView;
end;

procedure TInterior.HandleEvent(var Event: TEvent);
var
  S : TextBuf;
begin
  TTerminal.HandleEvent(Event);
  if (Event.What = evKeyDown) or (Event.What = evComChar) then begin
    if Event.CharCode <> #0 then begin
      {Send the character out the serial port}
      if Event.What = evKeyDown then
        AP^.PutChar(Event.CharCode);

      {Add it to the terminalwindow's buffer}
      CharWrite(Event.CharCode);
      ClearEvent(Event);
    end;
  end;
end;

{TTerminalWindow}
constructor TTerminalWindow.Init(Bounds: TRect; WinTitle: String;
                                 WindowNo: Word; ABufSize: Word;
                                 APort : AbstractPortPtr);
var
  Interior : PInterior;
begin
  TWindow.Init(Bounds, WinTitle, WindowNo);

  {Instantiate the internal scroller and insert it into the TerminalWindow}
  Interior := MakeInterior(Bounds, ABufSize, APort);
  Insert(Interior);

  {Tell the application to start getting com events}
  Message(Application, evBroadCast, cmTermStart, nil);

  {Consider com events as focused events}
  FocusedEvents := FocusedEvents or evComChar;

  EventMask := EventMask or evComChar;
end;

destructor TTerminalWindow.Done;
  {-Tell the application to stop getting com events}
begin
  TWindow.Done;
  Message(Application, evBroadCast, cmTermStop, nil);
end;

function TTerminalWindow.MakeInterior(Bounds: TRect; ABufSize: Word;
                                      APort : AbstractPortPtr): PInterior;
begin
  GetExtent(Bounds);
  Bounds.Grow(-1, -1);
  MakeInterior := New(PInterior, Init(Bounds,
                      StandardScrollBar(sbHorizontal + sbHandleKeyboard),
                      StandardScrollBar(sbVertical + sbHandleKeyboard),
                      ABufSize, APort));
end;

{TComApp}
constructor TComApp.Init;
begin
  {Do parent init}
  TApplication.Init;

  {Don't get com events yet}
  TW := nil;
  DoComEvents := False;
end;


procedure TComApp.Idle;
  {-Override Idle to handle incoming characters}
const
  ReleaseCnt = 10;
var
  C : Char;
  Event : TEvent;
  Cnt : Byte;
begin
  TApplication.Idle;

  if DoComEvents then begin
    Cnt := 1;

    while UP^.CharReady and (Cnt < ReleaseCnt) do begin
      Inc(Cnt);
      UP^.GetChar(C);
      if AsyncStatus = ecOk then begin
        Event.What := evComChar;
        Event.CharCode := C;
        Event.ScanCode := $FF;
        TW^.HandleEvent(Event);
      end;
    end;
  end;
end;

function ExecDialog(P: PDialog; Data: Pointer): Word;
var
  Result: Word;
begin
  Result := cmCancel;
  P := PDialog(Application^.ValidView(P));
  if P <> nil then
  begin
    if Data <> nil then P^.SetData(Data^);
    Result := DeskTop^.ExecView(P);
    if (Result <> cmCancel) and (Data <> nil) then P^.GetData(Data^);
    Dispose(P, Done);
  end;
  ExecDialog := Result;
end;

function CreateFindDialog: PDialog;
var
  D: PDialog;
  Control: PView;
  R: TRect;
begin
  R.Assign(0, 0, 38, 12);
  D := New(PDialog, Init(R, 'Find'));
  with D^ do
  begin
    Options := Options or ofCentered;

    R.Assign(3, 3, 32, 4);
    Control := New(PInputLine, Init(R, 80));
    Insert(Control);
    R.Assign(2, 2, 15, 3);
    Insert(New(PLabel, Init(R, '~T~ext to find', Control)));
    R.Assign(32, 3, 35, 4);
    Insert(New(PHistory, Init(R, PInputLine(Control), 10)));

    R.Assign(3, 5, 35, 7);
    Insert(New(PCheckBoxes, Init(R,
      NewSItem('~C~ase sensitive',
      NewSItem('~W~hole words only', nil)))));

    R.Assign(14, 9, 24, 11);
    Insert(New(PButton, Init(R, 'O~K~', cmOk, bfDefault)));
    Inc(R.A.X, 12); Inc(R.B.X, 12);
    Insert(New(PButton, Init(R, 'Cancel', cmCancel, bfNormal)));

    SelectNext(False);
  end;
  CreateFindDialog := D;
end;

function CreateReplaceDialog: PDialog;
var
  D: PDialog;
  Control: PView;
  R: TRect;
begin
  R.Assign(0, 0, 40, 16);
  D := New(PDialog, Init(R, 'Replace'));
  with D^ do
  begin
    Options := Options or ofCentered;

    R.Assign(3, 3, 34, 4);
    Control := New(PInputLine, Init(R, 80));
    Insert(Control);
    R.Assign(2, 2, 15, 3);
    Insert(New(PLabel, Init(R, '~T~ext to find', Control)));
    R.Assign(34, 3, 37, 4);
    Insert(New(PHistory, Init(R, PInputLine(Control), 10)));

    R.Assign(3, 6, 34, 7);
    Control := New(PInputLine, Init(R, 80));
    Insert(Control);
    R.Assign(2, 5, 12, 6);
    Insert(New(PLabel, Init(R, '~N~ew text', Control)));
    R.Assign(34, 6, 37, 7);
    Insert(New(PHistory, Init(R, PInputLine(Control), 11)));

    R.Assign(3, 8, 37, 12);
    Insert(New(PCheckBoxes, Init(R,
      NewSItem('~C~ase sensitive',
      NewSItem('~W~hole words only',
      NewSItem('~P~rompt on replace',
      NewSItem('~R~eplace all', nil)))))));

    R.Assign(17, 13, 27, 15);
    Insert(New(PButton, Init(R, 'O~K~', cmOk, bfDefault)));
    R.Assign(28, 13, 38, 15);
    Insert(New(PButton, Init(R, 'Cancel', cmCancel, bfNormal)));

    SelectNext(False);
  end;
  CreateReplaceDialog := D;
end;

function DoEditDialog(Dialog: Integer; Info: Pointer): Word; far;
var
  R: TRect;
  T: TPoint;
begin
  case Dialog of
    edOutOfMemory:
      DoEditDialog := MessageBox('Not enough memory for this operation.',
        nil, mfError + mfOkButton);
    edReadError:
      DoEditDialog := MessageBox('Error reading file %s.',
        @Info, mfError + mfOkButton);
    edWriteError:
      DoEditDialog := MessageBox('Error writing file %s.',
        @Info, mfError + mfOkButton);
    edCreateError:
      DoEditDialog := MessageBox('Error creating file %s.',
        @Info, mfError + mfOkButton);
    edSaveModify:
      DoEditDialog := MessageBox('%s has been modified. Save?',
        @Info, mfInformation + mfYesNoCancel);
    edSaveUntitled:
      DoEditDialog := MessageBox('Save untitled file?',
        nil, mfInformation + mfYesNoCancel);
    edSaveAs:
      DoEditDialog := ExecDialog(New(PFileDialog, Init('*.*',
        'Save file as', '~N~ame', fdOkButton, 101)), Info);
    edFind:
      DoEditDialog := ExecDialog(CreateFindDialog, Info);
    edSearchFailed:
      DoEditDialog := MessageBox('Search string not found.',
        nil, mfError + mfOkButton);
    edReplace:
      DoEditDialog := ExecDialog(CreateReplaceDialog, Info);
    edReplacePrompt:
      begin
        { Avoid placing the dialog on the same line as the cursor }
        R.Assign(0, 1, 40, 8);
        R.Move((Desktop^.Size.X - R.B.X) div 2, 0);
        Desktop^.MakeGlobal(R.B, T);
        Inc(T.Y);
        if TPoint(Info).Y <= T.Y then
          R.Move(0, Desktop^.Size.Y - R.B.Y - 2);
        DoEditDialog := MessageBoxRect(R, 'Replace this occurence?',
          nil, mfYesNoCancel + mfInformation);
      end;
  end;
end;

function OpenEditor(FileName: FNameStr; Visible: Boolean): PEditWindow;
var
  P: PView;
  R: TRect;
begin
  DeskTop^.GetExtent(R);
  P := Application^.ValidView(New(PEditWindow, Init(R, FileName, wnNoNumber)));
  if not Visible then
    P^.Hide;
  DeskTop^.Insert(P);
  OpenEditor := PEditWindow(P);
end;

constructor TMyApp.Init;
var
  H: Word;
begin
  {$IFNDEF VER70}                                                      {!!.02}
  {Init edit buffers}
  H := PtrRec(HeapEnd).Seg - PtrRec(HeapPtr).Seg;
  if H > HeapSize then
    BufHeapSize := H - HeapSize
  else
    BufHeapSize := 0;
  InitBuffers;
  {$ENDIF}                                                             {!!.02}

  {Do parent init}
  TComApp.Init;

  {Make a clipboard from an editor}
  DisableCommands([cmSave, cmSaveAs, cmCut, cmCopy, cmPaste, cmClear,
                   cmUndo, cmFind, cmReplace, cmSearchAgain]);
  EditorDialog := DoEditDialog;
  ClipWindow := OpenEditor('', False);
  if ClipWindow <> nil then begin
    Clipboard := ClipWindow^.Editor;
    Clipboard^.CanUndo := False;
  end;
end;

procedure TMyApp.HandleEvent(var Event: TEvent);

procedure FileOpen;
var
  FileName: FNameStr;
begin
  FileName := '*.*';
  if ExecDialog(New(PFileDialog, Init('*.*', 'Open file',
    '~N~ame', fdOpenButton, 100)), @FileName) <> cmCancel then
    OpenEditor(FileName, True);
end;

procedure FileNew;
begin
  OpenEditor('', True);
end;

procedure ChangeDir;
begin
  ExecDialog(New(PChDirDialog, Init(cdNormal, 0)), nil);
end;

{$IFNDEF VER70}                                                        {!!.02}
procedure DosShell;
begin
  DoneSysError;
  DoneEvents;
  DoneVideo;
  DoneMemory;
  SetMemTop(Ptr(BufHeapPtr, 0));
  PrintStr('Type EXIT to return to TVEDIT...');
  SwapVectors;
  Exec(GetEnv('COMSPEC'), '');
  SwapVectors;
  SetMemTop(Ptr(BufHeapEnd, 0));
  InitMemory;
  InitVideo;
  InitEvents;
  InitSysError;
  Redraw;
end;
{$ENDIF}                                                               {!!.02}

procedure ShowClip;
begin
  ClipWindow^.Select;
  ClipWindow^.Show;
end;

{$IFNDEF VER70}                                                        {!!.02}
procedure Tile;
var
  R: TRect;
begin
  Desktop^.GetExtent(R);
  Desktop^.Tile(R);
end;

procedure Cascade;
var
  R: TRect;
begin
  Desktop^.GetExtent(R);
  Desktop^.Cascade(R);
end;
{$ENDIF}                                                               {!!.02}

procedure TermOpen;
var
  R : TRect;
begin
  {Open up the serial port}
  New(UP, InitCustom(ComPort, ComBaud, NoParity, 8, 1, 1000, 1000, DefPortOptions));
  if UP = nil then begin
    WriteLn('Failed to open port: ', AsyncStatus);
    Halt;
  end;

  {Instantiate the TerminalWindow object}
  R.Assign(10, 1, 70, 18);
  TW := New(PTerminalWindow, Init(R, 'Terminal', wnNoNumber, 8192, UP));
  TW := PTerminalWindow(Application^.ValidView(TW));
  Desktop^.Insert(TW);

  {Start com events}
  DoComEvents := True;
end;

begin
  TApplication.HandleEvent(Event);
  case Event.What of
    evCommand :
      case Event.Command of
        cmOpen : FileOpen;
        cmNew : FileNew;
        cmChangeDir : ChangeDir;
        cmDosShell : DosShell;
        cmShowClip : ShowClip;
        cmTile : Tile;
        cmCascade : Cascade;
        cmTermOpen : TermOpen;
        else Exit;
      end;
    evBroadCast :
      case Event.Command of
        cmTermStart : DoComEvents := True;
        cmTermStop :
          begin
            DoComEvents := False;
            TW := nil;
            Dispose(UP, Done);                                         {!!.01}
          end;
        else Exit;
      end;
  else
    Exit;
  end;
  ClearEvent(Event);
end;

procedure TMyApp.InitMenuBar;
var
  R: TRect;
begin
  GetExtent(R);
  R.B.Y := R.A.Y + 1;
  MenuBar := New(PMenuBar, Init(R, NewMenu(
    NewSubMenu('~F~ile', hcNoContext, NewMenu(
      NewItem('~O~pen...', 'F3', kbF3, cmOpen, hcNoContext,
      NewItem('~N~ew', '', kbNoKey, cmNew, hcNoContext,
      NewItem('~S~ave', 'F2', kbF2, cmSave, hcNoContext,
      NewItem('S~a~ve as...', '', kbNoKey, cmSaveAs, hcNoContext,
      NewLine(
      NewItem('~C~hange dir...', '', kbNoKey, cmChangeDir, hcNoContext,
      NewItem('~D~OS shell', '', kbNoKey, cmDosShell, hcNoContext,
      NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcNoContext,
      nil))))))))),
    NewSubMenu('~E~dit', hcNoContext, NewMenu(
      NewItem('~U~ndo', '', kbNoKey, cmUndo, hcNoContext,
      NewLine(
      NewItem('Cu~t~', 'Shift-Del', kbShiftDel, cmCut, hcNoContext,
      NewItem('~C~opy', 'Ctrl-Ins', kbCtrlIns, cmCopy, hcNoContext,
      NewItem('~P~aste', 'Shift-Ins', kbShiftIns, cmPaste, hcNoContext,
      NewItem('~S~how clipboard', '', kbNoKey, cmShowClip, hcNoContext,
      NewLine(
      NewItem('~C~lear', 'Ctrl-Del', kbCtrlDel, cmClear, hcNoContext,
      nil))))))))),
    NewSubMenu('~S~earch', hcNoContext, NewMenu(
      NewItem('~F~ind...', '', kbNoKey, cmFind, hcNoContext,
      NewItem('~R~eplace...', '', kbNoKey, cmReplace, hcNoContext,
      NewItem('~S~earch again', '', kbNoKey, cmSearchAgain, hcNoContext,
      nil)))),
    NewSubMenu('~W~indows', hcNoContext, NewMenu(
      NewItem('~S~ize/move','Ctrl-F5', kbCtrlF5, cmResize, hcNoContext,
      NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcNoContext,
      NewItem('~T~ile', '', kbNoKey, cmTile, hcNoContext,
      NewItem('C~a~scade', '', kbNoKey, cmCascade, hcNoContext,
      NewItem('~N~ext', 'F6', kbF6, cmNext, hcNoContext,
      NewItem('~P~revious', 'Shift-F6', kbShiftF6, cmPrev, hcNoContext,
      NewItem('~C~lose', 'Alt-F3', kbAltF3, cmClose, hcNoContext,
      NewLine(
      NewItem('Ca~l~culator', '', kbNoKey, cmCalculator, hcNoContext,
      nil)))))))))),
    NewSubMenu('~T~erminal', hcNoContext, NewMenu(
      NewItem('~O~pen', '', kbNoKey, cmTermOpen, hcNoContext,
      NewItem('~C~lose', '', kbNoKey, cmClose, hcNoContext,
      nil))),
    nil))))))));
end;

procedure TMyApp.InitStatusLine;
var
  R: TRect;
begin
  GetExtent(R);
  R.A.Y := R.B.Y - 1;
  New(StatusLine, Init(R,
    NewStatusDef(0, $FFFF,
      NewStatusKey('~F2~ Save', kbF2, cmSave,
      NewStatusKey('~F3~ Open', kbF3, cmOpen,
      NewStatusKey('~Alt-F3~ Close', kbAltF3, cmClose,
      NewStatusKey('~F5~ Zoom', kbF5, cmZoom,
      NewStatusKey('~F6~ Next', kbF6, cmNext,
      NewStatusKey('~F10~ Menu', kbF10, cmMenu,
      NewStatusKey('', kbCtrlF5, cmResize,
      nil))))))),
    nil)));
end;

procedure TMyApp.OutOfMemory;
begin
  MessageBox('Not enough memory for this operation.', nil, mfError+mfOkButton);
end;

begin
  {$IFDEF VER70}                                                        {!!.02}
  {$IFNDEF Dpmi}                                                        {!!.02}
  MaxHeapSize := (MaxAvail div 16) - 8192;
  {$ENDIF}                                                              {!!.02}
  {$ENDIF}                                                              {!!.02}
  MyMain.Init;
  MyMain.Run;
  MyMain.Done;
end.