Power-Programmierung/CD1.mdf/pascal/library/dos/communic/lcom/ttl.pas

Pascal/Delphi Source File | 1988-06-27 | 19.5 KB | 827 lines

{$R-,S-,I+,D-,T-,F-,V-,B-,N-,L+ }
{$M 16384,0,655360 }
(*
**  TTL is a complete, if somewhat limited, terminal emulation
**  program  designed to demonstrate the use of the LiteComm
**  ToolBox.  The executable version is included so that you can
**  try it out while viewing the code.  To successfully create a
**  new version of TTL, you must have the XMODEM engine
**  which is provided as part of your registration package.
**  While non-registered users cannot create a new version of TTL,
**  you may still examine the TTL program, and use it as a basis for
**  your own programming.
**
**  Information Technology, Ltd.
*)

program TTL;

uses
  DOS, LctKrnl, LctSupp, LtXMKrnl, LtXmodem, LwXModem, Crt;

const
  CPort    : integer = 2;
  Baud     : integer = 2400;
  Parity   : char = 'N';
  Databits : integer = 8;
  Stopbits : integer = 1;
  Yxmode   : boolean = false;
  Wxmode   : boolean = false;
  Halfd    : boolean = false;
  Hostm    : boolean = false;
  CPtr     : CCBPTR = NIL;
  Imask    : byte = $00;

type
  FnStr = string[64];

procedure GetFileName(var FName : FnStr);

begin
  Writeln;
  Write('Enter File Name: ');
  FName := '';
  Readln(FName);
end;                                    { GetFileName }

procedure XSend;
var
  SFile     : file;
  SFilename : FnStr;
  Buffer    : array[1..1024] of byte;
  BufNdx    : integer;
  Result    : XMResult;
  ToRead    : integer;
  ToSend    : integer;
  FRes      : integer;

begin
  Writeln;
  Writeln('Sending a File');
  GetFileName(SFileName);
  if Length(SFilename) = 0 then
  begin
    Writeln('Zero Length Name entered');
    ReadLn;
    exit;                                { nothing to send }
  end;

  Assign(SFile, SFilename);
{$I-}
  Reset(SFile, 1);                     { attempt to open }
{$I+}
  FRes := IOResult;
  if FRes <> 0 then
  begin
    Writeln('Error Opening file: ',FRes);
    ReadLn;
    exit;
  end;

  if not CommSetup(CPort, Baud, 'N', 8, 1) then
  begin
    Writeln('Unable to change Port parameters, <RET> to continue');
    Readln;
    exit;
  end;

{
  Transmit the file using the engine
}
  if YModem then
    ToRead := 1024
  else
    ToRead := 128;
  Result := Success;
  FRes := 1;
  while (FRes > 0) and
        (Result = Success) do
  begin
    FillChar(Buffer, Sizeof(Buffer), $00);
{$I-}
    BlockRead(SFile, Buffer, ToRead, FRes);
{$I+}
    BufNdx := 1;
    if FRes = 0 then                   {EOF Signal ?}
      FRes := -1;

    while (FRes > 0) and
          (Result = Success) do
    begin
      if Yxmode then
        if FRes <> ToRead then         { short block }
        begin
          ToRead := 128;               { sending short }
          YModem := false;
        end;;

      Result := LxmTrec(CPort, Buffer[BufNdx]);   { do actual transmission }

      case Result of
        Success : begin
                    Write('Sent Record: ', (RecNum - 1), ^M);
                    Dec(FRes, ToRead);
                    Inc(BufNdx, ToRead);
                  end;
        InitCan  : begin
                     Writeln;
                     Writeln('Cancel Req. INIT, <RET> to continue');
                     Readln;
                   end;
        InitFail : begin
                     Writeln;
                     Writeln('Too many retries INIT, <RET> to continue');
                     Readln;
                   end;
        CanReq  : begin
                    Writeln;
                    Writeln('Cancel Requested, <RET> to continue');
                    Readln;
                  end;
        Retry   : begin
                    Writeln;
                    Writeln('Too Many Tries, Record: ', (RecNum - 1));
                    Readln;
                  end;
        else
          Writeln;
          Writeln('Fatal Transmission Error, <RET> to continue');
          Readln;
      end;                             { case }
    end;                               { inner while }
    if Result = Success then
      if FRes <> -1 then
        FRes := 1;
  end;                                 { outer while }

  if Result = Success then
  begin
    Result := LxmTeot(CPort);
    if Result <> Success then
    begin
      Writeln('Error Ending Transmission');
      Readln;
    end;
  end;

  if not CommSetup(CPort, Baud, Parity, Databits, Stopbits) then
  begin
    Writeln('Unable to Reset Port parameters, <RET> to continue');
    Readln;
  end;
end;                                   { XSend }

procedure WxSend;
var
  SFile     : file;
  SFilename : FnStr;
  Buffer    : array[1..128] of byte;
  BufNdx    : integer;
  Result    : XMResult;
  ToRead    : integer;
  ToSend    : integer;
  FRes      : integer;
  NRec      : integer;

begin
  Writeln;
  Writeln('Sending a File');
  GetFileName(SFileName);
  if Length(SFilename) = 0 then
  begin
    Writeln('Zero Length Name entered');
    ReadLn;
    exit;                                { nothing to send }
  end;

  Assign(SFile, SFilename);
{$I-}
  Reset(SFile, 128);                    { attempt to open }
{$I+}
  FRes := IOResult;
  if FRes <> 0 then
  begin
    Writeln('Error Opening file: ',FRes);
    ReadLn;
    exit;
  end;

  if not CommSetup(CPort, Baud, 'N', 8, 1) then
  begin
    Writeln('Unable to change Port parameters, <RET> to continue');
    Readln;
    exit;
  end;

  if not EnableXon(CPort, true) then
  begin
    Writeln('Unable to turn on XON-XOFF, <RET> to continue');
    Readln;
    exit;
  end;

{
  Transmit the file using the engine
}
  Result := Success;
  NRec := 0;

  while (NRec >= 0) and
        ((Result = Success) or (Result = ReSend)) do
  begin
    if not Eof(SFile) then
    begin
      FillChar(Buffer, Sizeof(Buffer), $1A);
{$I-}
      BlockRead(SFile, Buffer, 1, FRes);
{$I+}
      NRec := 0;
    end
    else
      NRec := -1;                       { signal EOF }

    Result := LwxTrec(CPort, Buffer, NRec);   { do actual transmission }

    case Result of
      Success : if NRec <> -1 then
                begin
                  Write('Sent Record: ', (RecNum - 1), ^M);
                  Dec(FRes, ToRead);
                  Inc(BufNdx, ToRead);
                end;
      InitCan  : begin
                   Writeln;
                   Writeln('Cancel Req. INIT, <RET> to continue');
                   Readln;
                 end;
      InitFail : begin
                   Writeln;
                   Writeln('Too many retries INIT, <RET> to continue');
                   Readln;
                 end;
      CanReq  : begin
                  Writeln;
                  Writeln('Cancel Requested, <RET> to continue');
                  Readln;
                end;
      Retry   : begin
                  Writeln;
                  Writeln('Too Many Tries, Record: ', (RecNum - 1));
                  Readln;
                end;
      ReSend  : Seek(SFile, NRec*128);         { reposition the file }
      else
        Writeln;
        Writeln('Fatal Transmission Error, <RET> to continue');
        Readln;
    end;                             { case }
  end;                                 { outer while }

  Close(SFile);

  if not EnableXon(CPort, false) then
  begin
    Writeln('Unable to turn off XON-XOFF, <RET> to continue');
    Readln;
    exit;
  end;
  if not CommSetup(CPort, Baud, Parity, Databits, Stopbits) then
  begin
    Writeln('Unable to Reset Port parameters, <RET> to continue');
    Readln;
  end;

end;                                   { WxSend }

procedure SendFile;
begin
  if Yxmode then
  begin
    YModem := true;
    XSend;
  end
  else
  begin
    YModem := false;
    if Wxmode then                     { No, What type od XModem }
      WXSend
    else
      XSend;
  end;
end;

procedure WxRecv;
var
  RFile     : file;
  RFilename : FnStr;
  Buffer    : array[1..128] of byte;
  Result    : XMResult;
  FRes      : word;

begin
  Writeln;
  Writeln('Receiving a File - WXModem');
  GetFileName(RFileName);
  if Length(RFilename) = 0 then
  begin
    Writeln('Zero Length Name entered');
    ReadLn;
    exit;                                { nothing to send }
  end;

  Assign(RFile, RFilename);
{$I-}
  Rewrite(RFile, 1);                     { attempt to open }
{$I+}
  FRes := IOResult;
  if FRes <> 0 then
  begin
    Writeln('Error Creating file: ',FRes);
    ReadLn;
    exit;
  end;

  if not CommSetup(CPort, Baud, 'N', 8, 1) then
  begin
    Writeln('Unable to change Port parameters, <RET> to continue');
    Readln;
    exit;
  end;

{
  Transmit the file using the engine
}
  Result := Success;

  while (Result = Success) or
        (Result = DupBlk) do
  begin
    FillChar(Buffer, 128, $00);
    Result := LwxRrec(CPort, Buffer); { receive a block }

    case Result of
      Success : begin
{$I-}
                  BlockWrite(RFile, Buffer, 128, FRes);
{$I+}
                  Write('Received Record: ', (RecNum - 1), ^M);
                end;
      DupBlk  : begin
                  Writeln;
                  Writeln('Duplicate Block, ignored');
                end;
      SeqErr  : begin
                  Writeln;
                  Writeln('Block Seq Error');
                  Readln;
                end;
      InitCan  : begin
                  Writeln;
                  Writeln('Cancel Req. INIT, <RET> to continue');
                  Readln;
                end;
      InitFail : begin
                  Writeln;
                  Writeln('Too many retries INIT, <RET> to continue');
                  Readln;
                end;
      CanReq  : begin
                  Writeln;
                  Writeln('Cancel Requested, <RET> to continue');
                  Readln;
                end;
      Retry   : begin
                  Writeln;
                  Writeln('Too Many Tries, Record: ', (RecNum - 1));
                  Readln;
                end;
      EndFile : begin
                  Writeln;
                  Writeln('Normal End, <RET> to continue');
                  Readln;
                end;
      TimeOut : begin
                  Writeln;
                  Writeln('SOH Timeout, <RET> to continue');
                  Readln;
                end;
      else
        Writeln;
        Writeln('Fatal Transmission Error, <RET> to continue');
        Readln;
    end;
  end;

  Close(RFile);

  if not CommSetup(CPort, Baud, Parity, Databits, Stopbits) then
  begin
    Writeln('Unable to Reset Port parameters, <RET> to continue');
    Readln;
  end;
end;                                   { WxRecv }

procedure XRecv;
var
  RFile     : file;
  RFilename : FnStr;
  Buffer    : array[1..1024] of byte;    { allow for YModem }
  Result    : XMResult;
  HandShake : byte;
  RecdSize  : integer;
  FRes      : word;

begin
  Writeln;
  Writeln('Receiving a File');
  GetFileName(RFileName);
  if Length(RFilename) = 0 then
  begin
    Writeln('Zero Length Name entered');
    ReadLn;
    exit;                                { nothing to send }
  end;

  Assign(RFile, RFilename);
{$I-}
  Rewrite(RFile, 1);                     { attempt to open }
{$I+}
  FRes := IOResult;
  if FRes <> 0 then
  begin
    Writeln('Error Creating file: ',FRes);
    ReadLn;
    exit;
  end;

  if not CommSetup(CPort, Baud, 'N', 8, 1) then
  begin
    Writeln('Unable to change Port parameters, <RET> to continue');
    Readln;
    exit;
  end;

{
  Transmit the file using the engine
}
  Result := Success;
  HandShake := CRCREQ;                 { Spec Checksum Mode }

  while (Result = Success) or
        (Result = DupBlk) do
  begin
    FillChar(Buffer, TBSIZE, $00);
    Result := LxmRrec(CPort, Buffer, RecdSize, RTOUT, HandShake); { receive a block }

    case Result of
      Success : begin
{$I-}
                  BlockWrite(RFile, Buffer, RecdSize, FRes);
{$I+}
                  Write('Received Record: ', (RecNum - 1), ^M);
                end;
      DupBlk  : begin
                  Writeln;
                  Writeln('Duplicate Block, ignored');
                end;
      SeqErr  : begin
                  Writeln;
                  Writeln('Block Seq Error');
                  Readln;
                end;
      InitCan  : begin
                  Writeln;
                  Writeln('Cancel Req. INIT, <RET> to continue');
                  Readln;
                end;
      InitFail : begin
                  Writeln;
                  Writeln('Too many retries INIT, <RET> to continue');
                  Readln;
                end;
      CanReq  : begin
                  Writeln;
                  Writeln('Cancel Requested, <RET> to continue');
                  Readln;
                end;
      Retry   : begin
                  Writeln;
                  Writeln('Too Many Tries, Record: ', (RecNum - 1));
                  Readln;
                end;
      EndFile : begin
                  Writeln;
                  Writeln('Normal End, <RET> to continue');
                  Readln;
                end;
      TimeOut : begin
                  Writeln;
                  Writeln('SOH Timeout, <RET> to continue');
                  Readln;
                end;
      else
        Writeln;
        Writeln('Fatal Transmission Error, <RET> to continue');
        Readln;
    end;
  end;

  Close(RFile);

  if not CommSetup(CPort, Baud, Parity, Databits, Stopbits) then
  begin
    Writeln('Unable to Reset Port parameters, <RET> to continue');
    Readln;
  end;
end;                                   { XRecv }

procedure ReceiveFile;
begin
  if not Yxmode then                   { Y Modem specified }
    if Wxmode then                     { No, What type od XModem }
      WXRecv
    else
      XRecv
  else
    XRecv;
end;

procedure ChgBaud(var NBaud : integer);
var
  SBaud : integer;

begin
  SBaud := NBaud;
  Writeln;
  Write('Enter new Baud Rate: ');
{$I-}
  Readln(SBaud);
{$I+}
  case SBaud of
     110,
     300,
     600,
    1200,
    2400,
    4800,
    9600,
    19200: NBaud := SBaud;
  else
    Write('Invalid Baud Rate, <enter> to continue');
    Readln;
  end;
end;                                   { ChgBaud }

procedure ChgParity(var NPar : char);
var
  SPar : char;

begin
  SPar := NPar;
  Writeln;
  Write('Enter new Parity: ');
{$I-}
  Readln(SPar);
{$I+}
  SPar := UpCase(SPar);
  case SPar of
    'O',
    'E',
    'N',
    'M',
    'S': NPar := SPar;
  else
    Write('Invalid Parity, <enter> to continue');
    Readln;
  end;

end;                                   { ChgParity }

procedure ChgData(var NData : integer);
var
  SData : integer;

begin
  SData := NData;
  Writeln;
  Write('Enter new Data Bits: ');
{$I-}
  Readln(SData);
{$I+}
  case SData of
     5,
     6,
     7,
     8: NData := SData;
  else
    Write('Invalid Data Bits, <enter> to continue');
    Readln;
  end;
end;                                   { ChgData }

procedure ChgStop(var NStop : integer);
var
  SStop : integer;

begin
  SStop := NStop;
  Writeln;
  Write('Enter new Stop Bits: ');
{$I-}
  Readln(SStop);
{$I+}
  case SStop of
     1,
     2: NStop := SStop;
  else
    Write('Invalid Stop Bits, <enter> to continue');
    Readln;
  end;
end;                                   { ChgStop }

procedure ChgComm;
var
  Sel       : char;
  NBaud     : integer;
  NParity   : char;
  NData     : integer;
  NStop     : integer;

begin
  NBaud := Baud;
  NParity := Parity;
  NData := Databits;
  NStop := Stopbits;

  repeat
    ClrScr;
    Writeln('-- C H A N G E   C O M M   S E T U P --');
    Writeln('    presently ',NBaud, ',', NParity, ',', NData, ',', NStop);
    Writeln;
    Writeln('B-  change Baud rate');
    Writeln('P-  change Parity');
    Writeln('D-  change Data bits');
    Writeln('S-  change Stop bits');
    Writeln;
    Writeln('A-  Abandon changes');
    Writeln('Q-  Quit and install changes');
    Writeln;
    Write('    Enter Selection -> ');

    Sel := ReadKey;
    if Sel = #0 then
      Sel := ReadKey;
    Sel := UpCase(Sel);

    case Sel of
      'B':  ChgBaud(NBaud);
      'P':  ChgParity(NParity);
      'D':  ChgData(NData);
      'S':  ChgStop(NStop);
      'Q':  if CommSetup(CPort, NBaud, Nparity, NData, NStop) then
            begin
              Baud := NBaud;
              Parity := NParity;
              Databits := NData;
              Stopbits := NStop;
            end;
      else
      end;
  until (Sel = 'A') or (Sel = 'Q');
end;                                   { ChgComm }

procedure Terminal;
var
  Ch    : byte;
  DBool : boolean;

begin
  ClrScr;
  while true do
  begin
    if LctGet(CPort,Ch) then
    begin
      Write(char(Ch and $7f));
      if Hostm then
      begin
        DBool := LctPut(CPort,Ch);
        if Ch = $0d then
        begin
          Write(char($0a));
          DBool := LctPut(CPort, $0a);
        end;
      end;
    end;

    if KeyPressed then
    begin
      char(Ch) := ReadKey;
      if Ch = $00 then
        char(Ch) := ReadKey;
      if Ch = $18 then
        exit;
      DBool := LctPut(CPort,Ch);
      if not DBool then
        writeln('Put Error');
      if Hostm or Halfd then
      begin
        Write(char(Ch));
        if Ch = $0d then
        begin
          Write(char($0a));
          if Hostm then
            DBool := LctPut(CPort, $0a);
        end;
      end;
    end;
  end;
end;                                   { Terminal }

procedure MainMenu;
var
  Sel : char;

begin
  repeat
    ClrScr;
    Writeln('-- M A I N   M E N U --');
    Writeln;
    Writeln('T-  enter Terminal mode');
    Writeln('    CTRL-X exits terminal mode');
    Write('H-  toggles Host mode (now ');
    if Hostm then
      Writeln('ON)')
    else
      Writeln('OFF)');
    Write('G-  toGgles half-duplex mode (now ');
    if Halfd then
      Writeln('ON)')
    else
      Writeln('OFF)');
    Writeln('C-  change Comm settings');
    Writeln('    presently ',Baud, ',', Parity, ',', Databits, ',', Stopbits);
    Write('X-  change Xmodem mode (now ');
    if Yxmode then
      Writeln('YMODEM)')
    else
      Writeln('NORMAL)');
    Write('W- change Windowed Xmodem mode (now ');
    if Wxmode then
      Writeln('ON)')
    else
      Writeln('OFF)');
    Writeln('S-  Send a file');
    Writeln('R-  Receive a file');
    Writeln('Q-  Quit to DOS');
    Writeln;
    Write('    Select a Function -> ');

    Sel := ReadKey;
    if Sel = #0 then
      Sel := ReadKey;
{
  Dispatch Logic
}
    Sel := UpCase(Sel);

    case Sel of
      'T':  Terminal;
      'H':  begin
              Hostm := not Hostm;
              if Hostm then
                Halfd := false;
            end;
      'G':  begin
              Halfd := not Halfd;
              if Halfd then
                Hostm := false;
            end;
      'W':  Wxmode := not Wxmode;
      'X':  Yxmode := not Yxmode;
      'S':  SendFile;
      'R':  ReceiveFile;
      'C':  ChgComm;
    else
    end;
  until Sel ='Q';
end;                                   { MainMenu }

begin                                  { TTL }
  CheckBreak := false;                 { disable ^C }

  if not CommOpen(CPort, Baud, Parity, Databits, Stopbits, 2000, 2000) then
  begin
    Writeln('Error opening Comm Port ',CPort);
    Halt(1);
  end;

  if SetModemSignals(Cport, (RTS or DTR)) then
    MainMenu
  else
    Writeln('Unable to set modem signals');

  CommClose(CPort);

  ClrScr;
end.