(* QK KERMIT, Turbo Pascal *)
(* This file is the concatenation of the following files.  Each begins *)
(* with a comment line containing +FILE+ followed by the file name. *)
(* KERMIT.PASMSCPM *)
(* UTILITY.PASMSCPM *)
(* SYSFUNC.PASMS *)
(* SYSFUNC.PASCPM *)
(* MODEMPRO.PASMS *)
(* MODEMPRO.PASAPPLE *)
(* MODEMPRO.PASKAYII *)
(* DEFWORDS.PASMSCPM *)
(* READCHAR.PASMSCPM *)
(* PACKET.PASMSCPM *)
(* SENDFILE.PASMS *)
(* SENDFILE.PASCPM *)
(* RECVFILE.PASMSCPM *)
(* CONNECT.PASVT52 *)
(* CONNECT.PASADM3A *)
(* CONNECT.PASVT100 *)
(* CONNECT.PASTEK10 *)
(* SETSHOW.PASMSCPM *)
(* LOCAL.PASMSCPM *)
(* REMOTE.PASMSCPM *)
(* MISCCOMM.PASMSCPM *)
(* TYPEDEF.PASDUMMY *)
(* GRAPHIX.PASDUMMY *)
(* KERNEL.PASDUMMY *)
(* The last line of this file should say +END-OF-FILES+ *)

(* +FILE+ KERMIT.PASMSCPM *)
{$C-}
Program Kermit ;
(* ***************************************************************** *)
(*                                                                   *)
(* Author - Victor Lee, Queen's University, Kingston, Ontario        *)
(*          Comments and problem can be sent to VIC@QUCDN.BITNET     *)
(*          Phone - 613-547-6115                                     *)
(*          Contributions from Jeff Duncan                           *)
(* Date -   1985 January                                             *)
(*      -   1985 May  1    first official release                    *)
(*      -        June 28   Add run command , fix logging             *)
(*      -        July  5   Fix Asfile bug.                           *)
(*               July 10   Fix Binary Transfer bug (no repeatchar)   *)
(*               July 17   change write(ch) to ritechar to fix bug   *)
(*                         with keyboard input.                      *)
(*               July 23   Add I/O error handling,fix initparm bug,  *)
(*                         restrict source to 80 columns.            *)
(*               Aug 7     Use $C- option,  Eliminate the use of     *)
(*                         ritechar procedure. Add VT100 terminal    *)
(*                         simulation code                           *)
(*               Sept 9    Minor cleanup of code. Retry for reading  *)
(*                         Keytable file.                            *)
(*               Sept 18   Set version number.                       *)
(*               Sept 30   Check seqnum on recieved data packets.    *)
(*               Nov. 01   Reenable auto remote command.             *)
(*               Dec. 16   Insert Mode ( FatCursor indicator )       *)
(*               Dec. 20   Sub Directory commands and features       *)
(*               Dec. 23   Audio Toggle .                            *)
(* Date -   1986 Jan.  7   Allow Packet Parameter specifications.    *)
(*               Jan. 14   Apl character set selection.              *)
(*               Jan. 20   8bit quote and repeat char. bug fixed.    *)
(*               Jan. 22   Remove some of the system dependant code  *)
(*                         from KERMIT.PAS.                          *)
(*               Jan. 29   Break key - to us ALT F10 .               *)
(*                                                                   *)
(* ***************************************************************** *)
(*  Utility Procedures                                               *)
(*       HEX                                                         *)
(*       UpperCase                                                   *)
(*       GETTOKEN                                                    *)
(*       NewAsFile                                                   *)
(* SysFunc Procedures  - These are operating system dependent        *)
(*       KeyChar                                                     *)
(*       CursorPosition                                              *)
(*       CursorUp,CursorDown,CursorRight,CursorLeft                  *)
(*       LocalScreen,RemoteScreen                                    *)
(*       FirstFile,Nextfile                                          *)
(*       DefaultDrive                                                *)
(*       SetDefaultDrive                                             *)
(*       DisplayDiskStatus                                           *)
(*       ExecFile                                                    *)
(* Modem Procedures   -   These are Machine dependent procedures     *)
(*       InitModem                                                   *)
(*       SetModem                                                    *)
(*       ResetModem                                                  *)
(*       DialModem                                                   *)
(*       RecvChar                                                    *)
(*       SendChar                                                    *)
(*                                                                   *)
(* Define Word Procedures                                            *)
(*       AssignDefWord                                               *)
(*       DisplayDefWords                                             *)
(*       CheckDefWords                                               *)
(*       WriteDefWord                                                *)
(*       DEFINEWORD                                                  *)
(*       LoadDefWords                                                *)
(*       SaveDefWords                                                *)
(* Read Character Procedure                                          *)
(*       ReadChar                                                    *)
(* Packet Procedures                                                 *)
(*       SENDPACKET                                                  *)
(*       RECVPACKET                                                  *)
(*       RESENDIT                                                    *)
(*       SENDACK                                                     *)
(*                                                                   *)
(*  ------------------ COMMAND  PROCEDURES  --------------------     *)
(*                                                                   *)
(*       SENDFILE  - Sends a file to another computer.               *)
(*       RECVFILE  - Receive a file from another computer.           *)
(*       CONNECTION- Simulate a dumb terminal.                       *)
(* SetShow Procedures                                                *)
(*       SHOWIT    - Display the options .                           *)
(*       SETIT     - Set the options.                                *)
(*       DisplayCommands - Displays the commands available.          *)
(*                                                                   *)
(* Local Procedures                                                  *)
(*      DisplayDir  - Display directory.                             *)
(*      EraseFiles  - Erase files.                                   *)
(*      RenameFiles - Rename files.                                  *)
(*      DisplayFile - Display file (TYPE file ).                     *)
(*     (RunFile     - Run a program  ( See SYSFUNC procedures ) )    *)
(*                                                                   *)
(*       REMOTEPRO  - Remote request procedures                      *)
(* Misccomm Procedures                                               *)
(*       Logit      - log the session to a file.                     *)
(*       Takeit     - take commands from a file.                     *)
(*       QuitExit   - terminate kermits and log out.                 *)
(*                                                                   *)
(* ***************************************************************** *)
CONST
    VERSION   = '2.5 ' ;  (* <<<<<<<<<<<< V E R S I O N <<<<<<<<<<< *)
    Date      = '1986 January 29  ' ;

    LocalChar = $1C ;   (* control backslash       ^\  *)
    BreakChar = $1D ;   (* control right bracket   ^]  *)

    SOH  = $01 ;        (* Start of Header *)
    EOT  = $04 ;        (* End of transmission *)
    BS   = $08 ;        (* Back Space *)
    Xon  = $11 ;
    Xoff = $13 ;
    ESC  = $1B ;
    DEL  = $7F ;

TYPE
    layouts = (one,two,three,four,five,six,seven,eight,nine,ten) ;
    Commandindex = (
                  zero,
                  connect,
                  send,
                  receive,
                  setparm,
                  status,
                  directory,
                  erase,
                  rename,
                  typefile,
                  runfile,
                  remote,
                  log,
                  take,
                  define,
                  help,
                  mkdir,
                  rmdir,
                  chdir,
                  audio,
                  parms,
                  quit,
                  null );
    comstring = string[80] ;
    Wstring   = string[10] ;

    STATETYPE = (S,SF,SD,SZ,SB,C,A,R,RF,RD) ;
    ABORTTYPE = (NOSOH,BADSF,NOT_S,NOT_SFBZ,NOT_DZ);
    BREAKTYPE = (NOBREAK,BX,BZ,BC,BE);
    PACKET = PACKED ARRAY[1..255] OF BYTE ;
    ParityType = (OddP,EvenP,MarkP,NoneP);
    DefPointer = ^DefineRec ;
    DefineRec = Record
                Link : DefPointer ;
                DefWord : Wstring ;
                DefString : comstring ;
                End ;

VAR
    STATE          : STATETYPE ;
    ABORT          : ABORTTYPE ;
    BREAKSTATE     : BREAKTYPE ;
    RetryCount     : Integer ;

    (* Packet variables *)                           (* format   *)
    (* Receive       Send     *)                     (* SOH      *)
       InCount,      OutCount      : BYTE ;          (* COUNT    *)
       INSEQ,        OUTSEQ        : BYTE ;          (* SEQNUM   *)
       INPACKETTYPE, OUTPACKETTYPE : BYTE ;          (* TYPE     *)
       RecvData,     SendData      : PACKET ;        (* DATA...  *)
       CHECKSUM                    : INTEGER ;       (* CHECKSUM *)
       CRC                         : INTEGER ;       (* CRC      *)

       InDataCount,  OutDataCount  : BYTE ;          (* dataCOUNT *)

    (* Initialization packet parameters *)
    PacketSize,Timeout,NumPad,PadChar,EndChar,StartChar,
    CntrlQuote,Bit8Quote,Checktype,RepChar     : Byte ;

    (* Operational Options Parameters *)
    LocalEcho   : Boolean ;
    Series1     : Boolean ;
    XonXoff     : Boolean ;
    BaudRate    : Integer ;
    Parity      : ParityType ;
    PrimaryPort : Boolean ;
    AudioFlag,AplFlag,ParmFlag  : Boolean ;

    (* Execution control flags *)
    WaitXon, Running, Logging, ForPrinter,
    ActiveCommandFile, GotSOH,DTRcheck               : Boolean ;

    I                      : INTEGER ;
    inputstring            : comstring ;
    command                : Wstring ;
    commandtable,parmtable : string[255];
    LogName,dummy          : comstring ;
    Logfile,CommandFile    : Text ;

{$I Utility.Pas }
{$I SYSFUNC.PAS }
{$I MODEMPRO.PAS }
{$I ReadChar.Pas }
{$I DefWords.pas }
{$I packet.pas }

(* ----------------------------------------------------------------- *)
(* SENDFILE - Procedure                                              *)
(* ----------------------------------------------------------------- *)
{$I SENDFILE }

(* ----------------------------------------------------------------- *)
(* RECVFILE - Procedure                                              *)
(* ----------------------------------------------------------------- *)
{$I RECVFILE }

(* ----------------------------------------------------------------- *)
(* Graphics - Procedures . This are only required for graphics.      *)
(* ----------------------------------------------------------------- *)
{$I TYPEDEF }
{$I GRAPHIX }
{$I KERNEL }
{*I POLYGON }
{*I HATCH }

(* ----------------------------------------------------------------- *)
(* CONNECTION - Procedure                                            *)
(* ----------------------------------------------------------------- *)
{$I CONNECT }

(* ----------------------------------------------------------------- *)
(* SHOWOPTIONS and SETOPTIONS and  DisplayCommand - Procedures       *)
(* ----------------------------------------------------------------- *)
{$I SETSHOW }

(* ----------------------------------------------------------------- *)
(* Local Procedures - Directory, Erase, Rename, Typefile             *)
(* ----------------------------------------------------------------- *)
{$I LOCAL }

(* ----------------------------------------------------------------- *)
(* Remote Procedures                                                 *)
(* ----------------------------------------------------------------- *)
{$I REMOTE }

(* ----------------------------------------------------------------- *)
(* MiscCommands - LOG , Exit                      - Procedures       *)
(* ----------------------------------------------------------------- *)
{$I MISCCOMM }

(* ***************************************************************** *)
(* ********    Outter Block of Kermit ****************************** *)
(* ***************************************************************** *)


BEGIN (* KERMIT *)
commandtable := concat('bad       ',
                       'CONNECT   ',
                       'SEND      ',
                       'RECEIVE   ',
                       'SET       ',
                       'STATUS    ',
                       'DIRECTORY ',
                       'ERASE     ',
                       'RENAME    ',
                       'TYPE      ',
                       'RUN EXEC  ',
                       'REMOTE    ',
                       'LOG       ',
                       'TAKE      ',
                       'DEFINE    ',
                       'HELP  ?   ',
                       'MKDIR MD  ',
                       'RMDIR RD  ',
                       'CHDIR CD  ',
                       'AUDIO     ',
                       'PARMS     ',
                       'QUIT      ',
                       'DO LOCAL  ') ;

 (* Default Packet settings *)
 PacketSize := 94 ;     (* PACKET size 94 maximum *)
 Timeout    := 60 ;     (* Time out in seconds *)
 NumPad     := 00 ;     (* Number of Pad characters *)
 PadChar    := 00 ;     (* Padding Character *)
 EndChar    := 13 ;     (* End of line char - CR *)
 StartChar  := 01 ;     (* Start of Packet char - SOH *)
 CntrlQuote := 35 ;     (* # *)
 Bit8Quote  := 38 ;     (* & *)
 CheckType  := 49 ;     (* 1 *)
 RepChar    := 00 ;     (* ~ *)

 (* Default Settings *)
 Baudrate    := DefaultBaud ;
 Parity      := EvenP ;
 XonXoff     := False ;
 Series1     := True ;
 LocalEcho   := False ;
 PrimaryPort := True ;
 AudioFlag   := False ;
 AplFlag     := False ;
 ParmFlag    := False ;

(* Set control flow flags *)
connected         := false ;
logging           := false ;
ForPrinter        := false ;
ActiveCommandfile := false ;
GotSOH            := false ;
DTRcheck          := true ;
Running := true;

DefList := Nil ;
LoadDefWords ; NewDefs := false ;
InitModem ;

inputstring := commandline ;
(* writeln(commandline); *)

ReadKeyTable;

   Writeln('          * ======================================== * ');
   Writeln('          *  Queen''s University  -  KERMIT /',termtype,' * ');
   Writeln('          *                                          * ');
   Writeln('          *      Version ',version,Gversion,' - ',Date,'  * ');
   Writeln('          *      Author   -  Victor Lee              * ');
   Writeln('          *      Graphics ',Graphics,'  * ');
   Writeln('          * ======================================== * ');

While Running Do
    Begin (* Command Loop *)
    if audioflag then
       Begin sound(1500);delay(50);sound(300);delay(50);nosound; end ;
    if length(inputstring)<1 then
         if ActiveCommandFile then
              Begin (* Get command from file *)
              Readln(Commandfile,inputstring);
              ActiveCommandFile := not Eof(commandfile);
              End
                             else
             Begin (* ask for input *)
             Write('QK-Kermit>');              (* PROMPT for input *)
             readln(inputstring);
             End ; (* ask for input *)

    command := Uppercase(GETTOKEN(inputstring));
    CheckDefWords(DefList,command,Inputstring);
    command := ' ' + command ;
    WaitXon := false ;

    case commandindex(POS(command,commandtable) div 10 ) of
          zero    : If length(command)>1 then
                        Begin (* bad command *)
                        Writeln(' Invalid Command >>>>> ',Command,' <<<<<');
                        Writeln('--- Type HELP to see valid Commands.--- ');
                        End ; (* bad command *)
          connect  : Begin
                     If length(inputstring) > 1 then SetOptions(inputstring);
                     CONNECTION ;
                     End;
          send     : SENDFILE (inputstring);
          receive  : RECVFILE (inputstring );
          setparm  : SetOptions(inputstring);
          status   : ShowOptions ;
          directory: DisplayDir (GetToken(inputstring));
          erase    : EraseFiles (GetToken(inputstring));
          rename   : RenameFile (inputstring);
          typefile : DisplayFile (GetToken(inputstring));
          runfile  : EXECFile (inputstring);
          remote   : RemoteProc (inputstring);
          log      : Logit  (GetToken(inputstring));
          take     : Takeit (GetToken(inputstring));
          define   : DefineWord(inputstring);
          help     : DisplayCommands ;
          mkdir    : MkdirFunc (GetToken(inputstring)) ;
          rmdir    : RmdirFunc (GetToken(inputstring)) ;
          chdir    : ChdirFunc (GetToken(inputstring)) ;
          audio    : AudioFlag := AudioFlag xor True ;
          parms    : ParmFlag := ParmFlag xor True ;
          quit     : QuitExit (UpperCase(GetToken(inputstring)));
          null     : ;
       end ;  (*  Case commandindex *)
    End ; (* Command Loop *)

 If Logging then Close(Logfile);
 If NewDefs then SaveDefWords ;
 If audioflag then
    begin sound(1500);delay(200);sound(3000);delay(200);end ;
 If connected then ResetModem;
 If audioflag then
    begin sound(2000);delay(200); nosound; end ;
 ClrScr;
 Gotoxy(20,10); Write( ' G O O D - B Y E ');

END.  (* KERMIT *)

(* +FILE+ UTILITY.PASMSCPM *)
(* ============ Begining of   U T I L I T Y   Procedures ============ *)
Type String2 = String[2];

(* ----------------------------------------------------------------- *)
(* GETTOKEN - Function                                               *)
(* ----------------------------------------------------------------- *)
Function  GETTOKEN ( var instring : comstring) : comstring  ;
Var
    pt : byte ;

    Begin (* GETTOKEN *)
    While (instring[1] = ' ') and (length(instring)>1) do
          Delete(instring,1,1);    (* eliminate leading blanks *)
    pt := POS(' ',instring);
    if pt = 0 then pt := length(instring)+1 ;
    GETTOKEN := copy(instring,1,pt-1);
    DELETE(instring,1,pt);
    End ; (* GETTOKEN *)

(* ----------------------------------------------------------------- *)
(* UpperCase - Function                                               *)
(* ----------------------------------------------------------------- *)
Function UpperCase ( instring : comstring) : comstring ;
Var
    ix,len : integer ;

    Begin (* UpperCase *)
    len := length(instring) ;
    for ix := 1 to len do instring[ix] := Upcase(instring[ix]);
    UpperCase := instring ;
    End ; (* UpperCase *)

(* ----------------------------------------------------------------- *)
(* CRCheck - Procedure - generates a CCITT CRC using the polynominal *)
(*                       X^16 + X^12 + X^5 + 1                       *)
(* Side Effects : Updates the global variable CRC which should be    *)
(*                initialized to 0. It is call only once for each    *)
(*                byte to be checked and all 8 bits are included.    *)
(*                No terminating calls are necessary.                *)
(* ----------------------------------------------------------------- *)
Procedure CRCheck ( Abyte : byte ) ;
Var    j,temp : integer ;
    Begin (* CRCheck *)
    For j := 0 to 7 do
         Begin (* check all 8 bits *)
         temp := CRC xor Abyte ;
         CRC := CRC shr 1 ;             (* shift right *)
         If Odd(temp) then CRC := CRC xor $8408 ;
         abyte := abyte shr 1 ;
         End ; (* check all 8 bits *)
    End ; (* CRCheck *)
(* ----------------------------------------------------------------- *)
(* Prefixof Function - Returns a char string of the dir prefix.      *)
(* ----------------------------------------------------------------- *)
 function Prefixof(afilename:comstring) : comstring;
 var i :integer;
 label exit ;
    begin (* Prefixof *)
    while length(afilename)>0 do
         If afilename[length(afilename)] in [':','\','/']
             then goto exit
             else delete(afilename,length(afilename),1);
 exit:
    Prefixof := afilename ;
    end;  (* Prefixof *)

(* ----------------------------------------------------------------- *)
(*  NewAsFile - returns a new ASFILE name in the parameter AsFile.   *)
(*           MyFiles - is the wild char name.                        *)
(*           Filename - is the filename to be renamed .              *)
(*           AsFiles  - is the wild char name of new file.           *)
(*           AsFile   - is the new file name.                        *)
(*     returns TRUE if AsFile correctly assigned.                    *)
(*     returns FALSE if AsFile detected an error in assignment       *)
(*   There is a BUG in the MsDoS Call to get next Directory Entry    *)
(*   therefore this function may return FALSE.                       *)
(*                                                                   *)
(* ----------------------------------------------------------------- *)
Function NewAsFile (MyFiles,Filename,AsFiles: comstring;
                    var AsFile : comstring                ): boolean;
var
    temp : comstring ;
    si,ix,iy : integer ;
    star : packed array[1..8] of string[20];
Label  Subdir,Exit;

Begin (* NewAsFile Function *)
for si := 1 to 8 do star[si] := '*';
si := 0 ;
 MyFiles  := Uppercase(Myfiles);
 FileName := Uppercase(Filename);
 AsFiles  := Uppercase(AsFiles);
 ix := Pos(':',MyFiles) ;
 If ix > 1 then delete(MyFiles,1,ix) ;  (* Eliminate filemode prefix *)
subdir:
 ix := Pos('\',MyFiles) ;
 If ix > 1 then delete(MyFiles,1,ix) ;  (* Eliminate sub-dir  prefixs *)
 if ix > 1 then goto subdir ;
 ix := Pos(':',AsFiles) ;
 If ix > 1 then delete(AsFiles,1,ix) ;  (* Eliminate filemode prefix *)
While (length(Filename) > 0) and (length(Myfiles)>0) Do
    Begin (* Scan filename *)
    If MyFiles[1] = Filename[1] then
        Begin delete(MyFiles,1,1) ; delete(Filename,1,1); end
                                else
         Begin (* get star string *)
         si:=si+1 ;
         delete(MyFiles,1,1);
         ix := Pos('*',MyFiles) - 1 ;  (* Next wild char *)
         if ix <= 0 then  temp := MyFiles
                    else  temp := copy(Myfiles,1,ix);
         iy := Pos(temp,Filename)-1 ;
         if iy < 0 then
              begin NEWASFILE:=FALSE; Asfile:='temp.dat'; Goto exit ; end;
         if iy = 0 then star[si] := filename
                    else star[si] := copy(filename,1,iy);
         delete(FileName,1,iy);
         End ;(* get star string *)
    End; (* Scan filename *)
ix := 1 ;
si := 1 ;
AsFile := '';
While ix <= length(AsFiles)  do
    Begin (* Create AsFile name *)
    If AsFiles[ix] in ['*','?'] then
         Begin (* wild char *)
         AsFile := Concat(AsFile,star[si]);
         si := si + 1 ;
         End
                                else
        AsFile := Concat(AsFile,Asfiles[ix]);
   ix := ix + 1 ;
   End ; (* Create AsFile name *)
NewAsFile := True ;
Exit:
End; (* NewASFile Function *)

(* ============ End of   U T I L I T Y   Procedures =================== *)

(* +FILE+ SYSFUNC.PASMS *)
(* ================================================================= *)
(*  MsDos SYSTEM  dependent Routines for Kermit .                    *)
(* ================================================================= *)
(* Global Declaration  *)
CONST
    (* FLAGS in flag register *)
    Cflag = $0001 ;
    Pflag = $0004 ;
    Aflag = $0010 ;
    Zflag = $0040 ;
    Tflag = $0100 ;
    Iflag = $0200 ;
    Dflag = $0400 ;
    Oflag = $0800 ;

TYPE
    regtype = record case layouts of
              one: ( ax,bx,cx,dx,bp,si,di,ds,es,flags          : integer ;);
              two: ( al,ah,bl,bh,cl,ch,dl,dh                   : byte ; ) ;
           three : ( Sectors,Clusters,BytesperSec,TotalClusters: integer;)
              end ;
    ScreenArray = array [1..4000] of byte ;

VAR
    register  : regtype ;
    MyDTA : array [1..43] of byte ;
    Remotecursor,LocalCursor : integer ;

    Commandline : comstring absolute Cseg:$80 ;


    MonoScreen      : ScreenArray absolute $B000:$0000 ; (* Monchrome Video *)
    ColorScreen     : ScreenArray absolute $B800:$0000 ; (* Colour graphics *)
    OldLocalScreen  : ScreenArray  ;
    OldRemoteScreen : ScreenArray  ;
    NumLock,ScrollLock : byte ;

(* ------------------------------------------------------------------ *)
(* KeyChar - get a character from the Keyboard.                       *)
(*           It returns TRUE if character found and the char is       *)
(*           returned in the parameter.                               *)
(*           It returns FALSE if no keyboard character.               *)
(*                                                                    *)
(* ------------------------------------------------------------------ *)
    Function KeyChar (var Achar,Bchar : byte): boolean ;
    Begin (* KeyChar *)
    with register do
           begin
           ah := 1;
           intr($16,register);
           if (Zflag and flags)=Zflag then

(* ------ The following code is required only if we want to us the ----- *)
(* ------ NUMLOCK and SCROLLLOCK key as function keys  ----------------- *)
              begin (* check for Numlck and Scroll Lck *)
              ah := 2;
              intr($16,register);
              If  (al and $10) <> ScrollLock then
                   Case (al and $0F) of
                   0:     Bchar := $46 ; (* not shifted *)
                   1,2,3: Bchar := $86 ; (* shifted *)
                   4,5,6,7: Bchar := $87 ; (* control *)
                   else Bchar := $87 ; (* Alt *)
                   end  (* case *)
                                            else
              If  (al and $20) <> NumLock then
                   Case (al and $0F) of
                    0:     Bchar := $45 ; (* not shifted *)
                    1,2,3: Bchar := $85 ; (* shifted *)
                    4,5,6,7: Bchar := $88 ; (* control *) (* Not Available *)
                    Else Bchar := $88 ; (* Alt *)
                   End (* case *)
                                             else Bchar := 0 ;
              ScrollLock := (al and $10) ;
              NumLock := (al and $20) ;
              Achar := 0 ;
              If Bchar <> 0 then   KeyChar := true
                            else   KeyChar := false
              End   (* check for Numlck and Scroll Lck *)
(*------ If you don't need this code, replace it with ------------------ *)
(* --------   KeyChar := False ----------------------------------------- *)

                                     else
              begin
              ah := 0;
              intr($16,register);
              Achar := al ;
              Bchar := ah ;
              KeyChar := true;
              end ;
           end;
    End ; (* KeyChar *)


(* ------------------------------------------------------------------ *)
(* CursorPosition - Returns Cursor Position in Reg DX.                *)
(* ------------------------------------------------------------------ *)
    Procedure CursorPosition ;
    Begin (* CursorPosition *)
    With register do
         begin (* Get position *)
         ah := 3;
         intr($10,register);
         end; (* Get position *)
    End;
(* ------------------------------------------------------------------ *)
(* CursorUp -                                                         *)
(* ------------------------------------------------------------------ *)
    Procedure CursorUp ;
    Begin (* CursorUp *)
    With register do
         begin (* Move up *)
         ah := 3;  (* Function code 3 - Read Cursor Position *)
         intr($10,register);
         if dh > 1 then dh := dh - 1
                   else dh := 24 ;
         ah := 2 ;  (* Function code 2 - Set Cursor Position *)
         intr($10,register);
         end; (* Move up *)
    End;  (* CursorUp *)

(* ------------------------------------------------------------------ *)
(* CursorDown -                                                       *)
(* ------------------------------------------------------------------ *)
    Procedure CursorDown ;
    Begin (* CursorDown *)
    With register do
         begin (* Move Down *)
         ah := 3;  (* Function code 3 - Read Cursor Position *)
         intr($10,register);
         if dh < 24 then dh := dh + 1
                   else dh := 1 ;
         ah := 2 ;  (* Function code 2 - Set Cursor Position *)
         intr($10,register);
         end; (* Move Down *)
    End;  (* CursorDown *)

(* ------------------------------------------------------------------ *)
(* CursorRight -                                                      *)
(* ------------------------------------------------------------------ *)
    Procedure CursorRight ;
    Begin (* CursorRight *)
    With register do
         begin (* Move Right *)
         ah := 3;  (* Function code 3 - Read Cursor Position *)
         intr($10,register);
         if dl < 80 then dl := dl + 1
                   else dl := 1 ;
         ah := 2 ;  (* Function code 2 - Set Cursor Position *)
         intr($10,register);
         end; (* Move Right *)
    End;  (* CursorRight *)

(* ------------------------------------------------------------------ *)
(* CursorLeft -                                                       *)
(* ------------------------------------------------------------------ *)
    Procedure CursorLeft ;
    Begin (* CursorLeft *)
    With register do
         begin (* Move Left *)
         ah := 3;  (* Function code 3 - Read Cursor Position *)
         intr($10,register);
         if dl > 0 then dl := dl - 1
                   else dl := 80 ;
         ah := 2 ;  (* Function code 2 - Set Cursor Position *)
         intr($10,register);
         end; (* Move Left *)
    End;  (* CursorLeft *)
(* ------------------------------------------------------------------ *)
(* FatCursor -                                                       *)
(* ------------------------------------------------------------------ *)
    Procedure FatCursor(flag :boolean);
    Begin (* FatCursor *)
    Port[$3D4] := $B ; (* Select Cursor end Register *)
    If flag then Port[$3D5] := 9
            else Port[$3D5] := 7 ;
    End;  (* FatCursor *)


(* ------------------------------------------------------------------ *)
(* RemoteScreen - Procedure                                           *)
(*                This procedure save the local screen and restores   *)
(*                the remote screen.                                  *)
(*                Also setup the 25th line to display settings        *)
(* ------------------------------------------------------------------ *)
    Procedure RemoteScreen ;
    Begin (* RemoteScreen *)
    If (OldRemoteScreen[4000]<>1) or (OldRemoteScreen[3999]<>32) then
         Begin (* Initialize OldRemoteScreen *)
         For i := 1 to 4000 do OldRemoteScreen[i] := 32 ;
         OldRemoteScreen[4000] := 1 ;
         RemoteCursor := $0000 ;
         End ; (* Initialize OldRemoteScreen *)
    With register do
         begin (* Switch Screens *)
         bx := 0 ;
         ah := 15;  (* Function code 15 - Return Current video State *)
         intr($10,register);
         if al < 7 then
              Begin (* Color Screen *)
              OldLocalScreen := ColorScreen ;
              ColorScreen := OldRemoteScreen ;
              End  (* Color Screen *)
                   else
              Begin (* MonoChrome Screen *)
              OldLocalScreen := MonoScreen ;
              MonoScreen := OldRemoteScreen ;
              End  (* MonoChrome Screen *)
         end ; (* Switch Screens *)
    With register do
         begin (* Save ? Restore Cursor *)
         bx := 0 ;
         ah := 3;  (* Function code 3 - Read Cursor Position *)
         intr($10,register);
         localcursor := dx ;

         (* ---- set up 25th line with status ------ *)
         ah := 2;       (* Function code 2 - Set Cursor Position *)
         DX := $1800;   (* Set the cursor to Row 25 and column 0 *)
         Intr($10,Register);
         Textcolor(Blue); Textbackground(Yellow);
         Write  (' Port ');
         If PrimaryPort then Write('One : ')
                        else Write('Two : ');
         Write(Baudrate,' baud, ');
         Case paritytype(parity) of
             OddP : write('Odd  ');
             EvenP: write('Even ');
             MarkP: write('Mark ');
             NoneP: write('None ');
         end ; (* parity case *)
         Write('parity, ');
         If LocalEcho then Write('Half duplex, ')
                      else Write('Full duplex, ');
         If XonXoff then write('Xon-Xoff ')
                    else if Series1 then write('Series/1 ')
                                    else write('Standard ');
         Write  ('    ExitChar=CTL ',chr($40+LocalChar),'  ' ) ;
         Textcolor(LightGreen); Textbackground(0);

         (* -------------------------------------------- *)

         dx := remotecursor ;
         ah := 2 ;  (* Function code 2 - Set Cursor Position *)
         intr($10,register);
         end; (* Save ? Restore Cursor *)
    Window(1,1,80,24);
    End;  (* RemoteScreen *)

(* ------------------------------------------------------------------ *)
(* LocalScreen  - Procedure                                           *)
(*                This procedure save the remote screen and restores  *)
(*                the local  screen.                                  *)
(* ------------------------------------------------------------------ *)
    Procedure LocalScreen ;
    Begin (* LocalScreen *)
    With register do
         begin (* Switch Screens *)
         bx := 0 ;
         ah := 15;  (* Function code 15 - Return Current video State *)
         intr($10,register);
         if al < 7 then
              Begin (* Color Screen *)
              OldRemoteScreen := ColorScreen ;
              ColorScreen := OldLocalScreen ;
              End  (* Color Screen *)
                   else
              Begin (* MonoChrome Screen *)
              OldRemoteScreen := MonoScreen ;
              MonoScreen := OldLocalScreen ;
              End  (* MonoChrome Screen *)
         end ; (* Switch Screens *)
    With register do
         begin (* Save and Restore Cursor *)
         ah := 3;  (* Function code 3 - Read Cursor Position *)
         intr($10,register);
         Remotecursor := dx ;
         dx := Localcursor ;
         ah := 2 ;  (* Function code 2 - Set Cursor Position *)
         intr($10,register);
         end; (* Save and Restore Cursor *)
    TextColor(Yellow); TextBackground(Black);
    Window(1,1,80,25);
    End;  (* LocalScreen *)

(* ----------------------------------------------------------------- *)
(* FirstFile - Returns True if file found for file mask Myfile       *)
(*                 and the first file name is returned in Filename   *)
(*           - Returns False if no file Found.                       *)
(* ----------------------------------------------------------------- *)
Function FirstFile(Myfile:Comstring; var Filename:Comstring): Boolean ;
Var
    OldSegment,OldOffset,i : integer ;

    Begin (* FirstFile Function *)
    Myfile := concat(myfile,chr(0));
    With Register do
         Begin { Search for File }

         Ax := $2F00 ;      { Get DTA Dos Function }
         MsDos(Register);
         OldSegment := Es ; OldOffset := Bx ;  (* save old DTA location *)

         Ds := Seg(MyDTA);  Dx := Ofs(MyDTA) ;
         Ax := $1A00 ;      { Set DTA Dos Function }
         MsDos(Register);                      (* set my  DTA location *)

         Ax := $4E00 ;      {get first directory entry }
         Ds := Seg(Myfile); { mask location }
         Dx := Ofs(Myfile)+1;
         Cx := 2 ;          {option}
         MsDos(Register);
         if al = 0 then    { Got file }
              Begin (* Got File *)
              i := 1 ;
              Repeat
                 Filename[i] := Chr (MyDTA[30 + i]) ;
                 i := i + 1 ;
              until (not (Filename[i-1] in [' '..'~'])) ;
              Filename[0] := chr(i - 2);
              Firstfile := true ;
              End  (* Got file *)
                 else
              Firstfile := False ;

         Ds := OldSegment ;  Dx := OldOffset ;
         Ax := $1A00 ;      { Set DTA Dos Function }
         MsDos(Register);                    (* reset old DTA location *)
         End; { Search for File }
    End; { FirstFile Function }
(* ----------------------------------------------------------------- *)
(*  NextFile - Returns True if file found for file mask Myfile       *)
(*                 and the first file name is returned in Filename   *)
(*           - Returns False if no file Found.                       *)
(* ----------------------------------------------------------------- *)
Function NextFile(Var Myfile, Filename : Comstring): Boolean ;
Var
    OldSegment,OldOffset,i : integer ;

    Begin (* NextFile Function *)
    With Register do
         Begin { Search for File }

         Ax := $2F00 ;      { Get DTA Dos Function }
         MsDos(Register);
         OldSegment := Es ; OldOffset := Bx ;  (* save old DTA location *)

         Ds := Seg(MyDTA);  Dx := Ofs(MyDTA) ;
         Ax := $1A00 ;      { Set DTA Dos Function }
         MsDos(Register);                      (* set my DTA location *)

         Ax := $4F00 ;      { get next directory entry }
         MsDos(Register);
         if al = 0 then    { Got file }
              Begin (* Got File *)
              i := 1 ;
              Repeat
                 Filename[i] := chr (MyDTA[30 + i]) ;
                 i := i + 1 ;
              until (not (Filename[i-1] in [' '..'~'])) ;
              Filename[0] := chr(i - 2);
              Nextfile := true ;
              End  (* Got file *)
                 else
              Nextfile := False ;

         Ds := OldSegment ;  Dx := OldOffset ;
         Ax := $1A00 ;      { Set DTA Dos Function }
         MsDos(Register);                    (* reset old DTA location *)
         End; { Search for File }
    End; { NextFile Function }

(* ------------------------------------------------------------------ *)
(* SetDefaultDrive -                                                  *)
(* ------------------------------------------------------------------ *)
    Procedure SetDefaultDrive (Drive : Byte);
    Begin (* SetDefaultDrive *)
    With register do
         begin (* Select disk *)
         DL := Drive ;
         Ax := $0E00 ;      { Select default drive }
         MsDos(Register);
         end; (* Select disk *)
    End;  (* SetDefaultDrive *)

(* ------------------------------------------------------------------ *)
(* DefaultDrive - returns the value of the default drive              *)
(*                 A=0,B=1,C=2 etc.                                   *)
(* ------------------------------------------------------------------ *)
    Function DefaultDrive : Byte ;
    Begin (* DefaultDrive *)
    With register do
         begin (* Current disk *)
         Ax := $1900 ;      { Find default drive }
         MsDos(Register);
         DefaultDrive := al ;
         end; (* Current disk *)
    End;  (* DefaultDrive *)

(* ----------------------------------------------------------------- *)
(*  DisplayDiskStatus - Display the disk status for the default disk.*)
(*                                                                   *)
(* ----------------------------------------------------------------- *)
Procedure DisplayDiskStatus  ;
Var
    Freebytes : real ;
Begin (* DisplayDiskStatus *)
With Register do
    Begin { Get disk status }
    dl := DefaultDrive + 1 ;  (* use default drive *)
    Write (' Disk Drive ',chr(DX+$40),':     ');
    Ax := $3600 ;      { Get diskstatus Function }
    MsDos(Register);
    Writeln('Bytes/sector = ',BytesperSec,'  Sector/cluster = ',Sectors);
    Writeln('Total Clusters = ',TotalClusters);
    FreeBytes := BytesperSec*Sectors; (* two steps required due to  *)
    FreeBytes := FreeBytes*Clusters ; (* integer overflow *)
    Writeln('Free Clusters  = ',Clusters,'  i.e. ',Freebytes:7:0,' bytes free');
    End; (* Get disk status *)
End;  (* DisplayDiskStatus *)
(* ----------------------------------------------------------------- *)
(* MkDir - Make Directory.                                           *)
(* ----------------------------------------------------------------- *)
Procedure MkDirFunc(DirName:Comstring) ;
    Begin (* MkDir  *)
    DirName := DirName + chr(0) ;
    With Register do
         Begin { MD  }
         Ds := Seg(DirName);  Dx := Ofs(DirName)+1 ;
         Ax := $3900 ;      { MkDir Function }
         MsDos(Register);
         While Mem[Ds:Dx] <> 0 Do
              Begin Write(Chr(Mem[Ds:Dx])); Dx := Dx + 1 ; End ;
        Case Al of
            0: writeln(' - New Directory Made ');
            3: writeln(' - Path not found');
            5: writeln(' - Acess denied');
            else writeln(' - Return code =',al);
          end; (* case of Ax *)
        End ; { MD }
    End ; (* MkDir *)
(* ----------------------------------------------------------------- *)
(* RmDir - Remove Directory.                                         *)
(* ----------------------------------------------------------------- *)
Procedure RmDirFunc(DirName:Comstring) ;
    Begin (* RmDir  *)
    DirName := DirName + chr(0) ;
    With Register do
         Begin { Remove Directory }
         Ds := Seg(DirName);  Dx := Ofs(DirName)+1 ;
         Ax := $3A00 ;      { RmDir Function }
         MsDos(Register);
         While Mem[Ds:Dx] <> 0 Do
              Begin Write(Chr(Mem[Ds:Dx])); Dx := Dx + 1 ; End ;
         Case Al of
              0: writeln(' - Directory Removed ');
              3: writeln(' - Path not found');
              5: writeln(' - Acess denied');
            else writeln(' - Return code =',al);
            end; (* case of Ax *)
        End ; { Remove Directory }
    End ; (* RmDir *)
(* ----------------------------------------------------------------- *)
(* ChDir - Change Directory.                                         *)
(* ----------------------------------------------------------------- *)
Procedure ChDirFunc(DirName:Comstring) ;
    Begin (* ChDir  *)
    DirName := DirName + chr(0) ;
    With Register do
         Begin { CD  }
         Ds := Seg(DirName);  Dx := Ofs(DirName)+1 ;
         Ax := $3B00 ;      { ChDir Function }
         MsDos(Register);
         While Mem[Ds:Dx] <> 0 Do
              Begin Write(Chr(Mem[Ds:Dx])); Dx := Dx + 1 ; End ;
         Case Al of
              0: writeln(' - Current Directory  ');
              3: writeln(' - Path not found');
              5: writeln(' - Acess denied');
            else writeln(' - Return code =',al);
            end; (* case of Ax *)
        End ; { CD }
    End ; (* ChDir *)

(* ----------------------------------------------------------------- *)
(*  EXECFile - Exec a file.                                          *)
(*                                                                   *)
(* ----------------------------------------------------------------- *)
Procedure EXECFile (Var RunString : comstring) ;
Type
     FCB      = record
                Drive    : char ;
                filename : array [1..8] of char ;
                filetype : array [1..3] of char ;
                Curblock : integer ;
                Recsize  : integer ;
                DosUse   : array [1..16] of char ;
                CurRec   : byte ;
                Randlow  : integer ;
                Randhigh : integer ;
                end ;
     PPBrecord = record
                 SegAddr       : integer ;
                 ComlinePt     : ^Comstring ;
                 FCB1pt,FCB2pt : ^FCB ;
                 end;
Var
    PPB         : PPBrecord ;
    Myfile      : comstring ;
    FCB1,FCB2   : FCB ;

Begin (* RunFile *)
Myfile := Gettoken(Runstring);
If Pos('.',Myfile) = 0 then Myfile := Myfile + '.COM' ;
With Register do
    Begin (* SetBlock - Modify allocated Memory Blocks  *)
    Ax := $4A00 ;      (* Set Block - Free up unused memory  *)
    Es := CSeg ;       (* Point to begining of block *)
    Bx := SSeg ;       (* Amount of memory in use *)
    MsDos(Register);
    Writeln(Register.BX,' paragraphs of memory in use .');
    End ;  (* SetBlock - Modify allocated Memory Blocks  *)

Writeln(' Exec program  ',Myfile);
Myfile := Myfile + chr($00) ;
With Register do
    Begin (* Set up Run  *)
    Ax := $4B00 ;      (* Load and EXEC Function *)
(*  Ax := $4B03 ;  *)  (* Load Overlay  Function *)
    DS := Seg(Myfile); DX := Ofs(Myfile)+1 ; (* Point to Program name *)
    ES := Seg(PPB) ;   BX := Ofs(PPB);       (* Point to Program Parm block *)
    With PPB do
         BEGIN  (* set up Program Parameter Block *)
         SegAddr   :=  Memw[CSEG :$2C] ;
         Comlinept :=  Addr(RunString);
         FCB1pt    :=  Addr(FCB1);
         FCB2pt    :=  Addr(FCB2);
         End ;  (* set up Program Parameter Block *)

(*  MsDos(Register);      *)
     (* The following in line code does the same thing as the MsDos call *)
     (* with the exception that it also save and restores the SS and SP reg. *)
    Inline (  $BF/Register/  (* MOV DI,Register *)
              $1E/           (* PUSH DS *)
              $07/           (* POP  ES *)
              $1E/           (* PUSH DS *)
              $06/           (* PUSH ES *)
              $57/           (* PUSH DI *)
              $55/           (* PUSH BP *)
              $53/           (* PUSH BX *)
              $B9/$09/$00/   (* MOV  CX,0009 *)
              $26/           (* ES:     *)
              $FF/$35/       (* PUSH [DI] *)
              $47/           (* INC  DI *)
              $47/           (* INC  DI *)
              $E2/$F9/       (* LOOP back to PUSH [DI] *)
              $07/           (* POP  ES *)
              $1F/           (* POP  DS *)
              $5F/           (* POP  DI *)
              $5E/           (* POP  SI *)
              $5D/           (* POP  BP *)
              $5A/           (* POP  DX *)
              $59/           (* POP  CX *)
              $5B/           (* POP  BX *)
              $58/           (* POP  AX *)
    (* Now save SS and SP in location 104 of Code Segment *)
              $57/           (* PUSH DI *)
              $BF/$0104/     (* MOV  DI,0104 *)
              $2E/           (* CS:     *)
              $8C/$15/       (* MOV  [DI],SS *)
              $47/           (* INC  DI *)
              $47/           (* INC  DI *)
              $2E/           (* CS:     *)
              $89/$25/       (* MOV  [DI],SP *)
              $5F/           (* POP  DI *)

    (*  This dumb msdos call destroys all the register including SS and SP  *)
              $CD/$21/     (*  ********  MsDos Call  ******** *)

    (* Restore the SS and SP register from location 104 of Code Segment *)
              $BF/$0104/     (* MOV  DI,0104 *)
              $2E/           (* CS:     *)
              $8E/$15/       (* MOV  SS,[DI] *)
              $47/           (* INC  DI *)
              $47/           (* INC  DI *)
              $2E/           (* CS:     *)
              $8B/$25/       (* MOV  SP,[DI] *)
              $5F/           (* POP  DI *)
    (* Now restore the rest of the registers from the stack *)
              $9C/           (* PUSH F  *)
              $06/           (* PUSH ES *)
              $1E/           (* PUSH DS *)
              $57/           (* PUSH DI *)
              $56/           (* PUSH SI *)
              $55/           (* PUSH BP *)
              $52/           (* PUSH DX *)
              $51/           (* PUSH CX *)
              $53/           (* PUSH BX *)
              $50/           (* PUSH AX *)
              $8B/$EC/       (* MOV  BP,SP *)
              $8B/$7E/$18/   (* MOV  DI,[BP+18] *)
              $8E/$46/$1A/   (* MOV  ES,[BP+1A] *)
              $B9/$0A/$00/   (* MOV  CX,000A *)
              $26/           (* ES:     *)
              $8F/$05/       (* POP  [DI] *)
              $47/           (* INC  DI  *)
              $47/           (* INC  DI  *)
              $E2/$F9/       (* LOOP back to POP [DI] *)
              $5B/           (* POP  BX *)
              $5D/           (* POP  BP *)
              $5F/           (* POP  DI *)
              $07/           (* POP  ES *)
              $1F);          (* POP  DS *)
    Case Ax of
         2: writeln('File >>> ',Myfile, ' <<< not found');
         5: writeln('Acess denied');
         8: writeln('Insufficient Memory to load program');
        10: writeln('Invalid Environment');
        end; (* case of Ax *)
    End; (* Set up Run  *)
 Writeln(' Return from Execution of ',Myfile);
End;  (* RunFile *)

(* +FILE+ SYSFUNC.PASCPM *)
(* ================================================================= *)
(*  CP/M SYSTEM  dependent Routines for Kermit                       *)
(* ================================================================= *)
(* Global Declaration  *)
TYPE
    FCBrecord = record
                Drive : byte ;
                Fname : array [1..8] of char ;
                Ftype : array [1..3] of char ;
                Extent: byte ;
                Sbite1: byte ;
                Sbite2: byte ;
                RCount: byte ;  (* record count *)
                CBdata: array [1..16] of char ;
                CurRec: byte ;
                r0r1  : integer ;
                r2    : byte ;
                end ;
    listpointer = ^Filenamerec;
    Filenamerec = record
                  Link : listpointer ;
                  nextname : string[12] ;
                  end ;
VAR
    Commandline : string[80] absolute $80 ;
    FCB : FCBrecord absolute $005C ;
    DMA : array[0..255] of char ;
    FNHead : listpointer ;
    Marker : listpointer ;
(* ------------------------------------------------------------------ *)
(* Sound - Dummy sound routine for CPM system.                        *)
(* ------------------------------------------------------------------ *)
    Procedure Sound (dummy : integer );
    Begin (* Sound *)
    write(chr(7));
    End ; (* Sound *)
    Procedure Nosound ; begin end;

(* ------------------------------------------------------------------ *)
(* KeyChar - get a character from the Keyboard.                       *)
(*           It returns TRUE if character found and the char is       *)
(*           returned in the parameter.                               *)
(*           It returns FALSE if no keyboard character.               *)
(*                                                                    *)
(* ------------------------------------------------------------------ *)
    Function KeyChar (var Achar,Bchar : byte): boolean ;
    var mychar : char ;
    Begin (* KeyChar *)
    If keypressed then
         Begin (* got a key *)
         Read(KBD,mychar);
         Achar := Ord(mychar);
         Bchar := 0;
         KeyChar := true ;
         End
                  else
        Keychar := false ;
    End ; (* KeyChar *)


(* ------------------------------------------------------------------ *)
(* RemoteScreen - Save the local screen and restores the Remotescreen *)
(* ------------------------------------------------------------------ *)
    Procedure RemoteScreen ;
    Begin (* RemoteScreen *)
    Clrscr ;
    End;

(* ------------------------------------------------------------------ *)
(* LocalScreen - Save the local screen and restores the Remotescreen *)
(* ------------------------------------------------------------------ *)
    Procedure LocalScreen ;
    Begin (* LocalScreen *)
    Clrscr ;
    End;

(* ------------------------------------------------------------------ *)
(* CursorPosition - Returns Cursor Position in Reg DX.                *)
(* ------------------------------------------------------------------ *)
    Procedure CursorPosition ;
    Begin (* CursorPosition *)
    End;
(* ------------------------------------------------------------------ *)
(* CursorUp -                                                         *)
(* ------------------------------------------------------------------ *)
    Procedure CursorUp ;
    Begin (* CursorUp *)
    write(Chr($0B));     (* Vertical Tab *)
    End;  (* CursorUp *)

(* ------------------------------------------------------------------ *)
(* CursorDown -                                                       *)
(* ------------------------------------------------------------------ *)
    Procedure CursorDown ;
    Begin (* CursorDown *)
    write(Chr($0A));       (* LineFeed *)
    End;  (* CursorDown *)

(* ------------------------------------------------------------------ *)
(* CursorRight -                                                      *)
(* ------------------------------------------------------------------ *)
    Procedure CursorRight ;
    Begin (* CursorRight *)
    write(Chr($0C));      (* Form Feed *)
    End;  (* CursorRight *)

(* ------------------------------------------------------------------ *)
(* CursorLeft -                                                       *)
(* ------------------------------------------------------------------ *)
    Procedure CursorLeft ;
    Begin (* CursorLeft *)
    write(Chr($08));      (* BackSpace *)
    End;  (* CursorLeft *)

(* ------------------------------------------------------------------ *)
(* SetDefaultDrive -                                                  *)
(* ------------------------------------------------------------------ *)
    Procedure SetDefaultDrive (Drive : Byte);
    Var dummy : byte ;
    Begin (* SetDefaultDrive *)
    Dummy := Bdos(14,Drive);      (* Select Drive *)
    End;  (* SetDefaultDrive *)

(* ------------------------------------------------------------------ *)
(* DefaultDrive - returns the value of the default drive              *)
(*                 A=0,B=1,C=2 etc.                                   *)
(* ------------------------------------------------------------------ *)
    Function DefaultDrive : Byte ;
    Begin (* DefaultDrive *)
    DefaultDrive := Bdos(25) ;  (* Current Disk *)
    End;  (* DefaultDrive *)
(* ----------------------------------------------------------------- *)
(* ----------------- Build Next List Procedure --------------------- *)
    Procedure BuildNextList(var Pt : listpointer);
    Var dot,i,results : byte ;
        Newpt: listpointer ;
    Begin (* BuildNextList *)
    I := Bdos(26,addr(DMA));
    Results := Bdos(18);
    If Results < 4 then
         Begin (* found file *)
         New(Newpt);
         Pt := Newpt;
         With Newpt^ do
             Begin (* Get file name in list *)
             Link := nil ;
             nextname[0] := chr(12) ;
             results := results * 32 ;
             for i := 1 to 8 do nextname[i] := DMA[results+i] ;
             nextname[9] := ' ' ;
             dot := pos(' ',nextname) ;
             nextname[dot] := '.' ;
             for i := 1 to 3 do nextname[dot+i] := DMA[results+8+i] ;
             nextname[0] := Chr(dot+3) ;
             end ; (* Get file name in list *)
         BuildNextList(Newpt^.link)
         End ;   (* Found file *)
              (*  else do nothing *) ;
     End ; { BuildNextlist }
(* ----------------- Get Next Procedure ----------------------------------- *)
     Function GetNext ( Var FN : comstring ): boolean ;
     Var Pt : listpointer ;
     Begin (* GetNext *)
     If FNhead = Nil then
         Begin (* end of List *)
         GetNext := false ;
         Release(Marker);
         End   (* end of list *)
                     else
         Begin (* get name *)
         FN := FNhead^.nextname;
         pt := Fnhead ;
         FNhead := Fnhead^.link ;
         GetNext := true ;
         End ; (* get name *)
     End ; (* GetNext *)
(* ----------------------------------------------------------------- *)
(* ----------------------------------------------------------------- *)
(* FirstFile - Returns True if file found for file mask Myfile       *)
(*                 and the first file name is returned in Filename   *)
(*           - Returns False if no file Found.                       *)
(* note: because the CPM call FIND NEXT can not be issued after      *)
(*       an open or close operation, the find next must be done here *)
(*       for the the NEXTFILE function.  We will use a link list of  *)
(*       file names.                                                 *)
(* ----------------------------------------------------------------- *)

Function FirstFile(Myfile:Comstring; var Filename:Comstring): Boolean ;
Var
    colon,Dot,asterisk,I,results : byte ;
    temp : string[20] ;

    Begin (* FirstFile Function *)
    Myfile := uppercase(Myfile) ;
    With FCB do
         Begin (* set up FCB *)
         Drive := 0 ;
         colon := pos(':',Myfile) ;
         if colon <> 0 then
              begin (* disk drive specified *)
              drive := Ord(myfile[1])-$40 ;
              delete(Myfile,1,colon);
              end ; (* disk drive specified *)
         dot := pos('.',Myfile);
         if dot=0 then dot := 8 ;
         temp := myfile ;
         delete(temp,dot,12);
         asterisk := pos('*',temp);
         if asterisk <> 0 then
             begin (* wild char *)
             temp[asterisk] := '?' ;
             while length(temp)< 8 do insert('?',temp,asterisk);
             end ; (* wild char *)
         temp := temp + '       ' ;
         for i := 1 to 8 do FName[i] := temp[i] ;
         temp := myfile ;
         delete(temp,1,dot);
         asterisk := pos('*',temp);
         if asterisk <> 0 then
             begin (* wild char *)
             temp[asterisk] := '?' ;
             while length(temp)< 3 do insert('?',temp,asterisk);
             end ; (* wild char *)
         temp := temp + '   ' ;
         for i := 1 to 3 do FType[i] := temp[i] ;
         End ;  (* set up FCB *)
    I := Bdos(26,addr(DMA)) ;
    Results := Bdos(17,addr(FCB)) ;
    If Results < 4 then
         Begin (* found file *)
         filename[0] := chr(12) ;
         results := results * 32 ;
         for i := 1 to 8 do filename[i] := DMA[results+i] ;
         filename[9] := ' ' ;
         dot := pos(' ',filename) ;
         filename[dot] := '.' ;
         for i := 1 to 3 do filename[dot+i] := DMA[results+8+i] ;
         filename[0] := Chr(dot+3);
         FirstFile := true ;
         New(Marker); Mark(marker);
         Buildnextlist(FNhead);
         End    (* Found file *)
                        else
         FirstFile := false ;
    End; { FirstFile Function }
(* ----------------------------------------------------------------- *)
(*  NextFile - Returns True if file found for file mask Myfile       *)
(*                 and the first file name is returned in Filename   *)
(*           - Returns False if no file Found.                       *)
(* ----------------------------------------------------------------- *)
Function NextFile(Var Myfile, Filename : Comstring): Boolean ;
    Begin (* NextFile *)
    NextFile := Getnext(Filename) ;
    End ; (* NextFile *)
(* ----------------------------------------------------------------- *)
(*  DisplayDiskStatus - Display the disk status for the default disk.*)
(*                                                                   *)
(* ----------------------------------------------------------------- *)
Procedure DisplayDiskStatus  ;
Type
    DPBrec = record
             SPT     : integer ;  (* sectors per track *)
             BSH     : byte ;     (* data alloc. block shift factor *)
             BLM     : byte ;
             EXM     : byte ;
         (*  Blocks  : integer ; *) (* total storage capacity *)
             Blocklo : byte ;
             BLockhi : byte ;
             DRM     : integer ;  (* number of directory entries *)
             AL0,AL1 : byte ;
             CKS     : integer ;
             OFF     : integer ;
             end ;
   DKspace = record diskspace : array[0..100] of byte ; end ;
Var DPB : ^DPBrec ;
    DK : ^DKspace ;
    Diskspaceindex,
    Blocks : integer ;
    i,j,freeblock : integer ;
    DefDrive : byte ;
Begin (* DisplayDiskStatus *)
DefDrive := DefaultDrive ;  (* save def drive *)
i := BDos(13) ;             (* reset drive to r/w *)
SetDefaultDrive(DefDrive) ; (* restore def drive *)
writeln(' ');
Write('Disk Drive ',Chr(DefaultDrive+$41),':  ');
DPB := Ptr(BdosHL(31)) ;      (* get disk parameters *)
with DPB^ do
    Begin (* display disk data *)
    Blocks := (Blockhi*256 + Blocklo);
    Write (' Total User Space =',(Blocks+1)*(BLM+1) DIV 8,' Kbytes, ');
    End ; (* display disk data *)
DK  := Ptr(BdosHL(27)) ;      (* get disk space vector *)
freeblock := 0;
with DK^ do
  for i := 0 to blocks do
       if (Diskspace[ (i div 8)] shl (i mod 8)) and $80 = 0 then
          freeblock := freeblock + 1 ;
  writeln (' Available Space =',freeblock*(DPB^.BLM+1) DIV 8,' Kbytes ');
End;  (* DisplayDiskStatus *)

(* ----------------------------------------------------------------- *)
(*  EXECfile - Execute a file .                                      *)
(*                                                                   *)
(* ----------------------------------------------------------------- *)
Procedure EXECfile( myfile: comstring);
Begin (* EXECfile *)
Writeln(' RUN function is not available in CP/M version ');
End;  (* EXECfile *)

(* +FILE+ MODEMPRO.PASMS *)
(* ================================================================= *)
(*  MODEM - Routines and Global variables for IBMPC compatiables     *)
(* ================================================================= *)

CONST
    (* Modem Registers *)
    LowOrderDiv      = 0 ;
    HiOrderDiv       = 1 ;  InterruptEnable = 1 ;
    InterruptIdReg   = 2 ;
    LineControlReg   = 3 ;
    ModemControlReg  = 4 ;
    LineStatusReg    = 5 ;
    ModemStatusReg   = 6 ;
    ClockRate        = 18430 ;  (* CentiHertz. - use 17895 for PCjr *)
    (* 8259 Interrupt Controller addresses *)
    (* IC8259Reg1 = $20 ;   IC8259Reg2 = $21 ; *)

    MaxBuffsize = 20000 ;
    DefaultBaud = 9600 ;

VAR
    connected : boolean ;
    Modem     : Integer ;
    EnableMask,ResetMask : byte ;
    IntVector,
    Saveoffset,SaveSeg  : integer ;

    Buffer : Packed array [1..MaxBuffsize] of byte ;
    Iout,Iin : integer ;

(* ------------------------------------------------------------------ *)
(* IntHandler - Interrupt handler                                     *)
(*            This procedure handles the modem interrupts ,           *)
(*            which occur for incomming data only.                    *)
(*            1. Offset 16 into this procedure must be initialize     *)
(*               with the correct value of the DS register before     *)
(*               using this routine.                                  *)
(*            2. The routine is to start at offset 7, i.e. it         *)
(*              bypasses the normal pascal entry code.                *)
(*            (See InitModem Routine)                                 *)
(*                                                                    *)
(* ------------------------------------------------------------------ *)
Procedure IntHandler  ;
    (* Interrupt code starts at Inline code $50             *)
    (* which is offset 7 bytes from beginning of IntHandler *)
    Begin (* IntHandler *)
    (* Save Registers and set up the proper DS register *)
    Inline($50/$53/$51/$52/$57/$56/$06/$1E/ (* PUSH ax,bx,cx,dx,di,si,es,ds *)
           $B8/$00/$00/                 (* MOV  ax,immediatevalue    *)
           $50/                         (* PUSH ax                   *)
           $1F/                         (* POP  ds - set ds          *)
           $FB) ;                       (* STI  set interrupt enable *)

    If (Port[Modem+LineStatusReg] and $01) = $01 then
         begin (* put char in buffer *)
         buffer[Iin] := Port[Modem];
         Iin := Iin + 1 ;
         if Iin = MaxBuffsize then Iin := 1 ;
         end ; (* put char in buffer *)
    Port[$20] := ResetMask ;

    (* Restore the registers and Return *)
    Inline ($1F/$07/$5E/$5F/$5A/$59/$5B/$58/ (* POP ds,es,si,di,dx,cx,bx,ax *)
            $CF);                            (* IRET *)
    End ;  (* IntHandler *)

(* ------------------------------------------------------------------ *)
(* InitModem - Initialize the modem and setup interrupt procedure.    *)
(*            The interrupt procedure is at IntHandler+7, and         *)
(*            the DS register must be stored in IntHandler+16.        *)
(*                                                                    *)
(* ------------------------------------------------------------------ *)
    Procedure Initmodem ;
    Var rate : integer ;
    Begin (* Init modem *)
    If PrimaryPort then
         Begin (* Primary port *)
         Modem := $3F8 ;
         EnableMask := $EF ;
         ResetMask := $64 ;    (* end of interrupt for IRQ4 *)
         IntVector := $0030 ;
         End  (* Primary Port *)
                  else
        Begin (* Secondary Port *)
        Modem := $2F8 ;
        EnableMask := $F7 ;
        ResetMask := $63 ;   (* end of interrupt for IRQ3 *)
        IntVector := $002C ;
        End ; (* Secondary Port *)
    Iin := 1 ; Iout := 1 ;

    (* Initialize the Interrupt Procedure *)
    Saveoffset := MemW[$0000:IntVector] ;     (* save the Old interrupt  *)
    SaveSeg    := MemW[$0000:IntVector+2] ;   (* address of serial interrupt *)

    MemW[$0000:IntVector] := Ofs(IntHandler) + 7 ;  (* Use our own interrupt *)
    MemW[$0000:IntVector+2] := Cseg ;               (*  hanlder              *)
    MemW[Cseg:Ofs(IntHandler)+16] := Dseg ;     (* set in  for handler   *)

    Port[$21] := Port[$21] and EnableMask ;  (* Enable serial port interrupt *)
    Port[$20] := ResetMask ;

    (* Initialize baud rates and bits and parity *)
    Rate := round( (Clockrate/16) / (Baudrate/100)) ;
    Port[Modem+LineControlReg] := $80 ;     (* Enable baud rate setting *)
    Port[Modem+LowOrderDiv]    := (rate and $00FF) ;
    Port[Modem+HiOrderDiv]     := rate div $100 ;
    Port[Modem+LineControlReg] := (ord(Parity) shl 4) OR $0A ;
                                  (* parity, 7 bits,1 stop *)
    Port[Modem+ModemControlReg] := $0B ;   (* DTR and RTS *)
    Port[Modem+InterruptEnable] := $01 ;   (* Data Avail. Interrupt set *)
    End ; (* Init modem *)

(* ------------------------------------------------------------------ *)
(*  ResetModem - Reset the Interrupt back to the original.            *)
(*       Global variables - Saveoffset,SaveSeq                        *)
(* ------------------------------------------------------------------ *)
    Procedure ResetModem;
    Begin (* Reset Modem Interrupt *)
    MemW[$0000:IntVector] := Saveoffset ;    (* restore the Old interrupt    *)
    MemW[$0000:IntVector+2] := SaveSeg  ;    (* address of serial interrupt *)
    End; (* Reset Modem Interrupt *)

(* ------------------------------------------------------------------ *)
(*  SetModem -  Set the baud rate and parity for modem.               *)
(*       Global variables - Modem,Clockrate,Baudrate,Parity           *)
(* ------------------------------------------------------------------ *)
    Procedure SetModem ;
    Var rate : integer ;
    Begin (* SetModem *)
    If PrimaryPort then
         Begin (* Primary port *)
         Modem := $3F8 ;
         EnableMask := $EF ;
         ResetMask := $64 ;    (* end of interrupt for IRQ4 *)
         End  (* Primary Port *)
                  else
        Begin (* Secondary Port *)
        Modem := $2F8 ;
        EnableMask := $F7 ;
        ResetMask := $63 ;   (* end of interrupt for IRQ3 *)
        End ; (* Secondary Port *)
    Rate := round( (Clockrate/16) / (Baudrate/100)) ;
    Port[Modem+LineControlReg] := $80 ;     (* Enable baud rate setting *)
    Port[Modem+LowOrderDiv]    := (rate and $00FF) ;
    Port[Modem+HiOrderDiv]     := rate div $100 ;
    Port[Modem+LineControlReg] := (ord(Parity) shl 4) OR $0A ;
                                  (* parity, 7 bits,1 stop *)
    End ; (* SetModem *)

(* ------------------------------------------------------------------ *)
(*  DialModem - Check and waits for modem to be connected.            *)
(*              It waits for DTR and CTS signals to be detected.      *)
(*  Side Effect - global variable 'connected' is set true.            *)
(* ------------------------------------------------------------------ *)
   Procedure DialModem ;
   var abyte,bbyte : byte ;
   Begin (* Dial Modem *)
   While ((Port[Modem+ModemStatusReg] and $30) <> $30) and DTRcheck Do
         Begin (* Connect modem please *)
         If audioFlag then
           Begin Sound(600);delay(100);Sound(2000);delay(200); nosound;end;
         writeln('  Please connect your modem ');
         delay (1000);
         DTRcheck := not (keychar(abyte,bbyte) and (abyte=$20)) ;
         End ; (* Connect modem please *)
   connected := true ;
   If audioflag then
       for i:=1 to 50 do begin sound(100*i);delay(5);end; nosound;
   Writeln('  Connection completed ');
   End ; (* Dial Modem *)

(* ------------------------------------------------------------------ *)
(* RecvChar - Receive a Character from the modem port.                *)
(*            TRUE - if there is a character from the modem and       *)
(*                   the character is returned in the parmeter.       *)
(*            FALSE - if no character found .                         *)
(*                                                                    *)
(* ------------------------------------------------------------------ *)
    Function RecvChar (var mchar : byte) : boolean ;
    Begin (* RecvChar *)
    if Iin <> Iout then
         begin (* get char from buffer *)
         mchar := buffer[Iout] and $7F ;
         Iout := Iout + 1 ;
         If Iout = MaxBuffsize then Iout := 1 ;
         RecvChar := true ;
         if logging then
                     Begin {$I-}
                     write(Logfile,chr(mchar));
                     If IOresult <> 0 then
                        Begin (* IO error *)
                        Writeln(' Disk is Full - logging teminated');
                        logging := false  ;
                        Close(Logfile);
                        End ; (* IO error *)
                     End ; {$I+}
         end   (* get char from buffer *)
                   else
         RecvChar := false ;
    End ; (* RecvChar *)

(* ------------------------------------------------------------------ *)
(* SendChar - Send a character thru the modem port.                   *)
(*           It waits for the previous character to be sent before    *)
(*           sending the current character.                           *)
(* ------------------------------------------------------------------ *)
    Procedure SendChar(char : byte ) ;
    Begin (* Send Char *)
    While  (Port[Modem+LineStatusReg] and $20) <> $20 do delay(1);
         Port[modem] := char ;
    End ;  (* Send Char *)

(* ------------------------------------------------------------------ *)
(* SendBreak- Send a break via the modem port .                       *)
(* ------------------------------------------------------------------ *)
    Procedure SendBreak ;
    Var Tbyte : byte ;
    Begin (* Send Break *)
    Tbyte := Port[Modem+LineControlReg] ;  (* save setting *)
    Port[Modem+LineControlReg] := $40 ;    (* break for 200 millsec *)
    Writeln(' *** BREAK *** ');
    Delay(200) ;
    Port[Modem+LineControlReg] := Tbyte ;    (* restore setting *)
    End ;  (* Send Break *)

(* ================================================================= *)
(*    End of MODEM routines for IBMPC compatiables.                  *)
(* ================================================================= *)

(* +FILE+ MODEMPRO.PASAPPLE *)
(* ================================================================= *)
(*  MODEM - Routines and Global variables for Apple II - PDA232.     *)
(* ================================================================= *)

CONST
    (* Modem Registers - Port assignment *)
    Modem            = $E0A8 ;
    LowOrderDiv      = 0 ;
    HiOrderDiv       = 1 ;  InterruptEnable = 1 ;
    InterruptIdReg   = 2 ;
    LineControlReg   = 3 ;
    ModemControlReg  = 4 ;
    LineStatusReg    = 5 ;
    ModemStatusReg   = 6 ;
    ClockRate        = 18430 ;  (* CentiHertz. - use 17895 for PCjr *)

VAR
    connected : boolean ;

(* ------------------------------------------------------------------ *)
(* InitModem - Initialize the modem.                                  *)
(*                                                                    *)
(* ------------------------------------------------------------------ *)
    Procedure Initmodem ;
    Var Rate : integer ;
    Begin (* Init modem *)
    (* Initialize baud rates and bits and parity *)
    Rate := round( (Clockrate/16) / (Baudrate/100)) ;
    Mem[Modem+LineControlReg] := $80 ;    (* Enable baud rate setting *)
    Mem[Modem+LowOrderDiv]    := (rate and $00FF) ;
    Mem[Modem+HiOrderDiv]     := rate div $100 ;
    Mem[Modem+LineControlReg] := (ord(Parity) shl 4) OR $0A ;
                                  (* parity, 7 bits,1 stop *)
    Mem[Modem+ModemControlReg] := $0B ;  (* DTR and RTS *)
    Mem[Modem+InterruptEnable] := $00 ;  (* No Interrupt set *)
    End ; (* Init modem *)

(* ------------------------------------------------------------------ *)
(*  ResetModem - Reset the Interrupt back to the original.            *)
(*                                                                    *)
(* ------------------------------------------------------------------ *)
    Procedure ResetModem;
    Begin (* Reset Modem Interrupt *)
    End; (* Reset Modem Interrupt *)

(* ------------------------------------------------------------------ *)
(*  SetModem -  Set the baud rate and parity for modem.               *)
(*       Global variables - Modem,Clockrate,Baudrate,Parity           *)
(* ------------------------------------------------------------------ *)
    Procedure SetModem ;
    Var rate : Integer ;
    Begin (* SetModem *)
    Rate := round( (Clockrate/16) / (Baudrate/100)) ;
    Mem[Modem+LineControlReg] := $80 ;    (* Enable baud rate setting *)
    Mem[Modem+LowOrderDiv]    := (rate and $00FF) ;
    Mem[Modem+HiOrderDiv]     := rate div $100 ;
    Mem[Modem+LineControlReg] := (ord(Parity) shl 4) OR $0A ;
                                  (* parity, 7 bits,1 stop *)
    End ; (* SetModem *)

(* ------------------------------------------------------------------ *)
(*  DialModem - Check and waits for modem to be connected.            *)
(*              It waits for DTR and CTS signals to be detected.      *)
(*  Side Effect - global variable 'connected' is set true.            *)
(* ------------------------------------------------------------------ *)
   Procedure DialModem ;
   Var abyte,bbyte : byte ;
   Begin (* Dial Modem *)
   While ((Mem[Modem+ModemStatusReg] and $30) <> $30) and DTRcheck Do
         Begin (* Connect modem please *)
     (*   Sound(600);delay(100);Sound(2000);delay(200); nosound;*)
         writeln('  Please connect your modem ');
         delay (1000);
         DTRcheck := Not (keychar(abyte,bbyte) and (abyte = $20)) ;
         End ; (* Connect modem please *)
   connected := true ;
(*   for i:=1 to 100 do begin sound(100*i);delay(10);end; nosound;  *)
   Writeln('  Connection completed ');
   End ; (* Dial Modem *)

(* ------------------------------------------------------------------ *)
(* RecvChar - Receive a Character from the modem port.                *)
(*            TRUE - if there is a character from the modem and       *)
(*                   the character is returned in the parmeter.       *)
(*            FALSE - if no character found .                         *)
(*                                                                    *)
(* ------------------------------------------------------------------ *)
    Function RecvChar (var mchar : byte) : boolean ;
    Begin (* RecvChar *)
    If (Mem[Modem+LineStatusReg] and $01) = $01 then
         begin (* get char from buffer *)
         mchar := Mem[Modem] and $7F ;
         RecvChar := true ;
         if logging then
                     Begin {$I-}
                     write(Logfile,chr(mchar));
                     If IOresult <> 0 then
                        Begin (* IO error *)
                        Writeln(' Disk is Full - logging teminated');
                        logging := false  ;
                        Close(Logfile);
                        End ; (* IO error *)
                     End ; {$I+}
         end   (* get char from buffer *)
                   else
         RecvChar := false ;
    End ; (* RecvChar *)

(* ------------------------------------------------------------------ *)
(* SendChar - Send a character thru the modem port.                   *)
(*           It waits for the previous character to be sent before    *)
(*           sending the current character.                           *)
(* ------------------------------------------------------------------ *)
    Procedure SendChar(char : byte ) ;
    Begin (* Send Char *)
    While  (Mem[Modem+LineStatusReg] and $20) <> $20 do delay(1);
        Mem[Modem] := char ;
    End ;  (* Send Char *)

(* ------------------------------------------------------------------ *)
(* SendBreak- Send a break via the modem port .                       *)
(* ------------------------------------------------------------------ *)
    Procedure SendBreak ;
    Var Tbyte : byte ;
    Begin (* Send Break *)
    Tbyte := Mem[Modem+LineControlReg] ;  (* save setting *)
    Mem[Modem+LineControlReg] := $40 ;    (* break for 200 millsec *)
    Writeln(' *** BREAK *** ');
    Delay(200) ;
    Mem[Modem+LineControlReg] := Tbyte ;    (* restore setting *)
    End ;  (* Send Break *)

(* ================================================================= *)
(*    End of MODEM routines for Apple  II computers with PDA232.     *)
(* ================================================================= *)

(* +FILE+ MODEMPRO.PASKAYII *)
(* ================================================================= *)
(*  MODEM - Routines and Global variables for Kaypro II.             *)
(* ================================================================= *)

CONST
    (* Modem Registers - Port assignment *)
    BaudrateReg = $00 ;
    ModemData   = $04 ;
    ModemStatus = $06 ;
    Ptable : array [0..3] of byte = (1,3,2,0) ;

    (* Flag in the Modem status register *)
    RxChar   = $01 ;         (* received char in modem data reg *)
    TxChar   = $04 ;         (* transmit buffer empty *)
    CTS      = $20 ;         (* Clear to Send signal *)
    DCD      = $08 ;         (* Data Carrier Detect *)

VAR
    connected : boolean ;

(* ------------------------------------------------------------------ *)
(* InitModem - Initialize the modem.                                  *)
(*                                                                    *)
(* ------------------------------------------------------------------ *)
    Procedure Initmodem ;
    Var rate : string[5] ;
    Begin (* Init modem *)

    Port[ModemStatus] := $03 ;  (* Select Write Reg 3 - Receive Option *)
    Port[ModemStatus] := $81 ;  (* 7 databit(80), Rx Enable(01) *)

    Port[ModemStatus] := $04 ;  (* Select Write Reg 4 - Modem Options *)
    Port[ModemStatus] := $44 +  (* x16clock(40),1 stopbit(04)  *)
                         PTable[Ord(Parity)];   (*  Parity  *)

    Port[ModemStatus] := $05 ;  (* Select Write Reg 5 - Xmit Options *)
    Port[ModemStatus] := $AA ;  (* DTR(80),7-bits(20),Tx Enable(08) *)
                                    (* RTS(20) *)

    Str(Baudrate,rate);
    Port[BaudRateReg] := Pos(rate,'  50   75  110  135  150  300  600' +
                ' 1200 1800 2000 2400 3600 4800 7200 9600 19200') div 5 ;

    End ; (* Init modem *)

(* ------------------------------------------------------------------ *)
(*  ResetModem - Reset the Interrupt back to the original.            *)
(*                                                                    *)
(* ------------------------------------------------------------------ *)
    Procedure ResetModem;
    Begin (* Reset Modem Interrupt *)
    End; (* Reset Modem Interrupt *)

(* ------------------------------------------------------------------ *)
(*  SetModem -  Set the baud rate and parity for modem.               *)
(*       Global variables - Modem,Clockrate,Baudrate,Parity           *)
(* ------------------------------------------------------------------ *)
    Procedure SetModem ;
    Var rate : string[5] ;
    Begin (* SetModem *)
    Port[ModemStatus] := $04 ;  (* Select Write Reg 4 - Modem Options *)
    Port[ModemStatus] := $44 +  (* x16clock(40),1 stopbit(04)  *)
                         PTable[Ord(Parity)];   (*  Parity  *)
    Str(Baudrate,rate);
    Port[BaudRateReg] := Pos(rate,'  50   75  110  135  150  300  600' +
                    ' 1200 1800 2000 2400 3600 4800 7200 9600 19200') div 5 ;
    End ; (* SetModem *)

(* ------------------------------------------------------------------ *)
(*  DialModem - Check and waits for modem to be connected.            *)
(*              It waits for DTR and CTS signals to be detected.      *)
(*  Side Effect - global variable 'connected' is set true.            *)
(* ------------------------------------------------------------------ *)
   Procedure DialModem ;
   Var abyte,bbyte : byte ;
   Begin (* Dial Modem *)
    While ((Port[ModemStatus] and DCD) <> DCD) and DTRcheck  Do
         Begin (* Connect modem please *)
         writeln('  Please connect your modem.  Status= ',Port[ModemStatus]);
         delay (1000);
         DTRcheck := Not (keychar(abyte,bbyte) and (abyte=$20)) ;
         End ; (* Connect modem please *)
   connected := true ;
(* Writeln('  Assume Connection completed '); *)
   End ; (* Dial Modem *)

(* ------------------------------------------------------------------ *)
(* RecvChar - Receive a Character from the modem port.                *)
(*            TRUE - if there is a character from the modem and       *)
(*                   the character is returned in the parmeter.       *)
(*            FALSE - if no character found .                         *)
(*                                                                    *)
(* ------------------------------------------------------------------ *)
    Function RecvChar (var mchar : byte) : boolean ;
    Begin (* RecvChar *)
    if (Port[ModemStatus] and RxChar) = RxChar then
         begin (* get char from buffer *)
         mchar := Port[ModemData] and $7F ;
         RecvChar := true ;
         if logging then write(Logfile,chr(mchar));
         end   (* get char from buffer *)
                   else
         RecvChar := false ;
    End ; (* RecvChar *)

(* ------------------------------------------------------------------ *)
(* SendChar - Send a character thru the modem port.                   *)
(*           It waits for the previous character to be sent before    *)
(*           sending the current character.                           *)
(* ------------------------------------------------------------------ *)
    Procedure SendChar(char : byte ) ;
    Begin (* Send Char *)
    While  (Port[ModemStatus] and TxChar) <> TxChar do delay(1);
    Port[ModemData] := char ;
    End ;  (* Send Char *)

(* ------------------------------------------------------------------ *)
(* SendBreak- Send a break via the modem port .                       *)
(* ------------------------------------------------------------------ *)
    Procedure SendBreak ;
    Var Tbyte : byte ;
    Begin (* Send Break *)
    Port[ModemStatus] := $05 ;  (* Select Write Reg 5 - Xmit Options *)
    Port[ModemStatus] := $10 ;  (* Send BREAK *)
    Writeln(' *** BREAK *** ');
    Delay(200) ;
    Port[ModemStatus] := $05 ;  (* Select Write Reg 5 - Xmit Options *)
    Port[ModemStatus] := $AA ;  (* DTR(80),7-bits(20),Tx Enable(08) *)
                                    (* RTS(20) *)
    End ;  (* Send Break *)

(* ================================================================= *)
(*    End of MODEM routines for Kaypro II computers                  *)
(* ================================================================= *)

(* +FILE+ DEFWORDS.PASMSCPM *)
(* Global DefWord variables *)
Var
    DefFile : text ;
    NewDefs : boolean ;
    DefList : DefPointer ;

(* ================================================================== *)
(* AssignDefWord  - Assigns the Defined Word  into the DefList.       *)
(*                   This is a recursive procedure.                   *)
(* Side Affects : The boolean variable NewDefs is set true            *)
(* ================================================================== *)
Procedure AssignDefWord (var PT : DefPointer;
                          DWord:Wstring ; Dstring: comstring);
Var TempPt : DefPointer ;
Begin (* AssignDefWord Procedure *)
NewDefs := true ;
TempPt := PT;
If PT <> nil then
    With PT^ do
         If DefWord = Dword then         (* Found existing Word *)
             If length(Dstring) > 0 then
                  DefString := Dstring
                                    else
                  Begin (* Drop DefWord *)
                  PT := Link ;  (* Drop entry *)
                  Dispose(tempPT);
                  End   (* Drop DefWord *)

                            else        (* Look down the list *)
             AssignDefWord(Link,DWord,Dstring)

            else
    If length(Dstring) > 0 then
         Begin (* Add new entry *)
         New(PT);
         With PT^ do
              Begin (* Add DefWord to list *)
              Link := Nil ;
              DefWord := DWord ;
              DefString := Dstring ;
              End;
         End ; (* Add new entry *)
End ; (* AssignDefWord Procedure *)


(* ================================================================== *)
(* DisplayDefWords - display the Defined Words in the DefList.        *)
(*                   This is a recursive procedure.                   *)
(*                                                                    *)
(* ================================================================== *)
Procedure DisplayDefWords (PT : DefPointer);
Begin (* DisplayDefWords Procedure *)
If PT <> nil then
      With PT^ do
         Begin (* Display Word and definition *)
         Writeln(DefWord,' := ',DefString);
         DisplayDefWords(Link);
         End ;
End ; (* DisplayDefWords Procedure *)
(* ================================================================== *)
(* CheckDefWords - Checks  for   Defined Words in the DefList.        *)
(*                 If it is found it concationates the DefString      *)
(*                 to the Instring and reset the first token          *)
(*                   This is a recursive procedure.                   *)
(*                                                                    *)
(* ================================================================== *)
Procedure CheckDefWords (PT : DefPointer;
                             var Dword : Wstring ; var Instring: comstring);
Begin (* CheckDefWords Procedure *)
If PT <> nil then
    With PT^ do
         If Dword = DefWord then
              Begin (* Update string *)
              Instring := DefString + ' ' + Instring ;
              Dword := uppercase(GetToken(Instring));
              End
                           else
              CheckDefWords(Link,Dword,Instring)
End ; (* CheckDefWords Procedure *)

(* ================================================================== *)
(* WriteDefWord - writes  the Defined Words in the DefList to the    *)
(*                 DefFile.                                           *)
(*                                                                    *)
(* ================================================================== *)
Procedure WriteDefWord (PT : DefPointer);
Begin (* WriteDefWord Procedure *)
If PT <> nil then
      With PT^ do
         Begin (* Write word and definition *)
         Writeln(DefFile,DefWord,' ',DefString);
         WriteDefWord(Link);
         End ;
End ; (* WriteDefWord Procedure *)

(* ================================================================== *)
(* DEFINEWORD - This procedure processes the DEFINE command.          *)
(*              It searches the DefList for the WORD specified        *)
(*              If it is found it replaces the definition string      *)
(*              with the new definition. Otherwise it creates an      *)
(*              new entry in the DefList.                             *)
(* ================================================================== *)
Procedure DEFINEWORD (Var Instring: comstring);
Var
    DWord : string[10] ;

Begin (* DefineWord Procedure *)
If length(Instring) < 1 then
    If DefList = Nil then  Writeln(' No Defined Words ')
                     else  DisplayDefWords (DefList)
                        else
    Begin (* Assign Defined Word *)
    DWord :=   Uppercase(GetToken(Instring));
    While (instring[1] = ' ') and (length(instring)>0) do
          Delete(instring,1,1);    (* eliminate leading blanks *)
    AssignDefWord(DefList,DWord,Instring);
    Instring := '';
    End ; (* Assign Define Word *)
End;  (* DefineWord Procedure *)

(* ================================================================== *)
(* LoadDefWords  - Loads the Defined Words into the DefList from      *)
(*                 the file KERMIT.DEF.                               *)
(*                                                                    *)
(* ================================================================== *)
Procedure LoadDefWords ;
Var Instring,dummy : comstring ;
Begin (* LoadDefWord Procedure *)
If FirstFile('KERMIT.DEF',DUMMY) then
    Begin (* Read file *)
    Assign(DefFile,'KERMIT.DEF');
    Reset(DefFile);
    While not Eof(DefFile) do
         Begin (* load DefList *)
         Readln(DefFile,Instring);
         DefineWord(Instring);
         End ; (* load DefList *)
    End ; (* Read file *)
End ; (* LoadDefWord Procedure *)

(* ================================================================== *)
(* SaveDefWords  - Saves the Defined Words from the DefList into      *)
(*                 the file KERMIT.DEF.                               *)
(*                                                                    *)
(* ================================================================== *)
Procedure SaveDefWords ;
Var Instring : comstring ;
Begin (* SaveDefWord Procedure *)
Writeln('Saving  DEFINE words in file KERMIT.DEF');
Assign(DefFile,'KERMIT.DEF');
Rewrite(DefFile);
WriteDefWord(DefList);
Close(DefFile);
End ; (* SaveDefWord Procedure *)

(* +FILE+ READCHAR.PASMSCPM *)
(* ------------------------------------------------------------------ *)
(* ReadChar - Read a character from the modem.                        *)
(*           Waits for a character to appear on the modem.            *)
(*           It returns TRUE when the character is received and       *)
(*           the value of the char is return in the parameter.        *)
(*           It returns FALSE if the keyboard char is detected before *)
(*           a character is received or it times out.                 *)
(*   Side Effects : if the keys ^Z ^X ^C or ^E are pressed then       *)
(*           BREAKSTATE is set to BZ, BX, BC, or BE respectively.     *)
(*   Note : The ticker value may need to change if code is added to   *)
(*           to this procedure or RecvChar or KeyChar. It is also     *)
(*           machine dependent.                                       *)
(* ------------------------------------------------------------------ *)
    Function ReadChar(var char : byte): boolean;
    var waiting : boolean ;
        dummy : byte ;
        Ticker,Timer : integer ;
    Begin (* Read Char *)
    waiting := true ;
    timer := 0 ;
    ticker := 0 ;
    While waiting Do
         Begin (* Wait for a Character *)
         If RecvChar(char) then
              Begin (* got char *)
              ReadChar := true ;
              waiting := false ;
              End  (* got char *)
                           else
              If KeyChar(char,dummy) then
                   Begin (* key char *)
                   ReadChar := false ;
                   waiting := false ;
                   if char = $03 then BREAKSTATE := BC ;
                   if char = $05 then BREAKSTATE := BE ;
                   if char = $18 then BREAKSTATE := BX ;
                   if char = $1A then BREAKSTATE := BZ ;
                   End   (* key char *)
                                    else
                   Begin (* Check for timeout *)
                   if Timer < Timeout then (* increment timer *)
                        If ticker = 1072 then
                             Begin ticker := 0 ; Timer := Timer + 1; end
                                        else ticker := ticker + 1
                                      else  (* times up *)
                        Begin Waiting := false; ReadChar := False; End;
                  End;   (* Check for timeout *)
        End ; (* Wait for a Character *)
    End; (* Read Char *)

(* +FILE+ PACKET.PASMSCPM *)
(* ===============================================================  *)
(* SENDPACKET -This procedure sends the SendData packet .           *)
(*          1. The COUNT sent includes SEQ,PACKETTYPE,and CHECKSUM  *)
(*             i.e. it is 3 larger than the OutCount or             *)
(*               if CheckType = 2 or 3 then COUNT is 4 or 5 larger. *)
(*          2. The COUNT and SEQ and CHECKSUM values are offset by  *)
(*             32 decimal (20hex) to make it a printable ASCII char.*)
(*          3. The CHECKSUM are calculated on the ASCII value of    *)
(*             the printable characters.                            *)
(*                                                                  *)
(* Assumptions:                                                     *)
(*       The following Global variables must be correctly set       *)
(*       before calling this procedure .                            *)
(*       1. OutDataCount - an integer-byte count of data characters.*)
(*       2. OUTSEQ    - an integer-byte count of sequence number.   *)
(*       3. OUTPACKETTYPE - an character    of type .               *)
(*       4. SendData   - a character array of data to be sent.      *)
(* ===============================================================  *)
PROCEDURE SENDPACKET ;
 VAR
    I,SUM,Checkbytes : INTEGER ;
    achar            : byte ;
    SOHecho          : boolean ;

    BEGIN (* SENDPACKET procedure *)
(*  SOHecho := Not (LocalEcho or (Series1 and  WaitXon)) ;  *)
    SOHecho := Not (LocalEcho or Series1) ;
    achar := 0 ;
    If WaitXon then
         While achar <> XON do if Readchar(achar) then
                                                  else achar := xon ;
    WaitXon := XonXoff ;
    While RecvChar(achar) do ; (* throw away all previous incoming data *)
    Delay(50);
     SUM := 0 ;
     CRC := 0 ;
     Checkbytes := 1 ;
     If (OutPacketType = ord('S')) or (OutPacketType = ord('I')) or
         (InpacketType = ord('S')) or  (InpacketType = ord('I')) or
         (InpacketType = ord('R')) then  (* leave Checkbytes := 1 *)
                              else
         If Checktype = ord('2') then Checkbytes := 2  else
              If Checktype = ord('3') then Checkbytes := 3 ;

    SendChar(StartChar) ;                                       (* SOH   *)
    If SOHecho then      (* wait for SOH to be echoed back *)
        While achar <> StartChar do
          if Not Readchar(achar) then achar:=StartChar ;
    OutCount := OutDataCount + 2 + Checkbytes ;
    SendChar(OutCount + $20) ;                             (* COUNT *)
      SUM := SUM + OutCount + $20 ;
      CRCheck(OutCount+$20) ;
    SendChar(OUTSEQ+$20) ;                                 (* SEQ   *)
      SUM := SUM + OUTSEQ + $20;
      CRCheck(OUTSEQ+$20);
    SendChar(OUTPACKETTYPE) ;                              (* TYPE  *)
      SUM := SUM + ORD(OUTPACKETTYPE) ;
      CRCheck(Ord(OutpacketType));

    IF OutDataCount > 0 THEN
     FOR I := 1 TO OutDataCount DO
         BEGIN (* Send Data *)
         SendChar(SendData[I]) ;                           (* DATA   *)
         SUM := SUM + SendData[I] ;
         CRCheck(SendData[I]);
         END ; (* Send Data *)


    If Checkbytes = 1 then
         Begin (* one Checksum *)
         CHECKSUM := (SUM + (SUM AND $C0) DIV $40 ) AND $3F ;
         SendChar(CHECKSUM+$20);                           (* CHECKSUM *)
         End   (* one Checksum *)
                     else
    If Checkbytes = 2 then
         Begin (* two Checksum *)
         Checksum := (Sum div $40) and $3F ; (* Bit 11 - 6 *)
         SendChar(Checksum+$20) ;
         Checksum :=  Sum and $3F ;          (* Bit 5 - 0 *)
         SendChar(Checksum+$20) ;
         End  (* two Checksum *)
                      else
    If Checkbytes = 3 then
        Begin (* CRC *)
        SendChar((CRC shr 12 ) and $0F + $20) ;
        SendChar((CRC shr 6  ) and $3F + $20) ;
        SendChar((CRC        ) and $3F + $20) ;
        End ; (* CRC *)

    SendChar(EndChar);                                     (* Cr *)
    If NumPad > 0 then
        For I := 1 to NumPad do SendChar(PadChar);         (* Padding *)
    END ; (* SENDPACKET procedure  *)

(* ===============================================================  *)
(* RECVPACKET -This Function returns TRUE if it successfully        *)
(*             recieved a packet and FALSE if it had an error.      *)
(*  Side Effects:                                                   *)
(*       The following global variables will be set.                *)
(*       1. InDataCount - an integer value of the msg char count.   *)
(*       2. INSEQ - an integer value of the sequence count.         *)
(*       3. TYPE  - a  character of message type (Y,N,D,F,etc)      *)
(*       4. RecvData - an array of data bytes to be sent.           *)
(*                                                                  *)
(* ===============================================================  *)
FUNCTION  RECVPACKET : BOOLEAN ;
 VAR
    I,SUM,RESENDS      : INTEGER ;
    INCHAR,Checkbytes  : Byte ;
    dummy              : Boolean ;

LABEL EXIT ;

    BEGIN (* RECVPACKET procedure *)
    RECVPACKET := false ;    (* assume false until proven otherwise *)
    If GotSOH then begin Inchar := StartChar; GotSOH := false; end
                     else Inchar := $20 ;
    While Inchar <> StartChar Do
         If Readchar(Inchar) then                     (* SOH   *)
                             else goto exit ;
    SUM := 0 ;
    CRC := 0 ;

    If not ReadChar (InCount) then goto exit ;        (* COUNT *)
      SUM := SUM + InCount ;
      CRCheck(InCount) ;
      InCount := InCount - $20 ; (* To absolute value *)

    if not ReadChar (INSEQ) then  goto exit ;         (* SEQ   *)
      SUM := SUM + INSEQ ;
      CRCheck(INSEQ) ;
      INSEQ := INSEQ - $20 ;

    If not ReadChar (INPACKETTYPE ) then goto exit ;  (* TYPE  *)
      SUM := SUM + INPACKETTYPE ;
      CRCheck(InPacketType);
     Checkbytes := 1 ;
     If (OutPacketType = ord('S')) or
         (InpacketType = ord('S')) or
         (InpacketType = ord('R')) then  (* leave Checkbytes := 1 *)
                                   else
         If Checktype = ord('2') then Checkbytes := 2  else
              If Checktype = ord('3') then Checkbytes := 3 ;

    InDataCount := InCount - 2 - Checkbytes ;
    IF InDataCount >  0 THEN
     FOR I := 1 TO InDataCount  DO
         BEGIN (* Recv Data *)
         If ReadChar (RecvData[I]) then               (* DATA   *)
              Begin (* checksum and CRC *)
              SUM := SUM + RecvData[I] ;
              CRCheck(RecvData[I]);
              End  (* checksum and CRC *)
                                   else
              goto exit ;
         END ; (* Revc Data *)

    RECVPACKET := True ;    (* Assume Ok until check fails *)
    If Checkbytes = 1 then
         Begin (* one char Checksum *)
         CHECKSUM := (SUM + (SUM AND $C0) DIV $40 ) AND $3F ;
         If ReadChar (INCHAR) then
              IF INCHAR <> CHECKSUM+$20  THEN  RECVPACKET := FALSE ;
         End  (* one char Checksum *)
                      else
    If Checkbytes = 2 then
         Begin (* two char Checksum *)
         Checksum := (Sum div $40) and $3F ;
         If ReadChar(Inchar) then
              If Inchar <> Checksum+$20 then RECVPACKET := false ;
         Checksum := Sum and $3F ;
         If ReadChar(Inchar) then
              If Inchar <> Checksum+$20 then RECVPACKET := false ;
         End   (* two char Checksum *)
                      else
    If Checkbytes = 3 then
         Begin (* CRC char Checksum *)
         Checksum := (CRC shr 12) and $0F ;
         If ReadChar(Inchar) then
          (*  If Inchar <> Checksum+$20 then
                   Writeln('CRC1 ',Inchar,' ',checksum+$20);    *)
              If Inchar <> Checksum+$20 then RECVPACKET := false ;
         Checksum := (CRC shr 6 ) and  $3F ;
         If ReadChar(Inchar) then
          (*  If Inchar <> Checksum+$20 then
               Writeln('CRC2 ',Inchar,' ',checksum+$20); *)
              If Inchar <> Checksum+$20 then RECVPACKET := false ;
         Checksum := (CRC       ) and  $3F ;
         If ReadChar(Inchar) then
         (*   If Inchar <> Checksum+$20 then
                   Writeln('CRC3 ',Inchar,' ',checksum+$20); *)
              If Inchar <> Checksum+$20 then RECVPACKET := false ;
         End;  (* CRC char Checksum *)

Exit:
    END ; (* RECVPACKET procedure  *)

(* ===============================================================  *)
(* RESENDIT -  This procedure RESENDS the packet if it gets a nak   *)
(*             It calls itself recursively upto the number of times *)
(*             specified in the intial parameter list.              *)
(* Side Effects - If it fails then the STATE in the message is set  *)
(*                to 'A' which means ABORT .                        *)
(*              - Global variable RetryCount is incremented         *)
(* ===============================================================  *)
PROCEDURE RESENDIT ( RETRIES : INTEGER ) ;

    BEGIN (* RESENDIT procedure *)
    RetryCount := RetryCount + 1 ;
    IF RETRIES > 0 THEN
         BEGIN (* Try again *)
         SENDPACKET ;
         IF RECVPACKET THEN
              IF INPACKETTYPE = ord('Y') THEN
                                         ELSE
              IF INPACKETTYPE = ord('N') THEN RESENDIT(RETRIES-1)
                                         ELSE STATE := A
                       ELSE STATE := A  ;
         END   (* Try again *)
                   ELSE STATE := A ;  (* Retries failed - ABORT *)
    END ; (* RESENDIT procedure  *)

(* ------------------------------------------------------------ *)
(*  SendPacketType - Procedure  will send a packet of the       *)
(*            type specified in  the Character  parameter.      *)
(*            i.e. SendPacketType('Y')  an ACK packet           *)
(*                 SendPacketType('N')  an NAK packet           *)
(* ------------------------------------------------------------ *)
     PROCEDURE SendPacketType  (PacketType : char);
         BEGIN (* SEND ACK or NAK or B or Z *)
         OutDataCount := 0 ;
         IF PacketType <> 'N' THEN  OUTSEQ := OUTSEQ + 1 ;
         IF OUTSEQ >= 64 THEN OUTSEQ := 0;
         OUTPACKETTYPE := Ord(PacketType) ;
         SENDPACKET ;
         END ; (* SEND ACK or NAK or B or Z *)
(* ------------------------------------------------------------ *)
    PROCEDURE PutInitPacket  ;
         Begin (* Put Parameters into Init Packet *)
         OutDataCount := 9 ;
         OUTSEQ := 0 ;
         (* The values  are tranformed by adding hex 20 to    *)
         (* the true value, making the value a printable char *)
         SendData[1] := PacketSize+ $20 ;  (* Buffsize       *)
         SendData[2] := Timeout   + $20 ;  (* Time out sec   *)
         SendData[3] := NumPad    + $20 ;  (* Num padchars   *)
         SendData[4] := PadChar   + $20 ;  (* Pad char       *)
         SendData[5] := EndChar   + $20 ;  (* EOL char       *)
         SendData[6] := CntrlQuote ;      (* Quote character  *)
         SendData[7] := Bit8Quote ;       (* Quote character  *)
         SendData[8] := CheckType ;       (* Check Type       *)
         SendData[9] := RepChar   ;       (* Repeat Character *)
         IF Bit8Quote = $00 then OutDataCount := 6  (* Don't send bit8_quote *)
                            else
              If CheckType = $00 then OutDataCount := 7
                                 else
                   If RepChar = $00 then OutDataCount := 8 ;
         End ; (* Put Parameters into Init Packet *)
(* ------------------------------------------------------------ *)
    PROCEDURE GetInitPacket ;
         Begin  (* Get init parameters *)
         IF InDataCount >= 1 then   PacketSize := RecvData[1]-$20 ;
         IF InDataCount >= 2 then   TimeOut    := RecvData[2]-$20 ;
         IF InDataCount >= 3 then   NumPad     := RecvData[3]-$20 ;
         IF InDataCount >= 4 then   PadChar    := RecvData[4]-$20 ;
         IF InDataCount >= 5 then   EndChar    := RecvData[5]-$20 ;
         IF InDataCount >= 6 then   CntrlQuote := RecvData[6] ;
         IF InDataCount >= 7 then
              Begin (* Validate bit8Quote *)
              Bit8Quote  := RecvData[7] ;
              If RecvData[7] = ord('Y') then Bit8Quote := ord('&') ;
              If Not (chr(Bit8Quote) in ['!'..'?','`'..'~'])
                   then Bit8Quote := 0 ;
              End  (* Validate bit8Quote *)
                             else   Bit8Quote  := $00 ;
         IF (InDataCount >= 8) and (chr(RecvData[8]) in ['1','2','3'] )
              then   CheckType  := RecvData[8]
              else   CheckType  := ord('1') ;
         IF InDataCount >= 9 then
             If chr(RecvData[9]) in ['!'..'?','`'..'~']
                   then RepChar := RecvData[9]
                   else RepChar := $00
                             else   RepChar    := $00 ;
         End ;  (* Get init parameters *)
(* ------------------------------------------------------------ *)

(* +FILE+ SENDFILE.PASMS *)
(* **************************************************************** *)
(* SENDFILE  - This routine handles the sending of a file from    * *)
(*             the micro computer.                                * *)
(*                                                                * *)
(* **************************************************************** *)
 PROCEDURE SENDFILE (var InParms : ComString);

 VAR
    MyFiles,FileName,AsFileNames,AsFileName,Atoken   : Comstring ;
    SENDING, GETREPLY, LastFile, rawfile    : Boolean ;
    abyte, Kchar,Kbchar : byte ;
    ErrorMsg            : String[80];
    PacketCount,i,ix       : Integer ;
    FILETOSEND          : File of byte ;

Label Subdir,GetAsName,GetNextFile,Exit ;


    (* --------------------------------------------------- *)
    (* SENDRAW - This routine send the file in unpacket    *)
    (*           mode, Simply read and send.               *)
    (* --------------------------------------------------- *)
    Procedure SENDRAW ;
    Begin (* SendRaw Procedure *)
    Sending := true ;
    While Sending Do
         Begin (* Send a file *)
         ClrScr; Writeln('       Sending File >>>>>>> ',Filename,' <<<<<<< ');
         Assign(FileToSend,Prefixof(Myfiles)+FileName);
         RESET(FileToSend);
         While not EOF(FileToSend) do
              Begin (* Send data *)
              Read(FileToSend,abyte);
              SendChar(abyte);
              If LocalEcho then Write(chr(abyte))
                           else If Readchar(abyte) then Write(chr(abyte));
              If XonXoff and (abyte = $0D) then  (* wait for Xon *)
                  While abyte<>XON do
                        If Readchar(abyte) then
                                           else abyte := xon ;
              End ; (* Send data *)
         CLOSE(FileToSend);
         Sending := Nextfile(Myfiles,Filename);
         End ; (* Send a file *)
    Writeln(' ');
    End ; (* SendRaw Procedure *)

(* **************************************************************** *)

    BEGIN (* SENDFILE procedure *)
    rawfile := false ;
    RetryCount := 0 ;
  (* Check the file to be sent here *)
    If length(InParms) < 1 then
         Begin (* Get name of file to send *)
         Write  (' Enter name of file to be sent >');
         Readln(InParms);
         End;
    MyFiles := '                                     ';
    MyFiles := UpperCase(GetToken(InParms));
    AsFileNames := MyFiles ;
    Atoken := UpperCase(GetToken(InParms));
    If Atoken = 'AS' then
        If length(InParms)<1  then AsFileNames := MyFiles
                              else AsFileNames := UpperCase(GetToken(InParms))
                     else
        If Atoken = 'RAW' then  rawfile := true
                          else  InParms := Atoken + InParms ;
subdir:
 ix := Pos('\',AsFilenames) ;
 If ix > 1 then delete(AsFilenames,1,ix) ;  (* Eliminate sub-dir  prefixs *)
 if ix > 1 then goto subdir ;

    If FirstFile(Myfiles,Filename) then
                                   else
         begin (* No file found *)
         Writeln (' File "',MyFiles,'" not found.');
         Goto Exit ;
         end ; (* No file found *)
    AsFilename := 'Blank' ;

    If rawfile then
        begin SendRaw ; goto exit ; end ;

GetAsName:
writeln('Filename is =',Filename);
  If NewAsFile(Myfiles,Filename,AsFileNames,AsFileName) then
                                                        else
                 If NextFile(Myfiles,Filename) then goto GetAsName
                                               else
         begin (* No file found *)
         Writeln (' File "',MyFiles,'" not found on disk.');
         Goto Exit ;
         end ; (* No file found *)

    STATE := S ;
    BreakState := NoBreak ;
    GETREPLY := FALSE ;
    LastFile := false ;
    SENDING := TRUE ;
    ClrScr;
    GotoXY(10,4); Write(' Number of Packets Sent = ');
    GotoXY(10,5); Write(' Number of Retries      = ');
    PacketCount := 0 ;
    WHILE SENDING DO
       BEGIN (* Send files *)
       IF GETREPLY THEN
           IF RECVPACKET THEN
              IF InPacketType = Ord('Y') THEN
                                    ELSE
              IF InPacketType = Ord('N') THEN RESENDIT(10)
                                    ELSE
              IF InPacketType = Ord('R') THEN STATE := S
                                    ELSE STATE := A
                       ELSE  RESENDIT(10) ;
         GotoXY(36,5); Write (RetryCount);
         GETREPLY := TRUE ;
         If (InPacketType = Ord('Y')) and (InDataCount > 1) then
              If RecvData[1] = Ord('X') then  STATE := SZ  else
              If RecvData[1] = Ord('Z') then
                   Begin STATE := SZ ; LastFile := true ;  End ;
         If STATE = SD then
          Case Breakstate of
            NoBreak :  ;
            BC : Sending := False ;
            BE : STATE := A ;
            BX : STATE := SZ ;
            BZ : Begin STATE := SZ ; LastFile := true ;  End ;
         End ; (* Case Breakstate *)

            CASE STATE OF
    S :  BEGIN (* Send INIT packit *)
         OutPacketType := Ord('S') ;
         PutInitPacket ;
         SENDPACKET ;
         STATE := SF ;
         END ; (* Send INIT packit *)

    SF:  BEGIN (* Send file header *)
(*       If InDataCount = 0 then
              Begin    Not a Init packet, Resend our Init Packet
              GetReply := False;
              State := S ;
              End
                         Else      *)
              Begin  (* Got Init packet, Get init parameters *)
              If InDataCount > 1 then GetInitPacket ;
              OUTSEQ := OUTSEQ + 1 ;
              IF OUTSEQ >= 64 THEN OUTSEQ := 0 ;
              OutPacketType := Ord('F') ;
              OutDataCount := LENGTH(AsFileName);
              For i := 1 to OutDataCount do SendData[i] := Ord(AsFilename[i]) ;
              GotoXY(10,2);
              Write(' Sending file ',Filename,' as ',AsFileName,
                     '                                   ');
              Assign(FileToSend,Prefixof(MyFiles)+FileName);
              RESET(FILETOSEND);
              STATE := SD ;
              SENDPACKET ;
              End  (* Got Init packet, Get init parameters *)
         END ; (* Send file header *)

    SD:  BEGIN (* Send data *)
         OutDataCount := 0 ;
         OUTSEQ   := OUTSEQ + 1 ;
         IF OUTSEQ >= 64 THEN OUTSEQ := 0 ;
         OutPacketType := Ord('D') ;
         WHILE (OutDataCount<PacketSize-3-4) AND (NOT EOF(FILETOSEND)) DO
              BEGIN (* Read a char *)
              OutDataCount := OutDataCount + 1 ;
              READ(FILETOSEND,abyte);
              SendData[OutDataCount] := abyte;
              IF SendData[OutDataCount] >= $80 THEN
                   IF Bit8Quote = $00 THEN (* No bit8 quoting *)
                        (* Just drop the 8th bit  *)
                        SendData[OutDataCount] := SendData[OutDataCount]-$80
                                       ELSE
                        BEGIN (* BIT8 QUOTING *)
                        SendData[OutDataCount+1] := SendData[OutDataCount]-$80;
                        SendData[OutDataCount] := Bit8Quote ;
                        OutDataCount := OutDataCount + 1 ;
                        END ; (* BIT8 QUOTING *)
              IF SendData[OutDataCount] < $20   THEN
                   BEGIN (* CONTROL QUOTING *)
                   SendData[OutDataCount+1] := SendData[OutDataCount] + $40 ;
                   SendData[OutDataCount] := CntrlQuote ;
                   OutDataCount := OutDataCount + 1 ;
                   END ; (* CONTROL QUOTING *)
              IF SendData[OutDataCount] = $7F THEN
                   BEGIN (* DEL QUOTING *)
                   SendData[OutDataCount+1] := $3F ;
                   SendData[OutDataCount] := CntrlQuote ;
                   OutDataCount := OutDataCount + 1 ;
                   END ; (* DEL QUOTING *)
              IF (SendData[OutDataCount] = CntrlQuote) OR
                         (SendData[OutDataCount] = Bit8Quote) THEN
                   BEGIN (* Quote the  quote *)
                   SendData[OutDataCount+1] := SendData[OutDataCount] ;
                   SendData[OutDataCount] := CntrlQuote ;
                   OutDataCount := OutDataCount + 1 ;
                   END ; (* Quote the  quote *)
              END ; (* Read a char *)

         PacketCount := PacketCount + 1 ;
         GotoXY(36,4) ;  WRITE (PacketCount);
         IF EOF(FILETOSEND) THEN STATE := SZ ;
         SENDPACKET ;
         END ; (* Send data *)

    SZ:  BEGIN (* End of File *)
     (*  WRITELN ('end of file');  *)
         Close(FILETOSEND);
         GotoXY(10,6) ;
         If BreakState = NoBreak then
           WRITELN ('File ',Filename,' has been sent as ',AsFileName,
                   '                              ')
                                  else
           Writeln('File ',Filename,' Partially sent as ',AsFileName,
                   '                              ');
         If Lastfile then STATE := SB
                     else
GetNextFile:
         (* Get next file  *)
         If Nextfile(Myfiles,Filename)  then
            If NewAsFile(Myfiles,Filename,AsFilenames,AsFilename)
                     then  STATE := SF
                     else  goto GetNextFile
                                        else STATE := SB ;
        If Breakstate = BX then Breakstate := NoBreak ;
         SendPacketType('Z') ;
         END ; (* End of File *)

    SB:  BEGIN (* Last file sent *)
  (*     WRITELN ('SENT last file completed');  *)
         SendPacketType('B') ;
         STATE := C ;
         END ; (* Last file sent *)

     C:  BEGIN (* Completed Sending *)
         GotoXY(10,7) ;
         If BreakState = NoBreak then
              WRITELN ('Sending FILEs completed OK ')
                                 else
              WRITELN ('Sending FILEs terminated due to manual Interruption ');
         SENDING := FALSE ;
         END ; (* Completed Sending *)

     A:  BEGIN (* Abort Sending *)
         Close(FILETOSEND);
         GotoXY(10,7) ;
         WRITELN ('SENDing files ABORTED');
         ABORT := BADSF ;
         SENDING := FALSE ;
               (* SEND ERROR packet *)
              OutDataCount := 15 ;
              OUTSEQ   := 0 ;
              ErrorMsg := 'Send file abort' ;
              for i := 1 to OutDataCount do SendData[i] := Ord(ErrorMsg[i]) ;
              OutPacketType := Ord('E');
              SENDPACKET ;

         END ; (* Abort Sending *)
              END ; (* CASE of STATE *)
       END ; (* Send files *)
Exit:
    END ; (* SENDFILE procedure *)

(* +FILE+ SENDFILE.PASCPM *)
(* **************************************************************** *)
(* SENDFILE  - This routine handles the sending of a file from    * *)
(*             the micro computer.                                * *)
(*                                                                * *)
(* **************************************************************** *)
const
    MaxBlocks = 10 ;
    MaxBuffer = 2560 ;
var
    FileToSend : file;
    NumRec,Records,Bufferindex,lastchar : integer ;
    Buffer : Array  [1..MaxBuffer] of byte ;
    Endfile,Truncate : boolean ;
    abyte : byte ;


Procedure ResetFileToSend ;
    Begin (* ResetFile Procedure *)
    Reset (FiletoSend);
    Records := Filesize(FileToSend);
    EndFile := false ;
    BufferIndex := 0 ; lastchar := 0 ;
    End ; (* ResetFile Procedure *)

Procedure ReadFileToSend (var abyte : byte );
var i : integer ;
    Begin (* ReadFile Procedure *)
    Bufferindex := Bufferindex + 1 ;
    If Bufferindex > Lastchar then
      If Records > 0 then
         Begin (* get next block *)
         If Records > MaxBlocks then  NumRec := MaxBlocks
                                else  NumRec := Records ;
         BlockRead(FiletoSend,Buffer,Numrec);
         Records := Records - NumRec ;
         Bufferindex := 1 ;  Lastchar := NumRec * 128 ;
         abyte := Buffer[Bufferindex] ;
         End   (* get next block *)
                     else
         EndFile := true
                              else

      abyte := Buffer[Bufferindex] ;
    If (abyte=$1A) and (Records=0) and ((lastchar-bufferindex<128)) then
         Begin (* probable eof *)
         EndFile := true ;
         For i := bufferindex +1 to lastchar-1 do
             if Buffer[i] <> Buffer[i+1] then EndFile :=  false ;
         if truncate then EndFile := true ;
         End ; (* probable eof *)
    End ; (* ReadFile Procedure *)


 PROCEDURE SENDFILE (var InParms : ComString);

 VAR
    MyFiles,FileName,AsFileNames,AsFileName,Atoken   : Comstring ;
    SENDING, GETREPLY, LastFile, rawfile    : Boolean ;
    abyte, Kchar,Kbchar : byte ;
    achar : char ;
    ErrorMsg            : String[80];
    PacketCount,i       : Integer ;

Label GetAsName,GetNextFile,Exit ;


    (* --------------------------------------------------- *)
    (* SENDRAW - This routine send the file in unpacket    *)
    (*           mode, Simply read and send.               *)
    (* --------------------------------------------------- *)
    Procedure SENDRAW ;
    Begin (* SendRaw Procedure *)
    Sending := true ;
    While Sending Do
         Begin (* Send a file *)
         ClrScr; Writeln('       Sending File >>>>>>> ',Filename,' <<<<<<< ');
         Assign(FileToSend,FileName);
         RESETFileToSend;
         While not EndFile do
              Begin (* Send data *)
              ReadFileToSend(Abyte);
              SendChar(abyte);
              If LocalEcho then Write(chr(abyte))
                           else If Readchar(abyte) then Write(chr(abyte));
              If XonXoff and (abyte = $0D) then  (* wait for Xon *)
                  While abyte<>XON do
                        If Readchar(abyte) then
                                           else abyte := xon ;
              End ; (* Send data *)
         CLOSE(FileToSend);
         Sending := Nextfile(Myfiles,Filename);
         End ; (* Send a file *)
    Writeln(' ');
    End ; (* SendRaw Procedure *)

(* **************************************************************** *)

    BEGIN (* SENDFILE procedure *)
    rawfile := false ;
    RetryCount := 0 ;
  (* Check the file to be sent here *)
    If length(InParms) < 1 then
         Begin (* Get name of file to send *)
         Write  (' Enter name of file to be sent >');
         Readln(InParms);
         End;
    MyFiles := '                                     ';
    MyFiles := UpperCase(GetToken(InParms));
    AsFileNames := MyFiles ;
    Atoken := UpperCase(GetToken(InParms));
    If Atoken = 'AS' then
        If length(InParms)<1  then AsFileNames := MyFiles
                              else AsFileNames := UpperCase(GetToken(InParms))
                     else
        If Atoken = 'RAW' then  rawfile := true
                          else  InParms := Atoken + InParms ;
    If FirstFile(Myfiles,Filename) then
                                   else
         begin (* No file found *)
         Writeln (' File "',MyFiles,'" not found.');
         Goto Exit ;
         end ; (* No file found *)
    AsFilename := 'Blank' ;

    If rawfile then
        begin SendRaw ; goto exit ; end ;

GetAsName:
  If NewAsFile(Myfiles,Filename,AsFileNames,AsFileName) then
                                                        else
                 If NextFile(Myfiles,Filename) then goto GetAsName
                                               else
         begin (* No file found *)
         Writeln (' File "',MyFiles,'" not found on disk.');
         Goto Exit ;
         end ; (* No file found *)

    STATE := S ;
    BreakState := NoBreak ;
    GETREPLY := FALSE ;
    LastFile := false ;
    SENDING := TRUE ;
    ClrScr;
    GotoXY(10,4); Write(' Number of Packets Sent = ');
    GotoXY(10,5); Write(' Number of Retries      = ');
    PacketCount := 0 ;
    WHILE SENDING DO
       BEGIN (* Send files *)
       IF GETREPLY THEN
           IF RECVPACKET THEN
              IF InPacketType = Ord('Y') THEN
                                    ELSE
              IF InPacketType = Ord('N') THEN RESENDIT(10)
                                    ELSE
              IF InPacketType = Ord('R') THEN STATE := S
                                    ELSE STATE := A
                       ELSE  RESENDIT(10) ;
         GotoXY(36,5); Write (RetryCount);
         GETREPLY := TRUE ;
         If (InPacketType = Ord('Y')) and (InDataCount > 1) then
              If RecvData[1] = Ord('X') then  STATE := SZ  else
              If RecvData[1] = Ord('Z') then
                   Begin STATE := SZ ; LastFile := true ;  End ;
         If STATE = SD then
          Case Breakstate of
            NoBreak :  ;
            BC : Sending := False ;
            BE : STATE := A ;
            BX : STATE := SZ ;
            BZ : Begin STATE := SZ ; LastFile := true ;  End ;
         End ; (* Case Breakstate *)

            CASE STATE OF
    S :  BEGIN (* Send INIT packit *)
         OutPacketType := Ord('S') ;
         PutInitPacket ;
         SENDPACKET ;
         STATE := SF ;
         END ; (* Send INIT packit *)

    SF:  BEGIN (* Send file header *)
         If InDataCount = 0 then
              Begin    (* Not a Init packet, Resend our Init Packet *)
              GetReply := False;
              State := S ;
              End
                         Else
              Begin  (* Got Init packet, Get init parameters *)
              GetInitPacket ;
              OUTSEQ := OUTSEQ + 1 ;
              IF OUTSEQ >= 64 THEN OUTSEQ := 0 ;
              OutPacketType := Ord('F') ;
              OutDataCount := LENGTH(AsFileName);
              For i := 1 to OutDataCount do SendData[i] := Ord(AsFilename[i]) ;
              GotoXY(10,2);
              Write(' Sending file ',Filename,' as ',AsFileName,
                     '                                   ');
              Assign(FileToSend,FileName);
              RESETFILETOSEND;
              STATE := SD ;
              SENDPACKET ;
              End  (* Got Init packet, Get init parameters *)
         END ; (* Send file header *)

    SD:  BEGIN (* Send data *)
         OutDataCount := 0 ;
         OUTSEQ   := OUTSEQ + 1 ;
         IF OUTSEQ >= 64 THEN OUTSEQ := 0 ;
         OutPacketType := Ord('D') ;
         WHILE (OutDataCount<PacketSize-3-4) AND (NOT EndFile)  DO
              BEGIN (* Read a char *)
              OutDataCount := OutDataCount + 1 ;
              ReadFileToSend(Abyte);
              SendData[OutDataCount] := abyte;
              IF SendData[OutDataCount] >= $80 THEN
                   IF Bit8Quote = $00 THEN (* No bit8 quoting *)
                        (* Just drop the 8th bit  *)
                        SendData[OutDataCount] := SendData[OutDataCount] -$80
                                       ELSE
                        BEGIN (* BIT8 QUOTING *)
                        SendData[OutDataCount+1] := SendData[OutDataCount]-$80;
                        SendData[OutDataCount] := Bit8Quote ;
                        OutDataCount := OutDataCount + 1 ;
                        END ; (* BIT8 QUOTING *)
              IF SendData[OutDataCount] < $20   THEN
                   BEGIN (* CONTROL QUOTING *)
                   SendData[OutDataCount+1] := SendData[OutDataCount] +$40;
                   SendData[OutDataCount] := CntrlQuote ;
                   OutDataCount := OutDataCount + 1 ;
                   END ; (* CONTROL QUOTING *)
              IF SendData[OutDataCount] = $7F THEN
                   BEGIN (* DEL QUOTING *)
                   SendData[OutDataCount+1] := $3F ;
                   SendData[OutDataCount] := CntrlQuote ;
                   OutDataCount := OutDataCount + 1 ;
                   END ; (* DEL QUOTING *)
              IF (SendData[OutDataCount] = CntrlQuote) OR
                         (SendData[OutDataCount] = Bit8Quote) THEN
                   BEGIN (* Quote the  quote *)
                   SendData[OutDataCount+1] := SendData[OutDataCount] ;
                   SendData[OutDataCount] := CntrlQuote ;
                   OutDataCount := OutDataCount + 1 ;
                   END ; (* Quote the  quote *)
              END ; (* Read a char *)

         PacketCount := PacketCount + 1 ;
         GotoXY(36,4) ;  WRITE (PacketCount);
         IF EndFile THEN STATE := SZ ;
         SENDPACKET ;
         END ; (* Send data *)

    SZ:  BEGIN (* End of File *)
     (*  WRITELN ('end of file');  *)
         Close(FILETOSEND);
         GotoXY(10,6) ;
         If BreakState = NoBreak then
           WRITELN ('File ',Filename,' has been sent as ',AsFileName,
                   '                              ')
                                  else
           Writeln('File ',Filename,' Partially sent as ',AsFileName,
                   '                              ');
         If Lastfile then STATE := SB
                     else
GetNextFile:
         (* Get next file  *)
         If Nextfile(Myfiles,Filename)  then
            If NewAsFile(Myfiles,Filename,AsFilenames,AsFilename)
                     then  STATE := SF
                     else  goto GetNextFile
                                        else STATE := SB ;
        If Breakstate = BX then Breakstate := NoBreak ;
         SendPacketType('Z') ;
         END ; (* End of File *)

    SB:  BEGIN (* Last file sent *)
  (*     WRITELN ('SENT last file completed');  *)
         SendPacketType('B') ;
         STATE := C ;
         END ; (* Last file sent *)

     C:  BEGIN (* Completed Sending *)
         GotoXY(10,7) ;
         If BreakState = NoBreak then
              WRITELN ('Sending FILEs completed OK ')
                                 else
              WRITELN ('Sending FILEs terminated due to manual Interruption ');
         SENDING := FALSE ;
         END ; (* Completed Sending *)

     A:  BEGIN (* Abort Sending *)
         Close(FILETOSEND);
         GotoXY(10,7) ;
         WRITELN ('SENDing files ABORTED');
         ABORT := BADSF ;
         SENDING := FALSE ;
               (* SEND ERROR packet *)
              OutDataCount := 15 ;
              OUTSEQ   := 0 ;
              ErrorMsg := 'Send file abort' ;
              for i := 1 to OutDataCount do SendData[i] := Ord(ErrorMsg[i]) ;
              OutPacketType := Ord('E');
              SENDPACKET ;

         END ; (* Abort Sending *)
              END ; (* CASE of STATE *)
       END ; (* Send files *)
Exit:
    END ; (* SENDFILE procedure *)

(* +FILE+ RECVFILE.PASMSCPM *)
(* ------------------------------------------------------------ *)
(*  BreakACK - Procedure   will send a ACK  plus a break char   *)
(*              X or Z .                                        *)
(* ------------------------------------------------------------ *)
     PROCEDURE BreakACK (Achar : Char);
         BEGIN (* SEND ACK or NAK *)
         OutDataCount := 1 ;
         OUTSEQ   := OUTSEQ + 1 ;
         IF OUTSEQ >= 64 then OUTSEQ := 0;
         OUTPACKETTYPE := ord('Y');
         SendData[1] := Ord(Achar);
         SENDPACKET ;
         END ; (* SEND ACK or NAK *)
(* ------------------------------------------------------------ *)
(*  RenameDup- Procedure   will check to see if a file is       *)
(*              already present if it is it returns a new       *)
(*              name modified with &.                           *)
(*      Note : this procedure is maybe called recursively.      *)
(* ------------------------------------------------------------ *)
     PROCEDURE RenameDup(var MyFile:comstring);
         BEGIN (* RenameDup  *)
         If Firstfile(MyFile,MyFile) then
              Begin (* change name of file *)
              Insert ('&',Myfile,Pos('.',Myfile));
              if Pos('.',Myfile) > 9 then
                   Delete(Myfile,Pos('&',Myfile)-1,1);
              RenameDup(Myfile);
              End ; (* change name of file *)
         END ; (* RenameDup  *)

(* **************************************************************** *)
(* RECVFILE  - This routine handles the Receiving of a file from    *)
(*             the Main frame computer.                             *)
(*                                                                  *)
(* **************************************************************** *)
 PROCEDURE RECVFILE (var InParms : comstring);
VAR
    Bit8                      : BYTE ;
    Lastseqnum                : INTEGER ;
    Receiving,ReplaceFile     : BOOLEAN ;
    Retries,PacketCount,
    CharCount,i,j             : INTEGER ;
    Filenames,FileName,
    Myfiles,Myfile,Astring    : ComString ;
    ErrorMsg                  : ComString ;
    FileComing                : TEXT ;

Label Gotinit;

    (* ------------------------------------------------------------ *)
    (*  SENDNAK - Procedure of RECVFILE, will check the number of   *)
    (*            RETRIES , if it is greater than 0 it will send a  *)
    (*            call SendPacketType('N') which send a NAK packet  *)
    (*            and decrements the RETRIES by 1.                  *)
    (*  Side Effect - RETRIES is decremented by 1.                  *)
    (*                STATE is set to A if no more retries.         *)
    (*              - RetryCount is incremented                     *)
    (* ------------------------------------------------------------ *)
     PROCEDURE SENDNAK ;
         BEGIN (* SEND  NAK *)
         RetryCount := RetryCount + 1;
         IF RETRIES > 0 then
              BEGIN  (* Ask for a retransmission *)
              SendPacketType('N');
              RETRIES := RETRIES - 1 ;
              END    (* Ask for a retransmission *)
                        else
              STATE := A ;
         END ; (* SEND  NAK *)



    BEGIN (* ------- RECVFILE procedure ------- *)
    WRITELN (' RECEIVE file command . ',InParms);
    Packetcount := 0 ;
    ReplaceFile := false ;
    Lastseqnum := 0 ;

    (* Scan Parameter string *)
    FileNames := GETTOKEN(InParms);
    MyFiles := FileNames ;
    Astring := Uppercase(GetToken(Inparms));
    If Astring = 'AS' then
         if length(InParms) > 0 then
              Begin (* get AS name *)
              MyFiles := GetToken(Inparms);
              Astring := Uppercase(GetToken(Inparms));
              If Pos(Astring,' REPLACE') = 2 then ReplaceFile := True
                                             else InParms := Astring + InParms;
              End   (* get AS name *)
                                else MyFiles := FileNames
                      else
         If Pos(Astring,' REPLACE') = 2 then ReplaceFile := True
                                        else InParms := Astring + InParms ;

    If FileNames <> '' then
         Begin (* Send a R type packet requesting the file *)
         OutDataCount := length(Filenames);
         OutSeq := 0 ;
         OutPacketType := ord('R');
         For i := 1 to length(Filenames) do
              SendData[i] := Ord(FileNames[i]) ;
         WaitXon := false ;
         SendPacket ;
         End   (* Send a R type packet requesting the file *)
                      else
         WaitXon := XonXoff ;
    STATE := R ;
    RECEIVING := TRUE ;
    BreakState := NoBreak ;
    RETRIES := 10 ;       (* Up to 10 retries allowed. *)
    RetryCount := 0 ;
    clrscr ;
    GotoXY(10,4) ;
    Write('Number of Data Packets Received = ');
    GotoXY(10,5) ;
    Write('Number of Nak  responses sent   = ');
    WHILE RECEIVING DO  CASE STATE OF

    (* R ------ Initial receive State ------- *)
    (* Valid received msg type  : S           *)
    R : BEGIN (* Initial Receive State  *)
        If InPacketType =Ord('S')  then goto Gotinit;
        IF (NOT RECVPACKET) OR (INPACKETTYPE=Ord('N')) then  SENDNAK
                                                       else
Gotinit:
        (* Get a packet *)
        IF INPACKETTYPE = Ord('S') then
              BEGIN (* Got INIT packet *)
              GetInitPacket ;  (* Get Init parameters *)
              (* Reply with ACK and init parameters *)
              OutPacketType := Ord('Y');
              PutInitPacket ;
              SENDPACKET ;
              STATE := RF ;
              END   (* Got  INIT  packet *)
                              else
              BEGIN (* Not init packet *)
              STATE := A ;   (* ABORT if not INIT packet *)
              ABORT := NOT_S ;
              END ; (* Not init packet *)
        END ; (* Initial Receive State  *)


    (* RF ----- Receive Filename State ------- *)
    (* Valid received msg type  : S,Z,F,B     *)
    RF: IF (NOT RECVPACKET) OR (INPACKETTYPE=Ord('N')) then  SENDNAK
                                                       else
        (* Get a packet *)
        IF INPACKETTYPE = Ord('S') then STATE:=R             else
        IF INPACKETTYPE = Ord('Z') then SendPacketType('N')  else
        IF INPACKETTYPE = Ord('B') then STATE:=C             else
        IF INPACKETTYPE = Ord('F') then
              BEGIN (* Got file header *)
              For i := 1 to InDataCount do
                   FileName[i] := Chr(RecvData[i]) ;
              FileName[0] := Chr(InDataCount) ;
              If Filenames = '' then
                  Myfile := Filename
                                 else
                  If NewAsfile(Filenames,Filename,MyFiles,Myfile) then;
              GotoXY(10,2);
              If ReplaceFile then (* write over old file *)
                             else ReNameDup(Myfile);
              Writeln('Receiving file ',Filename,' as ',Myfile,
                       '                          ');
              Assign(FileComing,Prefixof(Filenames)+MyFile);
              STATE := RD ;
              If not ForPrinter then
                     Begin {$I-}
                     REWRITE(FileComing);
                     If IOresult <> 0 then
                        Begin (* IO error *)
                        Writeln(' Directory Full ');
                        STATE := A ;
                        SendPacketType('N');
                        End ; (* IO error *)
                     End ; {$I+}
              SendPacketType('Y');
              END   (* Got file header *)
                                   else
         BEGIN (* Not S,F,B,Z packet *)
         STATE := A ;   (* ABORT if not a S,F,B,Z type packet *)
         ABORT := NOT_SFBZ ;
         END ; (* Not S,F,B,Z packet *)


    (* RD ----- Receive Data State ------- *)
    (* Valid received msg type  : D,Z      *)
    RD: IF (NOT RECVPACKET) OR (INPACKETTYPE=Ord('N')) then SENDNAK
                                                       else
        If lastseqnum = inseq then  SendPacketType('Y')
                              else
        BEGIN  (* Got a good packet *)
        lastseqnum := inseq ;
        IF INPACKETTYPE = Ord('D') then
              BEGIN (* Receive data *)
        (*    WRITELN ('RECEIVE data ');  *)
              PacketCount := PacketCount + 1 ;
              GotoXY(44,4) ; Write (PacketCount);
              GotoXY(44,5) ; Writeln(RetryCount);
              I := 1 ;
              WHILE I <= InDataCount DO
                 BEGIN (* Write Data to file  *)
                   IF RecvData[I] = RepChar   then
                        BEGIN (* Repeat char   *)
                        I := I+1 ;
                        charcount := RecvData[I] - 32 ;
                        I := I + 1 ;
                        For j := 1 to charcount - 1 do
                            If ForPrinter then  Write(LST,Chr(RecvData[i]))
                                          else
                     Begin {$I-}
                     Write(FileComing,Chr(RecvData[i]));
                     If IOresult <> 0 then
                        Begin (* IO error *)
                        Writeln(' Disk is Full or file too large');
                        STATE := A ;
                        SendPacketType('N');
                        End ; (* IO error *)
                     End ; {$I+}

                        END ;  (* Repeat char  *)
                   IF RecvData[I] = Bit8Quote then
                        BEGIN (* 8TH BIT QUOTING  *)
                        I := I+1 ;
                        BIT8 := $80 ;
                        END   (* 8TH BIT QUOTING  *)
                                            else
                        BIT8 := 0 ;
                   IF RecvData[I] = CntrlQuote then
                        BEGIN (* CONTROL character *)
                        I := I+1 ;
                        IF RecvData[I] = $3F then   (* Make it a del *)
                                                   RecvData[I] := $7F
                                             else
                        IF RecvData[I] >= 64 then   (* Make it a control *)
                                          RecvData[I] := RecvData[I] - 64 ;

                       END ; (* CONTROL character *)
                   RecvData[I] := RecvData[I] + BIT8 ;
                   If ForPrinter then  Write(LST,Chr(RecvData[i]))
                                 else
                     Begin {$I-}
                     Write(FileComing,Chr(RecvData[i]));
                     If IOresult <> 0 then
                        Begin (* IO error *)
                        Writeln(' Disk is Full or file too large');
                        STATE := A ;
                        SendPacketType('N');
                        End ; (* IO error *)
                     End ; {$I+}
                 I := I + 1 ;
                 END ; (* Write Data to File *)
              Case Breakstate of
                   NoBreak : SendPacketType('Y');
                   BC : RECEIVING:=false ;
                   BE : SendPacketType('N') ;
                   BX : BreakAck('X') ;
                   BZ : BreakAck('Z') ;
               End; (* Case BreakState *)
              If Breakstate <> NoBreak then
              Writeln('Receiving file ',Filename,' as ',Myfile,' Interrupted');
              If BreakState = BX then Breakstate := NoBreak ;
              END   (* Receive data *)
                              else
         IF INPACKETTYPE = Ord('F') then
              BEGIN (* repeat *)
              OutSeq := OutSeq - 1 ;
              SendPacketType('Y') ;
              END   (* repeat *)
                              else
         IF INPACKETTYPE = Ord('Z') then
              BEGIN (* End of Incoming File *)
              If not ForPrinter then
                     Begin {$I-}
                     CLOSE(FileComing);
                     If IOresult <> 0 then
                        Begin (* IO error *)
                        Writeln(' Disk is Full or file too large');
                        End ; (* IO error *)
                     End ; {$I+}
              STATE := RF ;
              SendPacketType('Y');
              END   (* End of Incoming File *)
                              else
         BEGIN (* Not D,Z packet *)
         STATE := A;   (* ABORT - Type not  D,Z, *)
         ABORT := NOT_DZ ;
         END ; (* Not D,Z packet *)
        END ;  (* Got a good packet *)


    (* C ----- COMPLETED  State ------- *)
     C:  BEGIN (* COMPLETED Receiving *)
         SendPacketType('Y');
         If BreakState = NoBreak then
              Writeln ('Receiving files completed OK.')
                                 else
              Writeln('Receiving Files terminated by manual interruption');
         RECEIVING := FALSE ;
         END ; (* COMPLETED Receiving *)

    (* A ----- A B O R T  State ------- *)
     A:  BEGIN (* Abort Sending *)
         {$I-}
         CLOSE(FileComing);
         If IOresult <> 0 then
                 Writeln(' Unable to close file, is DISK FULL ');
         {$I+}
         WRITELN ('RECEIVEing files ABORTED');
         RECEIVING := FALSE ;
         (* SEND ERROR packet *)
         OutSeq   := 0 ;
         ErrorMsg :=' RECVfile abort' ;
         OutDataCount := length(ErrorMsg) ;
         For i := 1 to length(ErrorMsg) do
              SendData[i] := Ord(ErrorMsg[i]) ;
         OutPacketType := Ord('E');
         SENDPACKET ;
         END ; (* Abort Sending *)

         END ; (* CASE of STATE *)

    END ; (* ------- RECVFILE procedure -------*)

(* +FILE+ CONNECT.PASVT52 *)
(* ================================================================== *)
(*  Global Var                                                        *)
(* ================================================================== *)
Const
     Gversion = '  ' ;
     TermType = ' VT52   ' ;
     Graphics = '- Not applicable         ' ;
(* ================================================================== *)
(* ReadkeyTable - Dummy procedure                                     *)
(* ================================================================== *)
Procedure ReadKeyTable ; Begin End ;

(* ================================================================== *)
(*  Connection - Connect to the other computer and simulates          *)
(*               a VT52 type terminal .                               *)
(*                                                                    *)
(* ================================================================== *)
Procedure Connection ;
    VAR
         achar,bchar : byte ;
         i : integer ;
     (* -------------------------------------------------------- *)
         Procedure Escape ;
         Type
             EscapeType=(A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z);
         Var
              Xpos,Ypos : byte ;

         Begin (* Escape Sequence *)
         If Readchar(achar) then
             CASE EscapeType(achar-$41) of
           A: CursorUp ;    (* System Dependent Routine *)
           B: CursorDown ;  (* System Dependent Routine *)
           C: CursorRight ; (* System Dependent Routine *)
           D: CursorLeft ;  (* System Dependent Routine *)
           H: (* Clear Screen *)
              If ReadChar(achar) then    (* read next ESC char *)
                 If ReadChar(achar) then  (* read J char *)
                    ClrScr;
           K: ClrEol ;
           Y: Begin (* Cursor Position *)
              If ReadChar(achar) then Ypos := achar - $1F ;
              If ReadChar(achar) then Xpos := achar - $1F ;
              GotoXY(Xpos,Ypos);
              End ; (* Cursor Position *)
             End ; (* Case *)
         End ; (* Escape Sequence *)
    (* -------------------------------------------------------- *)
         Procedure RemoteCommand  ;
         Var
              i : integer ;
              Filename : Comstring ;
         Begin (* RemoteCommand procedure *)
         GotSOH := true ;
         If RecvPacket then
              Begin (* Got a Packet *)
              If  InPacketType = Ord('S') then        (* Send Packet *)
                   Begin (* Receive *)
                   writeln('Got a Send    request ');
                   Filename :=  '' ;
                   RecvFile(filename);
                   End   (* Receive *)
                                          else
              If  InPacketType = Ord('R') then        (* Receive Packet *)
                   Begin (* Receive *)
                   writeln('Got a receive request ');
                   for i := 1 to InCount-3 do
                       filename[i] := chr(RecvData[i]);
                   Filename[0] :=  chr(InCount-3) ;
                   waitxon := XonXoff ;
                   SendFile(filename);
                   End   (* Receive *)
                                          else
              If  InPacketType = Ord('G') then        (* General Packet *)
                   Begin (* Receive *)
                   writeln('Got a General request ');
                   SendPacketType('Y');
                   End   (* Receive *)
                                          else

                   Begin (* Unknow packet Type *)
                   OutCount := 15 ;
                   Outseq := 0 ;
                   OutPacketType := Ord('E');
        (*           SendData := 'Unknow Command';  *)
                   End;   (* Unknown packet Type *)
              End   (* Got a Packet *)
         End ; (* RemoteCommand Procedure *)
    (* -------------------------------------------------------- *)

    Begin (* Connection *)
    DialModem ;
    RemoteScreen ;      (* Save local screen, restore remote screen *)
    While connected do
         Begin (* connected *)
         If RecvChar(achar) then
              if achar < $20 then
                   Begin (* Control Character *)
                   if achar = SOH then RemoteCommand
                                  else
                   if achar = EOT then connected := false
                                  else
                   if achar = ESC then Escape
                                  else
                        if achar in [7,8,10,13] then write(chr(achar));
                   End   (* Control Character *)
                             else
                   If achar <> DEL then  write(chr(achar));

         if KeyChar(achar,bchar) then
              Begin (* key input *)
              if achar = $00 then
                if bchar = 83 then SendChar($7F)    (* DEL *)
                              else
                if bchar = 82 then SendChar($19)     (* INS *)
                              else
                   Begin (* Special Key *)
                   SendChar(Esc);
                     CASE bchar of
                   $3B,$3C,$3D,$3E,$3F,$40,$41,$42,$43:
                       SendChar(bchar-10);      (* PF1 to PF9 keys *)
                   $44: SendChar($30) ;            (* PF10 key *)
                   $54: SendChar($2D) ;            (* PF11 key *)
                   $55: SendChar($3D) ;            (* PF12 key *)
                   $56: SendChar($71) ;            (* PF13 key *)
                   $57: SendChar($77) ;            (* PF14 key *)
                   $58: SendChar($65) ;            (* PF15 key *)
                   $59: SendChar($72) ;            (* PF16 key *)
                   $5A: SendChar($74) ;            (* PF17 key *)
                   $5B: SendChar($79) ;            (* PF18 key *)
                   $5C: SendChar($75) ;            (* PF19 key *)
                   $5D: SendChar($69) ;            (* PF20 key *)

                   $48: SendChar($41) ;            (* Esc A - up arrow *)
                   $50: SendChar($42) ;            (* Esc B - down arrow *)
                   $4D: SendChar($43) ;            (* Esc C - rightarrow *)
                   $4B: SendChar($44) ;            (* Esc D - left arrow *)
                   $47,$4C:
                        SendChar($48) ;            (* Esc H - home arrow *)
                   $51,$77:
                        SendChar($4A) ;            (* Esc J - Clear      *)
                   $4F,$75:
                        SendChar($4B) ;            (* Esc K - Erase Eol  *)
                     End; (* Case bchar *)
                   End   (* Special Key *)
                             else
                   Begin (* Normal Key *)
                   if achar = LocalChar then connected := false else
                   if achar = BreakChar then SendBreak
                                  else Sendchar(achar);
                   if LocalEcho and connected then write(chr(achar));
                   End ; (* Normal Key *)
             End; (* key input *)
         End; (* connected *)
    LocalScreen ;  (* save remote screen , restore local screen *)
    End ; (* Connection *)

(* +FILE+ CONNECT.PASADM3A *)
(* ================================================================== *)
(*  Global Declarations - for ADM3A type of terminal emulation        *)
(* ================================================================== *)
Const
    Gversion = '  ' ;
    TermType = ' ADM3A  ' ;
    Graphics = '- Not Implemented        ' ;

Procedure ReadKeytable ;
     Begin End ;  (* dummy procedure - for MsDos systems only *)

(* ================================================================== *)
(*  Connection - Connect to the other computer and simulates          *)
(*               a DUMB      terminal .                               *)
(*                                                                    *)
(* ================================================================== *)
Procedure Connection ;
    VAR
         achar,bchar : byte ;
         i : integer ;
    (* -------------------------------------------------------- *)
         Procedure RemoteCommand  ;
         Var
              i : integer ;
              Filename : Comstring ;
         Begin (* RemoteCommand procedure *)
         GotSOH := true ;
         If RecvPacket then
              Begin (* Got a Packet *)
              If  InPacketType = Ord('S') then        (* Send Packet *)
                   Begin (* Receive *)
                   writeln('Got a Send    request ');
                   Filename :=  '' ;
                   RecvFile(filename);
                   End   (* Receive *)
                                          else
              If  InPacketType = Ord('R') then        (* Receive Packet *)
                   Begin (* Receive *)
                   writeln('Got a receive request ');
                   for i := 1 to InCount-3 do
                       filename[i] := chr(RecvData[i]);
                   Filename[0] :=  chr(InCount-3) ;
                   waitxon := XonXoff ;
                   SendFile(filename);
                   End   (* Receive *)
                                          else
              If  InPacketType = Ord('G') then        (* General Packet *)
                   Begin (* Receive *)
                   writeln('Got a General request ');
                   SendPacketType('Y');
                   End   (* Receive *)
                                          else

                   Begin (* Unknow packet Type *)
                   OutCount := 15 ;
                   Outseq := 0 ;
                   OutPacketType := Ord('E');
        (*           SendData := 'Unknow Command';  *)
                   End;   (* Unknown packet Type *)
              End   (* Got a Packet *)
         End ; (* RemoteCommand Procedure *)
    (* -------------------------------------------------------- *)

    Begin (* Connection *)
    DialModem ;
    RemoteScreen ;      (* Save local screen, restore remote screen *)
    While connected do
         Begin (* connected *)
         If RecvChar(achar) then
              if achar = SOH then RemoteCommand
                             else
              if achar = EOT then connected := false
                             else
                   if achar in [17,19,127] then  (* don't write *)
                                           else Ritechar(achar);

         if KeyChar(achar,bchar) then
              Begin (* key input *)
                   Begin (* Normal Key *)
                   if LocalEcho then Ritechar(achar);
                   if achar = LocalChar then connected := false else
                   if achar = BreakChar then SendBreak
                                        else Sendchar(achar);
                   End ; (* Normal Key *)
             End; (* key input *)
         End; (* connected *)
    LocalScreen ;  (* save remote screen , restore local screen *)
    End ; (* Connection *)

(* +FILE+ CONNECT.PASVT100 *)
(* ================================================================== *)
(*  Global Var and Procedures for special key specifications.         *)
(* ================================================================== *)
Const
     Gversion = '  ' ;
     TermType = ' VT100  ' ;
     Graphics = '- Not applicable         ' ;

Var
     EscSeq : Array [1..$88,1..2] of char ;
     KeyTableName : String[14] ;
     KeyTable : Text ;
(*------------------------------------------------------------------- *)
Function hexinteger (chars : string2): byte ;
    begin (* HexInteger *)
    If chars[1] in ['A'..'F'] then chars[1]:=chr(ord(chars[1])+9);
    If chars[2] in ['A'..'F'] then chars[2]:=chr(ord(chars[2])+9);
    hexinteger := (ord(chars[1]) shl 4) + (ord(chars[2]) and $0F) ;
    end  ; (* HexInteger *)
(*------------------------------------------------------------------- *)

Procedure ReadKeytable ;
var I : integer ;
    Newname : string[15] ;
    comment : string[80] ;
label retry ;

    Begin (* ReadKeytable *)
    keytablename := 'KEYTABLE.DAT' ;
    Assign(keytable,keytablename) ;
retry :
    {$I-}  Reset(keytable);  {$I+}
    If IORESULT = 0 then
         Begin (* Initiate key table *)
         For i := 1 to $88 do
              Begin (* init EscSeq table *)
              Readln(KeyTable,EscSeq[i,1],EscSeq[i,2],comment) ;
              If copy(comment,2,2) <> '  ' then
                 EscSeq[i,1] := Chr(HexInteger(copy(comment,2,2))) ;
              If copy(comment,4,2) <> '  ' then
                 EscSeq[i,2] := Chr(HexInteger(copy(comment,4,2))) ;
              End ; (* init EscSeq table *)
         Close(keytable);
         End   (* Initiate key table *)
                  else
         Begin (* Warning *)
         ClrScr ;
         Writeln('*** File ',Keytablename,' not found on drive.');
         Writeln('    Please specify drive or new name of keytable file. ');
         Readln(newname);
         If Length(Newname) = 1 then
              keytablename := Newname + ':' + keytablename
                                else
              keytablename := Newname ;
         Assign(keytable,keytablename);
         If length(keytablename)<3 then Running := false
                                   else Goto Retry ;
         End ; (* Warning *)
    End ; (* ReadKeytable *)

const
     APLTABLE : array [0..127] of byte =
{00}  ($00,$01,$02,$03,$04,$05,$06,$07,$08,$09,$0A,$0B,$0C,$0D,$0E,$0F,  {0F}
{01}   $10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$1A,$1B,$1C,$1D,$1E,$1F,  {1F}
{02}   $20,$05,$29,$3C,$F3,$3D,$3E,$5D,$FA,$5E,$86,$F6,$2C,$2B,$2E,$2F,  {1F}
{03}   $30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$28,$5B,$3B,$78,$3A,$5C,  {3F}
{04}   $FD,$E0,$E6,$EF,$8F,$EE,$5F,$EC,$91,$E2,$F8,$27,$95,$FE,$E7,$F9,  {4F}
{05}   $2A,$3F,$FB,$8D,$7E,$19,$FC,$17,$0E,$18,$0B,$1B,$1D,$1A,$F2,$2D,  {5F}
{06}   $40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$4A,$4B,$4C,$4D,$4E,$4F,  {6F}
{07}   $50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$5A,$7B,$1C,$7D,$24,$2D); {7F}
   Over1 = 'T('#$E5'T)'#$EA'GM'#$1F'HM'#$1E'OM'#$E8'O?'#$ED'O_'#$E9'OP'#$0F ;
   Over2 = 'BN'#$15'GT'#$13'BJ'#$F5'NJ'#$F4'?_'#$A7'/_'#$EB'CJ'#$A6'KL'#$97 ;
   Over3 = 'K.'#$21'L+'#$98 ;
   Over4 = 'aFabFbcFcdFdeFefFfgFghFhiFijFjkFklFlmFmnFnoFopFpqFqrFrsFs' ;
   Over5 = 'tFtuFuvFvwFwxFxyFyzFz' ;
(* ================================================================== *)
(*  Connection - Connect to the other computer and simulates          *)
(*               a VT100 type terminal .                              *)
(*                                                                    *)
(* ================================================================== *)

Procedure Connection ;
    VAR
         achar,bchar : byte ;
         i : integer ;
         overchar : string[2] ;
         overchars : string[160] ;
         EscapeFlag : boolean ;
    (* -------------------------------------------------------- *)
    Procedure Escape ;
         Var Pn,Pc : byte ;

         Function PNumber (var achar : byte) : integer ;
          var Numstr : string[3];
              Num,result : integer ;
              Begin (* PNumber *)
              Numstr := '' ;
              While chr(achar) in ['0'..'9']  do
                   Begin (* get number *)
                   Numstr := Numstr + chr(achar) ;
                   If Readchar(achar) then ;
                   End ; (* get number *)
              Val(Numstr,Num,Result);
              PNumber := Num ;
              End ; (* PNumber *)

    Begin (* Escape Sequence *)
    If Readchar(achar) then
    CASE chr(achar) of  (* First Level *)
         '[':
               If Readchar(achar) then
               CASE chr(achar) of   (* Second level *)
                 'C': CursorRight ;
                 'D': CursorLeft  ;
                 'J': ClrScr ; (* Erase End of Display *)
                 'K': ClrEol ; (* Erase End of Line *)
                 '?': ;        (* Special functions - not yet implemented *)
                 'H': GoToXY(0,0);  (* Cursor Home *)
                 'm':(* NormVideo*) ;  (* Exit all attribute modes *)
                else
                     Begin (* Esc [ Pn x   functions *)
                     Pn := PNumber(achar);
                     CASE chr(achar) of (* third level *)
                        'A': For i := 1 to Pn do Cursorup ;
                        'B': For i := 1 to Pn do Cursordown ;
                        'C': For i := 1 to Pn do CursorRight ;
                        'D': For i := 1 to Pn do CursorLeft ;
                        ';': Begin (* Direct cursor addressing *)
                             If readchar(achar) then ;
                             Pc := PNumber (achar);
                             GoToXY(Pc,Pn);
                             If (pn<1) or (pc<1) then
                              writeln('***',pn,' ',pc,'***');
                             End ; (* Direct cursor addressing *)
                        'q': FatCursor(Pn=1) ;
                        'm',
                        '}':
                             Case Pn of      (* Field specs *)
                             0: begin (* Normal *)
                                TextColor(LightGray);
                                Textbackground(black);
                                end ;
                             1: begin (* High Intensity *)
                                TextColor(White);
                                Textbackground(black);
                                end ;
                             4: begin (* Underline *)
                                TextColor(White);
                                Textbackground(black);
                                end ;
                             5: begin (* Blink *)
                                TextColor(White+ blink);
                                Textbackground(black);
                                end ;
                             7: begin (* Reverse *)
                                TextColor(Black);
                                Textbackground(white);
                                end ;
                             8: begin (* Invisible *)
                                TextColor(Black);
                                Textbackground(black);
                                end ;
                            30: Textcolor(Black);
                            31: Textcolor(Red);
                            32: Textcolor(Green);
                            33: Textcolor(yellow);
                            34: Textcolor(Blue);
                            35: Textcolor(Magenta);
                            36: Textcolor(Cyan);
                            37: Textcolor(White);

                            40: Textbackground(Black);
                            41: Textbackground(Red);
                            42: Textbackground(Green);
                            43: Textbackground(Yellow);
                            44: Textbackground(Blue);
                            45: Textbackground(Magenta);
                            46: Textbackground(Cyan);
                            47: Textbackground(White);

                             End ; (* case of Field specs *)
                        'J': Case Pn of
                             0: ClrScr ;
                             1: ClrScr ; (* clear to beginning *)
                             2: ClrScr ;
                             End ; (*  J - Pn Case *)
                        'K': Case Pn of
                             1: ClrEol ; (* clear to beginning *)
                             2: ClrEol ; (* clear line *)
                             End ; (*  J - Pn Case *)
                        'L': For i := 1 to Pn do InsLine ; (* Insert Line *)
                        'M': For i := 1 to Pn do DelLine ; (* Delete Line *)
                        '@': For i := 1 to Pn do (* InsertChar *)  ;
                        'P': For i := 1 to Pn do (* DeleteChar *)  ;
                     End ; (* Case third level *)
                     End ; (* Esc [ Pn x   functions *)

               End ; (* second level Case *)

         'D': CursorDown ;    (* Index *)
         'M': CursorUp   ;    (* Reverse Index *)
         'H':            ;    (* Set Tab Stop *)
         '(':            ;    (* G0 *)
         ')':            ;    (* G1 *)
         End ; (* First Level Case  *)

    End ; (* Escape Sequence *)
    (* -------------------------------------------------------- *)
         Procedure RemoteCommand  ;
         Var
              i : integer ;
              Filename : Comstring ;
         Begin (* RemoteCommand procedure *)
         GotSOH := true ;
         If RecvPacket then
              Begin (* Got a Packet *)
              If  InPacketType = Ord('S') then        (* Send Packet *)
                   Begin (* Receive *)
                   writeln('Got a Send    request ');
                   Filename :=  '' ;
                   RecvFile(filename);
                   End   (* Receive *)
                                          else
              If  InPacketType = Ord('R') then        (* Receive Packet *)
                   Begin (* Receive *)
                   writeln('Got a receive request ');
                   for i := 1 to InCount-3 do
                       filename[i] := chr(RecvData[i]);
                   Filename[0] :=  chr(InCount-3) ;
                   waitxon := XonXoff ;
                   SendFile(filename);
                   End   (* Receive *)
                                          else
              If  InPacketType = Ord('G') then        (* General Packet *)
                   Begin (* Receive *)
                   writeln('Got a General request ');
                   SendPacketType('Y');
                   End   (* Receive *)
                                          else

                   Begin (* Unknow packet Type *)
                   OutCount := 15 ;
                   Outseq := 0 ;
                   OutPacketType := Ord('E');
        (*           SendData := 'Unknow Command';  *)
                   End;   (* Unknown packet Type *)
              End   (* Got a Packet *)
         End ; (* RemoteCommand Procedure *)
    (* -------------------------------------------------------- *)

    Begin (* Connection *)
    DialModem ;
    Overchars := Over1+Over2+Over3+Over4+Over5 ;
    RemoteScreen ;      (* Save local screen, restore remote screen *)
    While KeyChar(achar,bchar) do ;    (* Empty keyboard buffer *)
    While connected do
         Begin (* connected *)
         If RecvChar(achar) then
              if achar < $20 then
                   Begin (* Control Character *)
                   if achar = StartChar then  RemoteCommand
                                        else
                   if achar = EOT then connected := false
                                  else
                   if achar = ESC then Escape
                                  else
                   if (achar=BS) and AplFlag then
                        Begin (* Overstrick character *)
                        overchar[0] := chr(2) ;
                        If Readchar(achar) then overchar[2]:=chr(achar);
                        i:=Pos(overchar,overchars);
                        If i > 0 then  achar := ord(overchars[i+2])
                                 else
                              begin (* reverse order *)
                              overchar[2] := overchar[1] ;
                              overchar[1] := chr(achar);
                              i:=Pos(overchar,overchars);
                              If i>0 then achar := ord(overchars[i+2])
                                     else achar := AplTable[ord(overchar[2])];
                              end ; (* reverse order *)
                        write(chr(BS),chr(achar));
                        End  (* Overstrick character *)
                                             else
                   if achar in [7,8,10,13] then write(chr(achar));
                   End   (* Control Character *)
                             else
                   If achar <> DEL then
                             if AplFlag then begin (* APL char *)
                                             write(chr(APLTABLE[achar]));
                                             overchar[1] := chr(achar) ;
                                             end
                                        else write(chr(achar));
         if KeyChar(achar,bchar) then
              Begin (* key input *)
              if bchar = $70 then connected := false else  (* Alt F9  *)
              if bchar = $71 then SendBreak          else  (* Alt F10 *)

              If ((achar=0) or (EscSeq[bchar,1]<>' ')
                            or (EscSeq[bchar,2]<>' ') ) and
                          (achar <> $09)  then
                   Begin (* Send escape sequence *)

                   If EscSeq[Bchar,1]<>' ' then SendChar(Esc);
                   If EscSeq[Bchar,1]<>' ' then
                             SendChar(Ord(EscSeq[bchar,1])) ;
                   If EscSeq[bchar,2]<>' ' then
                             SendChar(Ord(EscSeq[bchar,2])) ;
                   End  (* Send Escape Sequence *)
                                                    else
                   Begin (* Normal Key *)
                   If EscapeFlag then
                        if achar = $7B then AplFlag := true  else
                        if achar = $7D then AplFlag := false ;
                   Escapeflag := achar = ESC ;
                   if achar = LocalChar then connected := false else
                      if achar = BreakChar then SendBreak
                                           else Sendchar(achar);
                   if LocalEcho and connected then
                             if AplFlag then write(chr(APLTABLE[achar]))
                                        else write(chr(achar));
                   End ; (* Normal Key *)

             End; (* key input *)
         End; (* connected *)
    LocalScreen ;  (* save remote screen , restore local screen *)
    End ; (* Connection *)

(* +FILE+ CONNECT.PASTEK10 *)
(* ================================================================== *)
(*  Global Var and Procedures for special key specifications.         *)
(* ================================================================== *)
Const
     Gversion = 'G ' ;
     TermType = ' TEK4010' ;
     Graphics = ' by Victoria Henderson   ' ;

Var
     EscSeq : Array [1..$88,1..2] of char ;
     KeyTableName : String[14] ;
     KeyTable : Text ;
(*------------------------------------------------------------------- *)
Function hexinteger (chars : string2): byte ;
    begin (* HexInteger *)
    If chars[1] in ['A'..'F'] then chars[1]:=chr(ord(chars[1])+9);
    If chars[2] in ['A'..'F'] then chars[2]:=chr(ord(chars[2])+9);
    hexinteger := (ord(chars[1]) shl 4) + (ord(chars[2]) and $0F) ;
    end  ; (* HexInteger *)
(*------------------------------------------------------------------- *)

Procedure ReadKeytable ;
var I : integer ;
    Newname : string[15] ;
    comment : string[80] ;
label retry ;
    Begin (* ReadKeytable *)
    keytablename := 'KEYTABLE.DAT' ;
    Assign(keytable,keytablename) ;
retry :
    {$I-}  Reset(keytable);  {$I+}
    If IORESULT = 0 then
         Begin (* Initiate key table *)
         For i := 1 to $88 do
              Begin (* init EscSeq table *)
              Readln(KeyTable,EscSeq[i,1],EscSeq[i,2],comment) ;
              If copy(comment,2,2) <> '  ' then
                 EscSeq[i,1] := Chr(HexInteger(copy(comment,2,2))) ;
              If copy(comment,4,2) <> '  ' then
                 EscSeq[i,2] := Chr(HexInteger(copy(comment,4,2))) ;
              End ; (* init EscSeq table *)
         Close(keytable);
         End   (* Initiate key table *)
                  else
         Begin (* Warning *)
         Writeln('No ',Keytablename);
         Readln(Keytablename);
         Assign(keytable,keytablename);
         If length(keytablename)<1 then Running := false
                                   else Goto Retry ;
         End ; (* Warning *)
    End ; (* ReadKeytable *)


(* ================================================================== *)
(*  Connection - Connect to the other computer and simulates          *)
(*               a VT100 type terminal with Tek4010 graphics.         *)
(*                                                                    *)
(* ================================================================== *)

Procedure Connection ;
    CONST

         us = #31;
         rs = #30;
         gs = #29;
         fs = #28;
         ff = #12;
         syn = #22;
         exclam = #33;
    VAR
         achar,bchar : byte ;
         i : integer ;
         LastX, LastY: INTEGER;
         HiY, LoY, HiX, LoX, NewX, NewY: INTEGER;
         TextColour: Integer;
         DrawMode: Boolean;
         Heapmark : ^WrkString ;

    (* -------------------------------------------------------- *)

PROCEDURE InitGraph;
   BEGIN
     Mark(heapmark);
     InitGraphic;
     DefineWorld (1,0,779,1023,0);
     DefineWindow(1,0,0,xmaxglb,ymaxglb);
     SelectWorld(1);
     SelectWindow(1);
     SetWindowModeOn;
     DrawMode := True;
   END;

PROCEDURE EndGraph;
   BEGIN
     Repeat Until Keypressed;
     LeaveGraphic;   {clear graphics screen and return to text mode}
     DrawMode := False;
     Release(Heapmark);
 END;

    (* -------------------------------------------------------- *)

PROCEDURE EscapeSequence (VAR ach:byte);

   CONST
        Percent = #37;
        Exclam  = #33;
        ff      = #12;
        sub     = #26;

   VAR
        Xpos, Ypos : BYTE;
         Pn,Pc : byte ;

         Function PNumber (var achar : byte) : integer ;
          var Numstr : string[3];
              Num,result : integer ;
              Begin (* PNumber *)
              Numstr := '' ;
              While chr(achar) in ['0'..'9']  do
                   Begin (* get number *)
                   Numstr := Numstr + chr(achar) ;
                   If Readchar(achar) then ;
                   End ; (* get number *)
              Val(Numstr,Num,Result);
              PNumber := Num ;
              End ; (* PNumber *)

    Begin (* Escape Sequence *)
      IF ReadChar(ach) THEN
           IF DrawMode THEN
              CASE chr(ach) OF
                  sub: EndGraph;
                   ff: BEGIN
                         LeaveGraphic;
                         DrawMode := False;
                         END; {ff}
               END  {case}
            ELSE   {not drawmode, check system functions}
    CASE chr(achar) of  (* First Level *)
         '[':
               If Readchar(achar) then
               CASE chr(achar) of   (* Second level *)
                 'C': CursorRight ;
                 'D': CursorLeft  ;
                 'J': ClrScr ; (* Erase End of Display *)
                 'K': ClrEol ; (* Erase End of Line *)
                 '?': ;        (* Special functions - not yet implemented *)
                 'H': GoToXY(0,0);  (* Cursor Home *)
                 'm':(* NormVideo*) ;  (* Exit all attribute modes *)
                else
                     Begin (* Esc [ Pn x   functions *)
                     Pn := PNumber(achar);
                     CASE chr(achar) of (* third level *)
                        'A': For i := 1 to Pn do Cursorup ;
                        'B': For i := 1 to Pn do Cursordown ;
                        'C': For i := 1 to Pn do CursorRight ;
                        'D': For i := 1 to Pn do CursorLeft ;
                        ';': Begin (* Direct cursor addressing *)
                             If readchar(achar) then ;
                             Pc := PNumber (achar);
                             GoToXY(Pc,Pn);
                             End ; (* Direct cursor addressing *)
                        'q': FatCursor(Pn=1) ;
                        'm',
                        '}':
                             Case Pn of      (* Field specs *)
                             0: begin (* Normal *)
                                TextColor(LightGray);
                                Textbackground(black);
                                end ;
                             1: begin (* High Intensity *)
                                TextColor(White);
                                Textbackground(black);
                                end ;
                             4: begin (* Underline *)
                                TextColor(White);
                                Textbackground(black);
                                end ;
                             5: begin (* Blink *)
                                TextColor(White+ blink);
                                Textbackground(black);
                                end ;
                             7: begin (* Reverse *)
                                TextColor(Black);
                                Textbackground(white);
                                end ;
                             8: begin (* Invisible *)
                                TextColor(Black);
                                Textbackground(black);
                                end ;
                            30: Textcolor(Black);
                            31: Textcolor(Red);
                            32: Textcolor(Green);
                            33: Textcolor(yellow);
                            34: Textcolor(Blue);
                            35: Textcolor(Magenta);
                            36: Textcolor(Cyan);
                            37: Textcolor(White);

                            40: Textbackground(Black);
                            41: Textbackground(Red);
                            42: Textbackground(Green);
                            43: Textbackground(Yellow);
                            44: Textbackground(Blue);
                            45: Textbackground(Magenta);
                            46: Textbackground(Cyan);
                            47: Textbackground(White);

                             End ; (* case of Field specs *)
                        'J': Case Pn of
                             0: ClrScr ;
                             1: ClrScr ; (* clear to beginning *)
                             2: ClrScr ;
                             End ; (*  J - Pn Case *)
                        'K': Case Pn of
                             1: ClrEol ; (* clear to beginning *)
                             2: ClrEol ; (* clear line *)
                             End ; (*  J - Pn Case *)
                        'L': For i := 1 to Pn do InsLine ; (* Insert Line *)
                        'M': For i := 1 to Pn do DelLine ; (* Delete Line *)
                        '@': For i := 1 to Pn do (* InsertChar *)  ;
                        'P': For i := 1 to Pn do (* DeleteChar *)  ;
                     End ; (* Case third level *)
                     End ; (* Esc [ Pn x   functions *)

               End ; (* second level Case *)

         'D': CursorDown ;    (* Index *)
         'M': CursorUp   ;    (* Reverse Index *)
         'H':            ;    (* Set Tab Stop *)
         '(':            ;    (* G0 *)
         ')':            ;    (* G1 *)
         End ; (* First Level Case  *)

    End ; (* Escape Sequence *)

    (* -------------------------------------------------------- *)
PROCEDURE DrawVector (VAR ach:byte);

  CONST
    ParityBit = 127;
    BitCheck  =  96;
    LoYBit    =  96;
    LoXBit    =  64;
    HiBit     =  32;
    FiveBits  =  31;
    ScaleX    =  1.6;  {tek4010 co-ordinates are 1024 x 780}
    ScaleY    =  3.47;  {scale into screen size 640 x 225 }
    us = #31;
    gs = #29;
    esc = #27;
    sub = #26;

   VAR
     XFlag, DrawFlag: BOOLEAN;
     CByte: Integer;
     ch: char;

  BEGIN
     XFlag := FALSE;
     DrawFlag := FALSE;
     ch := chr(ach);
     WHILE (ch <> us) and (ch <> esc) DO
        BEGIN
          IF ReadChar(ach) THEN
            BEGIN
             IF ch = gs THEN DrawFlag := False;
             ch := chr(ach);
             CByte := ord(ch) and ParityBit;  {remove parity bit}
             IF (CByte and BitCheck) = HiBit THEN
                IF XFlag THEN
                   HiX := CByte and FiveBits
                ELSE
                   HiY := CByte and FiveBits
             ELSE
                IF (CByte and BitCheck) = LoYBit THEN
                   BEGIN
                     LoY := CByte and FiveBits;
                     XFlag := TRUE;
                   END
             ELSE
                IF (CByte and BitCheck) = LoXBit THEN
                   BEGIN
                     LoX := CByte and FiveBits;
                     XFlag := FALSE;
                     NewX := (HiX*32 + LoX);
                     NewY := 779 - (HiY*32 + LoY);
                     IF DrawFlag THEN
                        DrawLine ( LastX, LastY, NewX, NewY)
                     ELSE
                        BEGIN
                          SetColorBlack;
                          DrawPoint( NewX, NewY);
                          SetColorWhite;
                          DrawFlag := TRUE;
                        END;
                     LastX := NewX;
                     LastY := NewY;
                   END; {IF}
                END; {IF}
       END;  {while}
   END; {drawvector}

PROCEDURE  AlphaMode (VAR ach:byte);

    VAR
       I: INTEGER;
       Str: String[255];

    BEGIN
       Str := '';
       I := 1;
       IF ReadChar(ach) THEN
          WHILE (chr(ach) <> gs) and (I <= 255) and (ach <> esc) DO
                BEGIN
                  Str := Str + chr(ach); I := I+1;
                  IF ReadChar(ach) THEN
                END; {while}
           DrawTextW(LastX*1.0,LastY*1.0,1,Str);
           IF (chr(ach) = gs) and (not DrawMode) THEN  InitGraph;
           IF (ach = esc) THEN EndGraph;
    END; {alphamode}

    (* -------------------------------------------------------- *)

         Procedure RemoteCommand  ;
         Var
              i : integer ;
              Filename : Comstring ;
         Begin (* RemoteCommand procedure *)
         GotSOH := true ;
         If RecvPacket then
              Begin (* Got a Packet *)
              If  InPacketType = Ord('S') then        (* Send Packet *)
                   Begin (* Receive *)
            (*     writeln('Got a Send request');    *)
                   Filename :=  '' ;
                   RecvFile(filename);
                   End   (* Receive *)
                                          else
              If  InPacketType = Ord('R') then        (* Receive Packet *)
                   Begin (* Receive *)
              (*   writeln('Got a receive request ');  *)
                   for i := 1 to InCount-3 do
                       filename[i] := chr(RecvData[i]);
                   Filename[0] :=  chr(InCount-3) ;
                   waitxon := XonXoff ;
                   SendFile(filename);
                   End   (* Receive *)
                                          else
              If  InPacketType = Ord('G') then        (* General Packet *)
                   Begin (* Receive *)
              (*   writeln('Got a General request ');    *)
                   SendPacketType('Y');
                   End   (* Receive *)
                                          else

                   Begin (* Unknow packet Type *)
                   OutCount := 15 ;
                   Outseq := 0 ;
                   OutPacketType := Ord('E');
        (*           SendData := 'Unknow Command';  *)
                   End;   (* Unknown packet Type *)
              End   (* Got a Packet *)
         End ; (* RemoteCommand Procedure *)
    (* -------------------------------------------------------- *)

    Begin (* Connection *)
    DialModem ;
    RemoteScreen ;      (* Save local screen, restore remote screen *)
    While KeyChar(achar,bchar) do ;    (* Empty keyboard buffer *)
    HiY := 0; LoY := 0; HiX := 0; LoX := 0;
    LastX := 0; LastY := 0; DrawMode := False;
    While connected do
         Begin (* connected *)
         If RecvChar(achar) then
              if achar < $20 then
                   Begin (* Control Character *)
                   if achar = SOH then (* RemoteCommand *)
                                  else
                   if achar = EOT then connected := false
                                  else
                   if achar in [7,8,10,13] then write(chr(achar))
                    ELSE
                 IF chr(achar) = gs THEN
                      BEGIN
                         IF not DrawMode THEN  InitGraph;
                         WHILE chr(achar) = gs DO
                           BEGIN
                             DrawVector(achar);
                             IF achar = esc THEN EscapeSequence(achar)
                                ELSE
                             AlphaMode(achar);
                           END; {while}
                      END  {if}
                    ELSE
                 IF chr(achar) = fs THEN DrawVector(achar)
                    ELSE
                 IF chr(achar) = syn THEN  {ignore}
                    ELSE
                 IF achar = esc THEN  EscapeSequence(achar)
                    ELSE
                 IF char(achar) = rs THEN EndGraph; {sas terminator}
                   End   (* Control Character *)
                             else
                   If achar <> DEL then   write(chr(achar));

         if KeyChar(achar,bchar) then
              Begin (* key input *)
              If ((achar=0) or (EscSeq[bchar,1]<>' ')
                            or (EscSeq[bchar,2]<>' ') ) and
                          (achar <> $09)  then
                   Begin (* Send escape sequence *)
                   If EscSeq[Bchar,1]<>' ' then SendChar(Esc);
                   If EscSeq[Bchar,1]<>' ' then
                             SendChar(Ord(EscSeq[bchar,1])) ;
                   If EscSeq[bchar,2]<>' ' then
                             SendChar(Ord(EscSeq[bchar,2])) ;
                   End  (* Send Escape Sequence *)
                                                    else
                   Begin (* Normal Key *)
                   if achar = LocalChar then connected := false else
                      if achar = BreakChar then SendBreak
                                           else Sendchar(achar);
                   if LocalEcho and connected then write(chr(achar));
                   End ; (* Normal Key *)

             End; (* key input *)
         End; (* connected *)
    LocalScreen ;  (* save remote screen , restore local screen *)
    End ; (* Connection *)

(* +FILE+ SETSHOW.PASMSCPM *)
(* ================================================================== *)
(* ShowOptions - Show Parameter Options setting for Kermit.           *)
(*                                                                    *)
(* ================================================================== *)
Procedure ShowOptions ;

Begin (* ShowOptions Procedure *)
ClrScr ; (* Clear the Screen *)
GotoXY(1,2);   (* Start at line 2 *)
Writeln('         QK-KERMIT  version ',version,Gversion,' -  ',Date);
Writeln(' ');
Writeln('  Current Setting           Options ');
Writeln('-------------------    --------------------------------------');
Writeln('Baud Rate  = ',Baudrate,'      ( 300 600 1200 2400 4800 9600 19.2 )');
Write  ('Parity     = ') ;
  Case paritytype(parity) of
     OddP : write('Odd  ');
     EvenP: write('Even ');
     MarkP: write('Mark ');
     NoneP: write('None ');
  end ; (* parity case *)
Writeln('     ( Odd   Even  Mark  None ) ');
Write  ('Duplex     = ');
  If LocalEcho then Write('Half ')
               else Write('Full ');
  writeln('     ( Half  Full ) ');

Write  ('Protocol   = ');
    If Series1 then write('Series/1 ')
               else If XonXoff then write('Xon-Xoff ')
                               else write('Standard ');
    writeln(' ( Xon-Xoff   Series/1   Standard )');
Writeln(' ');
Write  ('Disk Drive = ',chr(DefaultDrive+$41),':   ') ;
  writeln('     ( A:    B:    C:    D:   )');
Write  ('Com Port   = ');
  If PrimaryPort then Write('One  ')
                 else Write('Two  ');
  writeln('     ( One   Two  ) ' );
Write  ('Destination=');
  If ForPrinter  then Write(' Printer ')
                 else Write(' Disk    ');
  writeln('  ( Disk  Printer )');
Writeln(' ');
If ParmFlag then Begin (* Display Packet Parameters *)
Writeln('-------------------------------------------------------------');
Writeln('Packet Parameters');
Writeln('    Packetsize = ',Packetsize,'  Timeout   = ',Timeout:2,'   *');
Writeln('    NumPad     = ',NumPad:2,'  PadChar   = ',PadChar:2,'   *');
Write  ('    Startchar  = ',StartChar:2,'  EndChar   = ',EndChar:2);
Writeln('   * use decimal values ');
Write  ('    CntrlQuote =  ',chr(CntrlQuote),'  Bit8Quote =  ',chr(Bit8quote));
Writeln('   | use character values ');
Write  ('    CheckType  =  ',chr(CheckType),'  RepChar   =  ',chr(RepChar));
Writeln('   |   use NULL for null character )');
                End ; (* Display Packet Parameters *)
If logging then
    Begin writeln(' '); writeln(' Logging data to file ',LogName); end;

End;  (* ShowOptions Procedure *)
(* ================================================================== *)
(* SetOptions - Set Parameter Options setting for Kermit.             *)
(*                                                                    *)
(* ================================================================== *)
Procedure SetOptions (var instring:comstring);
Const
    OP1Table : String[40] = '     300  600  1200 2400 4800 9600 19.2 ';
    OP2Table : String[30] = 'ODD  EVEN MARK NONE HALF FULL ';
    OP3Table : String[40] = 'XON-XOFF  SERIES/1  STANDARD  ONE  TWO  ';
    OP4Table : String[40] = 'A:   B:   C:   D:   DISK PRINTER  ';
    PP1Table : String[44] = '           PACKETSIZE TIMEOUT    NUMPAD     ';
    PP2Table : String[44] = 'PADCHAR    STARTCHAR  ENDCHAR    CNTRLQUOTE ';
    PP3Table : String[33] = 'BIT8QUOTE  CHECKTYPE  REPCHAR    ' ;
Type
    Options = (zero,b300,b600,b1200,b2400,b4800,b9600,b19200,
               PO,PE,PM,PN,HALF,FULL,
               Xon,xon1,Series,ser1,Stand,stand1,one,two,
               A,B,C,D,Disk,Print,print1) ;
   PParms = (Pzero,Psize,PTime,PNumPad,PPadChar,
             PStartChar,PEndChar,PcntrlQuote,Pbit8Quote,
             PChecktype,PRepChar);
Var
    Option : comstring ;
    OptionTable : String[255];
    PParmTable : String[122];
    Ix : integer ;
    ScanOptions : boolean ;

         Procedure SetValue ( var Pvalue : byte );
         var I,Retcode : integer ;
         Begin (* Set Value *)
         Val(Gettoken(Instring),I,Retcode);
         If Retcode = 0 then Pvalue := I
                        else
              Begin Writeln('>>> Invalid value specified <<<');Delay(2000);End;
         End ; (* Set Value *)

         Procedure SetChar ( var Pchar : byte );
         Var atoken : string[10];
         Begin (* set char *)
         Atoken := UpperCase(Gettoken(Instring)) ;
         If Atoken = 'NULL' then Pchar := 0 else
         If Length(Atoken) = 1 then Pchar := Ord(Atoken[1])
                               else
              Begin Writeln('>>> Invalid Specification <<<');delay(2000);End;
         End ; (* set char *)

Begin (* SetOptions Procedure *)
OptionTable := OP1Table + OP2Table + OP3Table + OP4Table ;
PParmTable := PP1Table + PP2Table + PP3Table ;
If length(instring)<1 then
    Begin (* Get Settings *)
    ShowOptions;
    Write  ('Enter Option Setting >');
    If audioflag then
       Begin Sound(1000); Delay(250); Sound(2000); Delay(50); Nosound;end;
    Readln(instring);
    End ; (* Get Settings *)
ScanOptions := true ;
While (length(instring)>0) and ScanOptions do
    Begin (* Parse instring *)
    Option := GetToken(instring);
    ScanOptions := Option<>';';
    Option := Concat(' ',Uppercase(Option));
    ix := Pos(Option,OptionTable) div 5 ;
    If ix <> 0 then
         Case Options(ix) of
         b300   : Baudrate := 300 ;
         b600   : Baudrate := 600 ;
         b1200  : Baudrate := 1200 ;
         b2400  : Baudrate := 2400 ;
         b4800  : Baudrate := 4800 ;
         b9600  : Baudrate := 9600 ;
         b19200 : Baudrate := 19200 ;
         PO     : Parity   := OddP ;
         PE     : parity   := EvenP ;
         PM     : Parity   := MarkP ;
         PN     : parity   := NoneP ;
         HALF   : LocalEcho:= True ;
         FULL   : LocalEcho:= False ;
         Xon    : Begin XonXoff := True;  Series1 := False; End;
(*       Series : Begin XonXoff := True;  Series1 := True;  End;  *)
         Series : Begin XonXoff := False; Series1 := True;  End;
         Stand  : Begin XonXoff := False; Series1 := False; End;
         One    : PrimaryPort := True ;
         Two    : PrimaryPort := False ;
         A      : SetDefaultDrive(0) ;
         B      : SetDefaultDrive(1) ;
         C      : SetDefaultDrive(2) ;
         D      : SetDefaultDrive(3) ;
         Disk   : ForPrinter := false ;
         Print  : ForPrinter := true ;
         End   (* case of options *)
               else
         Begin (* check packet parms *)
         ix := Pos(Option,PParmTable) div 11 ;
         If (ix <> 0) and ParmFlag then
              Case PParms(ix) of
         Psize:          SetValue(Packetsize) ;
         PTime:          SetValue(Timeout) ;
         PNumPad:        SetValue(NumPad) ;
         PPadChar:       SetValue(PadChar) ;
         PStartChar:     SetValue(StartChar) ;
         PEndChar:       SetValue(EndChar) ;
         PcntrlQuote:    SetChar(CntrlQuote) ;
         Pbit8Quote:     SetChar(Bit8Quote) ;
         PChecktype:     SetChar(CheckType) ;
         PRepChar :      SetChar(RepChar) ;
              End ; (* Case of  PParms *)
         If chr(CheckType) in ['1','2','3'] then else CheckType := 49 ;
         End ; (* check packet parms *)
    ResetModem; Initmodem ;
    SetModem ;
    End ; (* Parse instring *)
ShowOptions ;
End ; (* SetOptions Procedure *)

(* ================================================================== *)
(* DisplayCommands - Display all the valid Kermit Commands.           *)
(*                                                                    *)
(* ================================================================== *)
Procedure DisplayCommands;

Begin (* DisplayCommands Procedure *)
ClrScr ;
Writeln('     The Following are the valid Kermit Commands :');
Writeln('---------------------------------------------------------------');
Writeln('CONNECT <options>  - connect to a remote host as a dumb terminal.');
Writeln(' ');
Writeln('SEND    <local-filename > AS <remote-filename> RAW');
Writeln('RECEIVE <remote-filename> AS <local-filename > REPLACE');
Writeln('                        ');
Writeln('SET    <options>   - set option settings.');
Writeln('STATUS             - display optional settings and status');
Writeln('            ');
Writeln('DIRECTORY,ERASE,RENAME,TYPE,RUN <filename> - local commands');
Writeln('MKDIR,CHDIR,RMDIR  <directoryname>         - local commands');
Writeln('REMOTE <commands>                          - remote commands');
Writeln('            ');
Writeln('LOG  <filename>    - Record data received in a log file.');
Writeln('TAKE <filename>    - Take and execute commands from a  file.');
Writeln('DEFINE <dword> <dstring> - define a word to equal a string.');
Writeln('AUDIO,PARMS        - toggle options .');
Writeln('QUIT  <QuitOption> - terminate local or remote kermit program.');
Writeln('                     QuitOptions : LOCAL,REMOTE,DISCONnect,ALL');
Writeln(' ');
Writeln('   Note: All parameters are optional and all commands maybe');
Writeln('         abbreviated to a minimum of unique characters.');
Writeln('---------------------------------------------------------------');
End; (* DisplayCommand Procedure *)

(* +FILE+ LOCAL.PASMSCPM *)
(* ----------------------------------------------------------------- *)
(*  DisplayDir - Displays the directory for the mask given in the    *)
(*              input parameter string.                              *)
(* ----------------------------------------------------------------- *)
Procedure DisplayDir (Myfiles : Comstring) ;
var
  filename : comstring ;
  column,row : integer ;
Begin (* DisplayDir Procedure *)
if (length(myfiles)<1) or (Myfiles[length(myfiles)] in ['\','/',':'])
     then myfiles := myfiles + '*.*';
Clrscr;
If firstfile(myfiles,filename) then
    Begin (* found files *)
    writeln(' directory ',myfiles);
    write(filename);
    column := 21 ; row := 2;
    while nextfile(myfiles,filename) do
         begin (* list rest of files *)
         gotoxy(column,row);
         write (filename);
         column := column + 20 ;
         if column > 61 then
              begin row := row + 1 ; column := 1 ;  end ;
         end ; (* list rest of files *)
    End   (* found files *)
                                else
    writeln(' no file found ');
 writeln(' ');
 DisplayDiskStatus ;
 End ; (* DisplayDir Procedure *)

(* ----------------------------------------------------------------- *)
(*  EraseFiles - Erases a file or files from the disk.               *)
(*                                                                   *)
(* ----------------------------------------------------------------- *)
Procedure EraseFiles (Myfiles : Comstring) ;
var
    tempname : comstring ;
    tempfile : text ;
    column,row : integer ;
Begin (* EraseFile Procedure *)
While length(myfiles)<1 do
    Begin (* get file name *)
    write(' enter name of file to be erased > ');
    readln(myfiles);
    End ;
If firstfile(myfiles,tempname) then
    Begin (* found files *)
    Clrscr;
    writeln(' Erasing file(s) ',myfiles);
    assign(tempfile,prefixof(myfiles)+tempname);
    erase(tempfile);
    write(tempname);
    column := 21 ; row := 2;
    while nextfile(myfiles,tempname) do
         begin (* list rest of files *)
         gotoxy(column,row);
         assign(tempfile,prefixof(myfiles)+tempname);
         erase(tempfile);
         write (tempname);
         column := column + 20 ;
         if column > 61 then
              begin row := row + 1 ; column := 1 ;  end ;
         end ; (* list rest of files *)
    writeln(' ');
    writeln('The above file(s) have been erased. ');
    End   (* found files *)
                                else
    writeln(' no file found ');
End;  (* EraseFile *)

(* ----------------------------------------------------------------- *)
(*  RenameFile - Remame a file.                                      *)
(*                                                                   *)
(* ----------------------------------------------------------------- *)
Procedure RenameFile (Var Instring : Comstring) ;
var
    oldnames,oldname,newname : comstring ;
    tempfile : text ;
label exit ;
Begin (* RenameFile Procedure *)
If length(Instring)<1 then
    Begin (* get file name *)
    write(' Enter old file name  > ');
    readln(Instring);
    End ; (* get file name *)
If length(Instring)<1 then goto exit ;
oldnames := uppercase(GetToken(instring));
newname := uppercase(GetToken(instring));
If length(newname)<1 then
    Begin (* get new file name *)
    write(' Enter new file name  > ');
    readln(Instring);
    newname := uppercase(GetToken(instring));
    End ; (* get new file name *)
If firstfile(oldnames,oldname) then
    Begin (* found File *)
    assign(tempfile,prefixof(oldnames)+oldname);
    Rename(tempfile,newname);
    writeln(' ');
    writeln('File ',oldname, ' renamed to ',newname);
    End   (* found File *)
                                else
    writeln(' No file  - ',oldname);
exit:
End;  (* RenameFile *)

(* ----------------------------------------------------------------- *)
(*  DisplayFile - display a file.                                    *)
(*                                                                   *)
(* ----------------------------------------------------------------- *)
Procedure DisplayFile (Myfile : Comstring) ;
var
    oldname,newname : comstring ;
    tempfile : text ;
    achar : char ;
label exit ;
Begin (* DisplayFile Procedure *)
If length(Myfile)<1 then
    Begin (* get file name *)
    write(' Enter  file name  > ');
    readln(Myfile);
    End ; (* get file name *)
If length(Myfile)<1 then goto exit ;
Assign(tempfile,myfile);
{ $I- } Reset(tempfile); { $I+ }
If IOResult = 0  then
    Begin (* found File *)
    Clrscr ;
    While not eof(tempfile) do
       begin (* Display file *)
       Read(tempfile,achar);
       Write(achar);
       end;  (* Display file *)
    writeln(' ');
    End   (* found File *)
                             else
    writeln(' No file  - ',Myfile);
exit:
End;  (* DisplayFile *)

(* +FILE+ REMOTE.PASMSCPM *)
(* ----------------------------------------------------------------- *)
(*  RemoteProc - Remote procedure.                                   *)
(* ----------------------------------------------------------------- *)
Procedure RemoteProc (var Instring : Comstring) ;
Const
    Gsubtype : String[18] =  'CDEFHIJKLMPQRTUVW' ;
TYPE
    RemoteCommandindex = (
                  rem_zero,
                  rem_cwd,
                  rem_directory,
                  rem_erase,
                  rem_finish,
                  rem_help,
                  rem_login,
                  rem_journal,
                  rem_copy,
                  rem_logout,
                  rem_message,
                  rem_program,
                  rem_query,
                  rem_rename,
                  rem_type,
                  rem_usage,
                  rem_variable,
                  rem_who);
Var
    ErrorMsg : comstring ;
    Rem_CommandTable : String[255] ;
    Rem_Command : comstring ;
    Index : integer ;
    Receiving : boolean ;
    Retries : integer ;
    j,CharCount,Bit8 : integer ;
(* ----------------------------------------------------------------------- *)
Procedure AddParmString ;
    Begin (* Add parms *)
    If length(instring) > 0 then
         Begin (* add parameter *)
         SendData[OutdataCount+1] := length(instring) + $20 ;
         For i := 1 to length(instring) do
              SendData[OutdataCount+1+i] := ord(instring[i]) ;
         OutdataCount := OutdataCount + length(instring) + 1 ;
         Instring := '';
         End ;
    End ; (* Add parms *)

(* *********************************************************************** *)
Begin (* RemoteProc *)
rem_commandtable  := concat('bad       ',
                       'CWD       ',
                       'DIRECTORY ',
                       'ERASE     ',
                       'FINISH    ',
                       'HELP      ',
                       'LOGIN     ',
                       'JOURNAL   ',
                       'COPY      ',
                       'LOGOUT    ',
                       'MESSAGE   ',
                       'PROGRAM   ',
                       'QUERY     ',
                       'RENAME    ',
                       'TYPE      ',
                       'USAGE     ',
                       'VARIABLE  ',
                       'WHO       ') ;
    rem_command := ' ' + Uppercase(GETTOKEN(instring));
    if rem_command = ' HOST' then
         Begin (* Host Command *)
         End   (* Host Command *)
                             else
         Begin (* Generic Kermit Commands *)
         index := POS(rem_command,rem_commandtable) div 10 ;
         if index = 0 then
              Begin (* list commands *)
              Writeln (rem_command,' - Invalid REMOTE command. ');
              Writeln('    Valid REMOTE Commands are as follows: ');
              Writeln('CWD       directory     - Change Working Directory');
              Writeln('DIRECTORY filespec      - Directory               ');
              Writeln('ERASE     filespec      - Erase (delete) a file   ');
              Writeln('FINISH                  - Terminate Kermit server ');
              Writeln('HELP      keywords      - Help from server        ');
              Writeln('LOGIN     userid        - Login                   ');
              Writeln('JOURNAL   command       - Transaction Logging     ');
              Writeln('COPY      filespec      - Copy file               ');
              Writeln('LOGOUT                  - Logout the remote host  ');
              Writeln('MESSAGE   destination   - Message                 ');
              Writeln('PROGRAM   program-name  - Program execution       ');
              Writeln('QUERY                   - Query server status     ');
              Writeln('RENAME    old-filespec  - Rename file             ');
              Writeln('TYPE      filespec      - Type (list) file        ');
              Writeln('USAGE     area          - Disk Usage Query        ');
              Writeln('VARIABLE  command       - Set or Query a Variable ');
              Writeln('WHO       userid        - Who is logged in        ');
              End   (* list commands *)
                      else
              Begin (* Issue Remote command Request *)
    (* Send Init Packet *)
    OutPacketType := Ord('I');
    PutInitPacket ;
    SendPacket ;
    STATE := R ;
    RECEIVING := TRUE ;
    BreakState := NoBreak ;
    RETRIES := 10 ;       (* Up to 10 retries allowed. *)

    WHILE RECEIVING DO  CASE STATE OF

(* R ------ Initial receive State ------- *)
(* Valid types  - Y *)
R : BEGIN (* Initial Receive State  *)
    If ( Not RecvPacket) or (InPacketType=Ord('N')) then Resendit(10)
                                                    else
         Begin (* Send Request *)
         If InPacketType=Ord('Y') then GetInitPacket ;
         If series1 then waitxon := false ;
         OutPacketType := Ord('G') ;
         SendData[1] := Ord(GSubtype[index]) ;
         OutDataCount :=  1 ;
         OUTSEQ   := OUTSEQ + 1 ;
         IF OUTSEQ >= 64 THEN OUTSEQ := 0;
         Case RemoteCommandIndex(index) of
     rem_zero:   ;
      rem_cwd:     Begin (* Change Working Directory *)
                   AddParmString;
                   Writeln (' Enter Password ') ;
                   Readln(instring);
                   AddParmString ;
                   End ; (* Change Working Directory *)
rem_directory:     AddParmString;
    rem_erase:     AddParmString;
   rem_finish:     AddParmString;
     rem_help:     AddParmString;
    rem_login:     Begin (* Login *)
                   AddParmString;
                   Writeln (' Enter Password ') ;
                   Readln(instring);
                   AddParmString ;
                   Writeln (' Enter Account Number ') ;
                   Readln(instring);
                   AddParmString ;
                   End ; (* Login *)
  rem_journal:     Begin (* Journal *)
                   AddParmString;
                   Writeln (' Enter Journal Argument ') ;
                   Readln(instring);
                   AddParmString ;
                   End ; (* Jounral *)
     rem_copy:     Begin (* Copy file *)
                   AddParmString;
                   Writeln (' Enter destination ') ;
                   Readln(instring);
                   AddParmString ;
                   End ; (* Copy file *)
   rem_logout:     AddparmString;
  rem_message:     Begin (* Message *)
                   AddParmString;
                   Writeln (' Enter Message text ') ;
                   Readln(instring);
                   AddParmString ;
                   End ; (* Message *)
  rem_program:     Begin (* Program *)
                   AddParmString;
                   Writeln (' Enter Program commands ') ;
                   Readln(instring);
                   AddParmString ;
                   End ; (* Program *)
    rem_query:     ;
   rem_rename:     Begin (* Rename file *)
                   AddParmString;
                   Writeln (' Enter New Name ') ;
                   Readln(instring);
                   AddParmString ;
                   End ; (* Rename file *)
     rem_type:     AddParmString;
    rem_usage:     AddParmString;
 rem_variable:     Begin (* Variable *)
                   AddParmString;
                   Writeln (' Enter First Argument ') ;
                   Readln(instring);
                   AddParmString ;
                   Writeln (' Enter Second Argument ') ;
                   Readln(instring);
                   AddParmString ;
                   End ; (* Variable *)
      rem_who:     Begin (* Who  *)
                   AddParmString;
                   Writeln (' Enter Options ') ;
                   Readln(instring);
                   AddParmString ;
                   End ; (* Who *)
         End ; (* Case *)

         SendPacket ;
         STATE := RF ;
         End ; (* Send Request *)

    END ; (* Initial Receive State  *)


    (* RF ----- Receive Filename State ------- *)
    (* Valid received msg type  : S,Z,F,B     *)
    RF: IF (NOT RECVPACKET) OR (InPacketType=Ord('N')) then  ReSendit(10)
                                                       else
        (* Get a packet *)
        IF (InPacketType = Ord('Y')) or (InPacketType=Ord('E')) then
              BEGIN (* Got simple reply  *)
              For i := 1 to InDataCount do
                   Write(Chr(RecvData[i])) ;
              Writeln(' ');
              RECEIVING := false
              END   (* Got simple reply *)
                                   else
        IF InPacketType = Ord('S') then
              Begin GetInitPacket; PutInitPacket; SendPacket; End else
        IF (InPacketType = Ord('X')) or (InPacketType = Ord('F')) then
              BEGIN (* Got file header *)
              For i := 1 to InDataCount do
                   Write(Chr(RecvData[i])) ;
              Writeln(' ');
              STATE := RD ;
              SendPacketType('Y');
              END   (* Got file header *)
                                   else
         BEGIN (* Not S,F,B,Z packet *)
         STATE := A ;   (* ABORT if not a S,F,B,Z type packet *)
         ABORT := NOT_SFBZ ;
         END ; (* Not S,F,B,Z packet *)


    (* RD ----- Receive Data State ------- *)
    (* Valid received msg type  : D,Z      *)
    RD: IF (NOT RECVPACKET) OR (InPacketType=Ord('N')) then ReSendit(10)
                                                       else
        (* Got a good packet *)
        IF InPacketType = Ord('D') then
              BEGIN (* Receive data *)
        (*    WRITELN ('RECEIVE data ');  *)
              I := 1 ;
              WHILE I <= InDataCount DO
                 BEGIN (* Write Data to file  *)
                   IF RecvData[I] = RepChar   then
                        BEGIN (* Repeat char   *)
                        I := I+1 ;
                        charcount := RecvData[I] - 32 ;
                        I := I + 1 ;
                        For j := 1 to charcount - 1 do
                             Write(Chr(RecvData[i]));
                        END ;  (* Repeat char  *)
                   IF RecvData[I] = Bit8Quote then
                        BEGIN (* 8TH BIT QUOTING  *)
                        I := I+1 ;
                        BIT8 := $80 ;
                        END   (* 8TH BIT QUOTING  *)
                                            else
                        BIT8 := 0 ;
                   IF RecvData[I] = CntrlQuote then
                        BEGIN (* CONTROL character *)
                        I := I+1 ;
                        IF RecvData[I] = $3F then   (* Make it a del *)
                                                   RecvData[I] := $7F
                                             else
                        IF RecvData[I] >= 64 then   (* Make it a control *)
                                          RecvData[I] := RecvData[I] - 64 ;

                       END ; (* CONTROL character *)
                   RecvData[I] := RecvData[I] + BIT8 ;
                   Write(Chr(RecvData[i])) ;
                   I := I + 1 ;
                 END ; (* Write Data to File *)
              Case Breakstate of
                   NoBreak : SendPacketType('Y');
                   BC : RECEIVING:=false ;
                   BE : SendPacketType('N') ;
                   BX : BreakAck('X') ;
                   BZ : BreakAck('Z') ;
               End; (* Case BreakState *)
              END   (* Receive data *)
                              else
         IF (InPacketType = Ord('F')) or (InPacketType=Ord('X')) then
              BEGIN (* repeat *)
              OutSeq := OutSeq - 1 ;
              SendPacketType('Y') ;
              END   (* repeat *)
                                                                   else
         IF InPacketType = Ord('Z') then SendPacketType('Y')
                                    else
         IF InPacketType = Ord('B') then Receiving := False
                                    else
         BEGIN (* Not D,Z packet *)
         STATE := A;   (* ABORT - Type not  D,Z, *)
         ABORT := NOT_DZ ;
         END ; (* Not D,Z packet *)


    (* C ----- COMPLETED  State ------- *)
     C:  BEGIN (* COMPLETED Receiving *)
         SendPacketType('Y');
         RECEIVING := FALSE ;
         END ; (* COMPLETED Receiving *)

    (* A ----- A B O R T  State ------- *)
     A:  BEGIN (* Abort Sending *)
         RECEIVING := FALSE ;
         (* SEND ERROR packet *)
         OutSeq   := 0 ;
         ErrorMsg :=' Abort while receiving data' ;
         OutDataCount := length(ErrorMsg);
         for i := 1 to length(ErrorMsg) do
              SendData[i] := Ord(ErrorMsg[i]) ;
         OutPacketType := Ord('E');
         SENDPACKET ;
         END ; (* Abort Sending *)

         END ; (* CASE of STATE *)
              End ; (* Issue Remote command Request *)
         End  ;  (* Generic Kermit Commands *)
End ; (* RemoteProc *)

(* +FILE+ MISCCOMM.PASMSCPM *)
(* ================================================================== *)
(* LOGIT - creates a Log file to record all incoming data from the    *)
(*       remote line.                                                 *)
(*           The file name is specified in the Parameter .            *)
(*               if no parameter specified logging is turned off.     *)
(* ================================================================== *)
Procedure Logit  (filename : comstring);
Begin (* Logit Procedure *)
If (length(filename) < 3) or (filename='OFF') then
    Begin (* Turn off Logging *)
    Logging := false ;
    Close (Logfile);
    Writeln (' Logging is turned off ');
    End   (* Turn off Logging *)
                        else
    Begin (* Turn on Logging *)
    If Logging then Close (Logfile);
    Logging := True ;
    Assign(Logfile,Filename);
    Rewrite(Logfile);
    Writeln(' Logging data to file ',filename);
    LogName := filename ;
    End ; (* Turn on Logging *)
End ; (* Logit Procedure)

(* ================================================================== *)
(* Takeit - read commands from a file and executes them.              *)
(*          if no file specified or file is not there if does nothing *)
(* ================================================================== *)
Procedure Takeit  (filename : comstring);
Begin (* Takeit Procedure *)
If length(filename) > 1 then
    If Firstfile(filename,dummy) then
         Begin (* Active file *)
         Writeln ('Activating Command file ',filename);
         ActiveCommandfile := true ;
         Assign(Commandfile,filename);
         Reset(Commandfile);
         End  (* Active file *)
                                else
         Writeln('No file ',filename) ;
End ; (* Takeit Procedure)

(* ================================================================== *)
(* QuitExit    - Terminates the KERMIT.                               *)
(*             the QuitOptions are:                                   *)
(*                  LOCAL,REMOTE,DISCONnect,ALL                       *)
(*               if LOCAL or noparms only the local kermit terminates.*)
(*               if REMOTE then  only the remote kermit terminates.   *)
(*               if DISCONect then the remote kermit is terminated    *)
(*                       and the remote is logged off.                *)
(*               if ALL  then both kermits are terminated and remote  *)
(*                        is logged off.                              *)
(*                                                                    *)
(* ================================================================== *)
Procedure QuitExit  (QuitOption : comstring);
Const
    QuitTable : String[35] = '       LOCAL  REMOTE DISCON ALL    ' ;
Type QuitType = (zero,local,remote,discon,all);
Var
    Qix : integer  ;
Begin (* QuitExit Procedure *)
QuitOption := Uppercase(Concat(' ',QuitOption));
Qix := Pos(QuitOption,QuitTable) div 7 ;
Case QuitType(Qix) of    (* Quit Type *)
 zero,
 local:  Running := false ;
 remote :
         Begin (* terminate remote kermit *)
        (* Send a Finish packet *)
         OutDataCount := 1 ;
         OutSeq := OutSeq + 1 ;
         If OutSeq > 64 then OutSeq := 0 ;
         OutPacketType := Ord('G');
         SendData[1] := Ord('F');
         WaitXon := False ;
         SendPacket ;
         If RecvPacket and (InPacketType = Ord('Y')) then
               Writeln (' Remote Kermit terminated. ')
                                                     else
               Writeln(' Unable to terminate Remote Kermit. ');
         End ; (* terminate remote kermit *)
discon,
all:
         Begin (* logoff Remote  *)
         (* Send a Logoff packet *)
         OutDataCount := 1 ;
         OutSeq := OutSeq + 1 ;
         If OutSeq > 64 then OutSeq := 0 ;
         OutPacketType := Ord('G');
         SendData[1] := Ord('L');
         WaitXon := false ;
         SendPacket ;
         If RecvPacket and (InPacketType = Ord('Y')) then
              Writeln (' Remote host is logging off ')
                                                     else
              Writeln(' Remote host unable to execute a log off ');
         If (Qix = Ord(all))  then Running := False ;
         End;  (* Logoff Remote *)
    End ; (* Case Quit Type *)
End; (* QuitExit Procedure *)

(* +FILE+ TYPEDEF.PASDUMMY *)
(* TYPEDEF.SYS - Dummy  Include file  for non-graphics terminal simulation *)

(* +FILE+ GRAPHIX.PASDUMMY *)
(* GRAPHIX.SYS - Dummy  Include file  for non-graphics terminal simulation *)

(* +FILE+ KERNEL.PASDUMMY *)
(* KERNEL.SYS - Dummy  Include file  for non-graphics terminal simulation *)

(* +END-OF-FILES+ *)
