home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / TURBOPAS / QKKER25.ARK / QKKER.PAS < prev   
Pascal/Delphi Source File  |  1986-11-25  |  223KB  |  5,202 lines
  1. (* QK KERMIT, Turbo Pascal *)
  2. (* This file is the concatenation of the following files.  Each begins *)
  3. (* with a comment line containing +FILE+ followed by the file name. *)
  4. (* KERMIT.PASMSCPM *)
  5. (* UTILITY.PASMSCPM *)
  6. (* SYSFUNC.PASMS *)
  7. (* SYSFUNC.PASCPM *)
  8. (* MODEMPRO.PASMS *)
  9. (* MODEMPRO.PASAPPLE *)
  10. (* MODEMPRO.PASKAYII *)
  11. (* DEFWORDS.PASMSCPM *)
  12. (* READCHAR.PASMSCPM *)
  13. (* PACKET.PASMSCPM *)
  14. (* SENDFILE.PASMS *)
  15. (* SENDFILE.PASCPM *)
  16. (* RECVFILE.PASMSCPM *)
  17. (* CONNECT.PASVT52 *)
  18. (* CONNECT.PASADM3A *)
  19. (* CONNECT.PASVT100 *)
  20. (* CONNECT.PASTEK10 *)
  21. (* SETSHOW.PASMSCPM *)
  22. (* LOCAL.PASMSCPM *)
  23. (* REMOTE.PASMSCPM *)
  24. (* MISCCOMM.PASMSCPM *)
  25. (* TYPEDEF.PASDUMMY *)
  26. (* GRAPHIX.PASDUMMY *)
  27. (* KERNEL.PASDUMMY *)
  28. (* The last line of this file should say +END-OF-FILES+ *)
  29.  
  30. (* +FILE+ KERMIT.PASMSCPM *)
  31. {$C-}
  32. Program Kermit ;
  33. (* ***************************************************************** *)
  34. (*                                                                   *)
  35. (* Author - Victor Lee, Queen's University, Kingston, Ontario        *)
  36. (*          Comments and problem can be sent to VIC@QUCDN.BITNET     *)
  37. (*          Phone - 613-547-6115                                     *)
  38. (*          Contributions from Jeff Duncan                           *)
  39. (* Date -   1985 January                                             *)
  40. (*      -   1985 May  1    first official release                    *)
  41. (*      -        June 28   Add run command , fix logging             *)
  42. (*      -        July  5   Fix Asfile bug.                           *)
  43. (*               July 10   Fix Binary Transfer bug (no repeatchar)   *)
  44. (*               July 17   change write(ch) to ritechar to fix bug   *)
  45. (*                         with keyboard input.                      *)
  46. (*               July 23   Add I/O error handling,fix initparm bug,  *)
  47. (*                         restrict source to 80 columns.            *)
  48. (*               Aug 7     Use $C- option,  Eliminate the use of     *)
  49. (*                         ritechar procedure. Add VT100 terminal    *)
  50. (*                         simulation code                           *)
  51. (*               Sept 9    Minor cleanup of code. Retry for reading  *)
  52. (*                         Keytable file.                            *)
  53. (*               Sept 18   Set version number.                       *)
  54. (*               Sept 30   Check seqnum on recieved data packets.    *)
  55. (*               Nov. 01   Reenable auto remote command.             *)
  56. (*               Dec. 16   Insert Mode ( FatCursor indicator )       *)
  57. (*               Dec. 20   Sub Directory commands and features       *)
  58. (*               Dec. 23   Audio Toggle .                            *)
  59. (* Date -   1986 Jan.  7   Allow Packet Parameter specifications.    *)
  60. (*               Jan. 14   Apl character set selection.              *)
  61. (*               Jan. 20   8bit quote and repeat char. bug fixed.    *)
  62. (*               Jan. 22   Remove some of the system dependant code  *)
  63. (*                         from KERMIT.PAS.                          *)
  64. (*               Jan. 29   Break key - to us ALT F10 .               *)
  65. (*                                                                   *)
  66. (* ***************************************************************** *)
  67. (*  Utility Procedures                                               *)
  68. (*       HEX                                                         *)
  69. (*       UpperCase                                                   *)
  70. (*       GETTOKEN                                                    *)
  71. (*       NewAsFile                                                   *)
  72. (* SysFunc Procedures  - These are operating system dependent        *)
  73. (*       KeyChar                                                     *)
  74. (*       CursorPosition                                              *)
  75. (*       CursorUp,CursorDown,CursorRight,CursorLeft                  *)
  76. (*       LocalScreen,RemoteScreen                                    *)
  77. (*       FirstFile,Nextfile                                          *)
  78. (*       DefaultDrive                                                *)
  79. (*       SetDefaultDrive                                             *)
  80. (*       DisplayDiskStatus                                           *)
  81. (*       ExecFile                                                    *)
  82. (* Modem Procedures   -   These are Machine dependent procedures     *)
  83. (*       InitModem                                                   *)
  84. (*       SetModem                                                    *)
  85. (*       ResetModem                                                  *)
  86. (*       DialModem                                                   *)
  87. (*       RecvChar                                                    *)
  88. (*       SendChar                                                    *)
  89. (*                                                                   *)
  90. (* Define Word Procedures                                            *)
  91. (*       AssignDefWord                                               *)
  92. (*       DisplayDefWords                                             *)
  93. (*       CheckDefWords                                               *)
  94. (*       WriteDefWord                                                *)
  95. (*       DEFINEWORD                                                  *)
  96. (*       LoadDefWords                                                *)
  97. (*       SaveDefWords                                                *)
  98. (* Read Character Procedure                                          *)
  99. (*       ReadChar                                                    *)
  100. (* Packet Procedures                                                 *)
  101. (*       SENDPACKET                                                  *)
  102. (*       RECVPACKET                                                  *)
  103. (*       RESENDIT                                                    *)
  104. (*       SENDACK                                                     *)
  105. (*                                                                   *)
  106. (*  ------------------ COMMAND  PROCEDURES  --------------------     *)
  107. (*                                                                   *)
  108. (*       SENDFILE  - Sends a file to another computer.               *)
  109. (*       RECVFILE  - Receive a file from another computer.           *)
  110. (*       CONNECTION- Simulate a dumb terminal.                       *)
  111. (* SetShow Procedures                                                *)
  112. (*       SHOWIT    - Display the options .                           *)
  113. (*       SETIT     - Set the options.                                *)
  114. (*       DisplayCommands - Displays the commands available.          *)
  115. (*                                                                   *)
  116. (* Local Procedures                                                  *)
  117. (*      DisplayDir  - Display directory.                             *)
  118. (*      EraseFiles  - Erase files.                                   *)
  119. (*      RenameFiles - Rename files.                                  *)
  120. (*      DisplayFile - Display file (TYPE file ).                     *)
  121. (*     (RunFile     - Run a program  ( See SYSFUNC procedures ) )    *)
  122. (*                                                                   *)
  123. (*       REMOTEPRO  - Remote request procedures                      *)
  124. (* Misccomm Procedures                                               *)
  125. (*       Logit      - log the session to a file.                     *)
  126. (*       Takeit     - take commands from a file.                     *)
  127. (*       QuitExit   - terminate kermits and log out.                 *)
  128. (*                                                                   *)
  129. (* ***************************************************************** *)
  130. CONST
  131.     VERSION   = '2.5 ' ;  (* <<<<<<<<<<<< V E R S I O N <<<<<<<<<<< *)
  132.     Date      = '1986 January 29  ' ;
  133.  
  134.     LocalChar = $1C ;   (* control backslash       ^\  *)
  135.     BreakChar = $1D ;   (* control right bracket   ^]  *)
  136.  
  137.     SOH  = $01 ;        (* Start of Header *)
  138.     EOT  = $04 ;        (* End of transmission *)
  139.     BS   = $08 ;        (* Back Space *)
  140.     Xon  = $11 ;
  141.     Xoff = $13 ;
  142.     ESC  = $1B ;
  143.     DEL  = $7F ;
  144.  
  145. TYPE
  146.     layouts = (one,two,three,four,five,six,seven,eight,nine,ten) ;
  147.     Commandindex = (
  148.                   zero,
  149.                   connect,
  150.                   send,
  151.                   receive,
  152.                   setparm,
  153.                   status,
  154.                   directory,
  155.                   erase,
  156.                   rename,
  157.                   typefile,
  158.                   runfile,
  159.                   remote,
  160.                   log,
  161.                   take,
  162.                   define,
  163.                   help,
  164.                   mkdir,
  165.                   rmdir,
  166.                   chdir,
  167.                   audio,
  168.                   parms,
  169.                   quit,
  170.                   null );
  171.     comstring = string[80] ;
  172.     Wstring   = string[10] ;
  173.  
  174.     STATETYPE = (S,SF,SD,SZ,SB,C,A,R,RF,RD) ;
  175.     ABORTTYPE = (NOSOH,BADSF,NOT_S,NOT_SFBZ,NOT_DZ);
  176.     BREAKTYPE = (NOBREAK,BX,BZ,BC,BE);
  177.     PACKET = PACKED ARRAY[1..255] OF BYTE ;
  178.     ParityType = (OddP,EvenP,MarkP,NoneP);
  179.     DefPointer = ^DefineRec ;
  180.     DefineRec = Record
  181.                 Link : DefPointer ;
  182.                 DefWord : Wstring ;
  183.                 DefString : comstring ;
  184.                 End ;
  185.  
  186. VAR
  187.     STATE          : STATETYPE ;
  188.     ABORT          : ABORTTYPE ;
  189.     BREAKSTATE     : BREAKTYPE ;
  190.     RetryCount     : Integer ;
  191.  
  192.     (* Packet variables *)                           (* format   *)
  193.     (* Receive       Send     *)                     (* SOH      *)
  194.        InCount,      OutCount      : BYTE ;          (* COUNT    *)
  195.        INSEQ,        OUTSEQ        : BYTE ;          (* SEQNUM   *)
  196.        INPACKETTYPE, OUTPACKETTYPE : BYTE ;          (* TYPE     *)
  197.        RecvData,     SendData      : PACKET ;        (* DATA...  *)
  198.        CHECKSUM                    : INTEGER ;       (* CHECKSUM *)
  199.        CRC                         : INTEGER ;       (* CRC      *)
  200.  
  201.        InDataCount,  OutDataCount  : BYTE ;          (* dataCOUNT *)
  202.  
  203.     (* Initialization packet parameters *)
  204.     PacketSize,Timeout,NumPad,PadChar,EndChar,StartChar,
  205.     CntrlQuote,Bit8Quote,Checktype,RepChar     : Byte ;
  206.  
  207.     (* Operational Options Parameters *)
  208.     LocalEcho   : Boolean ;
  209.     Series1     : Boolean ;
  210.     XonXoff     : Boolean ;
  211.     BaudRate    : Integer ;
  212.     Parity      : ParityType ;
  213.     PrimaryPort : Boolean ;
  214.     AudioFlag,AplFlag,ParmFlag  : Boolean ;
  215.  
  216.     (* Execution control flags *)
  217.     WaitXon, Running, Logging, ForPrinter,
  218.     ActiveCommandFile, GotSOH,DTRcheck               : Boolean ;
  219.  
  220.     I                      : INTEGER ;
  221.     inputstring            : comstring ;
  222.     command                : Wstring ;
  223.     commandtable,parmtable : string[255];
  224.     LogName,dummy          : comstring ;
  225.     Logfile,CommandFile    : Text ;
  226.  
  227. {$I Utility.Pas }
  228. {$I SYSFUNC.PAS }
  229. {$I MODEMPRO.PAS }
  230. {$I ReadChar.Pas }
  231. {$I DefWords.pas }
  232. {$I packet.pas }
  233.  
  234. (* ----------------------------------------------------------------- *)
  235. (* SENDFILE - Procedure                                              *)
  236. (* ----------------------------------------------------------------- *)
  237. {$I SENDFILE }
  238.  
  239. (* ----------------------------------------------------------------- *)
  240. (* RECVFILE - Procedure                                              *)
  241. (* ----------------------------------------------------------------- *)
  242. {$I RECVFILE }
  243.  
  244. (* ----------------------------------------------------------------- *)
  245. (* Graphics - Procedures . This are only required for graphics.      *)
  246. (* ----------------------------------------------------------------- *)
  247. {$I TYPEDEF }
  248. {$I GRAPHIX }
  249. {$I KERNEL }
  250. {*I POLYGON }
  251. {*I HATCH }
  252.  
  253. (* ----------------------------------------------------------------- *)
  254. (* CONNECTION - Procedure                                            *)
  255. (* ----------------------------------------------------------------- *)
  256. {$I CONNECT }
  257.  
  258. (* ----------------------------------------------------------------- *)
  259. (* SHOWOPTIONS and SETOPTIONS and  DisplayCommand - Procedures       *)
  260. (* ----------------------------------------------------------------- *)
  261. {$I SETSHOW }
  262.  
  263. (* ----------------------------------------------------------------- *)
  264. (* Local Procedures - Directory, Erase, Rename, Typefile             *)
  265. (* ----------------------------------------------------------------- *)
  266. {$I LOCAL }
  267.  
  268. (* ----------------------------------------------------------------- *)
  269. (* Remote Procedures                                                 *)
  270. (* ----------------------------------------------------------------- *)
  271. {$I REMOTE }
  272.  
  273. (* ----------------------------------------------------------------- *)
  274. (* MiscCommands - LOG , Exit                      - Procedures       *)
  275. (* ----------------------------------------------------------------- *)
  276. {$I MISCCOMM }
  277.  
  278. (* ***************************************************************** *)
  279. (* ********    Outter Block of Kermit ****************************** *)
  280. (* ***************************************************************** *)
  281.  
  282.  
  283. BEGIN (* KERMIT *)
  284. commandtable := concat('bad       ',
  285.                        'CONNECT   ',
  286.                        'SEND      ',
  287.                        'RECEIVE   ',
  288.                        'SET       ',
  289.                        'STATUS    ',
  290.                        'DIRECTORY ',
  291.                        'ERASE     ',
  292.                        'RENAME    ',
  293.                        'TYPE      ',
  294.                        'RUN EXEC  ',
  295.                        'REMOTE    ',
  296.                        'LOG       ',
  297.                        'TAKE      ',
  298.                        'DEFINE    ',
  299.                        'HELP  ?   ',
  300.                        'MKDIR MD  ',
  301.                        'RMDIR RD  ',
  302.                        'CHDIR CD  ',
  303.                        'AUDIO     ',
  304.                        'PARMS     ',
  305.                        'QUIT      ',
  306.                        'DO LOCAL  ') ;
  307.  
  308.  (* Default Packet settings *)
  309.  PacketSize := 94 ;     (* PACKET size 94 maximum *)
  310.  Timeout    := 60 ;     (* Time out in seconds *)
  311.  NumPad     := 00 ;     (* Number of Pad characters *)
  312.  PadChar    := 00 ;     (* Padding Character *)
  313.  EndChar    := 13 ;     (* End of line char - CR *)
  314.  StartChar  := 01 ;     (* Start of Packet char - SOH *)
  315.  CntrlQuote := 35 ;     (* # *)
  316.  Bit8Quote  := 38 ;     (* & *)
  317.  CheckType  := 49 ;     (* 1 *)
  318.  RepChar    := 00 ;     (* ~ *)
  319.  
  320.  (* Default Settings *)
  321.  Baudrate    := DefaultBaud ;
  322.  Parity      := EvenP ;
  323.  XonXoff     := False ;
  324.  Series1     := True ;
  325.  LocalEcho   := False ;
  326.  PrimaryPort := True ;
  327.  AudioFlag   := False ;
  328.  AplFlag     := False ;
  329.  ParmFlag    := False ;
  330.  
  331. (* Set control flow flags *)
  332. connected         := false ;
  333. logging           := false ;
  334. ForPrinter        := false ;
  335. ActiveCommandfile := false ;
  336. GotSOH            := false ;
  337. DTRcheck          := true ;
  338. Running := true;
  339.  
  340. DefList := Nil ;
  341. LoadDefWords ; NewDefs := false ;
  342. InitModem ;
  343.  
  344. inputstring := commandline ;
  345. (* writeln(commandline); *)
  346.  
  347. ReadKeyTable;
  348.  
  349.    Writeln('          * ======================================== * ');
  350.    Writeln('          *  Queen''s University  -  KERMIT /',termtype,' * ');
  351.    Writeln('          *                                          * ');
  352.    Writeln('          *      Version ',version,Gversion,' - ',Date,'  * ');
  353.    Writeln('          *      Author   -  Victor Lee              * ');
  354.    Writeln('          *      Graphics ',Graphics,'  * ');
  355.    Writeln('          * ======================================== * ');
  356.  
  357. While Running Do
  358.     Begin (* Command Loop *)
  359.     if audioflag then
  360.        Begin sound(1500);delay(50);sound(300);delay(50);nosound; end ;
  361.     if length(inputstring)<1 then
  362.          if ActiveCommandFile then
  363.               Begin (* Get command from file *)
  364.               Readln(Commandfile,inputstring);
  365.               ActiveCommandFile := not Eof(commandfile);
  366.               End
  367.                              else
  368.              Begin (* ask for input *)
  369.              Write('QK-Kermit>');              (* PROMPT for input *)
  370.              readln(inputstring);
  371.              End ; (* ask for input *)
  372.  
  373.     command := Uppercase(GETTOKEN(inputstring));
  374.     CheckDefWords(DefList,command,Inputstring);
  375.     command := ' ' + command ;
  376.     WaitXon := false ;
  377.  
  378.     case commandindex(POS(command,commandtable) div 10 ) of
  379.           zero    : If length(command)>1 then
  380.                         Begin (* bad command *)
  381.                         Writeln(' Invalid Command >>>>> ',Command,' <<<<<');
  382.                         Writeln('--- Type HELP to see valid Commands.--- ');
  383.                         End ; (* bad command *)
  384.           connect  : Begin
  385.                      If length(inputstring) > 1 then SetOptions(inputstring);
  386.                      CONNECTION ;
  387.                      End;
  388.           send     : SENDFILE (inputstring);
  389.           receive  : RECVFILE (inputstring );
  390.           setparm  : SetOptions(inputstring);
  391.           status   : ShowOptions ;
  392.           directory: DisplayDir (GetToken(inputstring));
  393.           erase    : EraseFiles (GetToken(inputstring));
  394.           rename   : RenameFile (inputstring);
  395.           typefile : DisplayFile (GetToken(inputstring));
  396.           runfile  : EXECFile (inputstring);
  397.           remote   : RemoteProc (inputstring);
  398.           log      : Logit  (GetToken(inputstring));
  399.           take     : Takeit (GetToken(inputstring));
  400.           define   : DefineWord(inputstring);
  401.           help     : DisplayCommands ;
  402.           mkdir    : MkdirFunc (GetToken(inputstring)) ;
  403.           rmdir    : RmdirFunc (GetToken(inputstring)) ;
  404.           chdir    : ChdirFunc (GetToken(inputstring)) ;
  405.           audio    : AudioFlag := AudioFlag xor True ;
  406.           parms    : ParmFlag := ParmFlag xor True ;
  407.           quit     : QuitExit (UpperCase(GetToken(inputstring)));
  408.           null     : ;
  409.        end ;  (*  Case commandindex *)
  410.     End ; (* Command Loop *)
  411.  
  412.  If Logging then Close(Logfile);
  413.  If NewDefs then SaveDefWords ;
  414.  If audioflag then
  415.     begin sound(1500);delay(200);sound(3000);delay(200);end ;
  416.  If connected then ResetModem;
  417.  If audioflag then
  418.     begin sound(2000);delay(200); nosound; end ;
  419.  ClrScr;
  420.  Gotoxy(20,10); Write( ' G O O D - B Y E ');
  421.  
  422. END.  (* KERMIT *)
  423.  
  424. (* +FILE+ UTILITY.PASMSCPM *)
  425. (* ============ Begining of   U T I L I T Y   Procedures ============ *)
  426. Type String2 = String[2];
  427.  
  428. (* ----------------------------------------------------------------- *)
  429. (* GETTOKEN - Function                                               *)
  430. (* ----------------------------------------------------------------- *)
  431. Function  GETTOKEN ( var instring : comstring) : comstring  ;
  432. Var
  433.     pt : byte ;
  434.  
  435.     Begin (* GETTOKEN *)
  436.     While (instring[1] = ' ') and (length(instring)>1) do
  437.           Delete(instring,1,1);    (* eliminate leading blanks *)
  438.     pt := POS(' ',instring);
  439.     if pt = 0 then pt := length(instring)+1 ;
  440.     GETTOKEN := copy(instring,1,pt-1);
  441.     DELETE(instring,1,pt);
  442.     End ; (* GETTOKEN *)
  443.  
  444. (* ----------------------------------------------------------------- *)
  445. (* UpperCase - Function                                               *)
  446. (* ----------------------------------------------------------------- *)
  447. Function UpperCase ( instring : comstring) : comstring ;
  448. Var
  449.     ix,len : integer ;
  450.  
  451.     Begin (* UpperCase *)
  452.     len := length(instring) ;
  453.     for ix := 1 to len do instring[ix] := Upcase(instring[ix]);
  454.     UpperCase := instring ;
  455.     End ; (* UpperCase *)
  456.  
  457. (* ----------------------------------------------------------------- *)
  458. (* CRCheck - Procedure - generates a CCITT CRC using the polynominal *)
  459. (*                       X^16 + X^12 + X^5 + 1                       *)
  460. (* Side Effects : Updates the global variable CRC which should be    *)
  461. (*                initialized to 0. It is call only once for each    *)
  462. (*                byte to be checked and all 8 bits are included.    *)
  463. (*                No terminating calls are necessary.                *)
  464. (* ----------------------------------------------------------------- *)
  465. Procedure CRCheck ( Abyte : byte ) ;
  466. Var    j,temp : integer ;
  467.     Begin (* CRCheck *)
  468.     For j := 0 to 7 do
  469.          Begin (* check all 8 bits *)
  470.          temp := CRC xor Abyte ;
  471.          CRC := CRC shr 1 ;             (* shift right *)
  472.          If Odd(temp) then CRC := CRC xor $8408 ;
  473.          abyte := abyte shr 1 ;
  474.          End ; (* check all 8 bits *)
  475.     End ; (* CRCheck *)
  476. (* ----------------------------------------------------------------- *)
  477. (* Prefixof Function - Returns a char string of the dir prefix.      *)
  478. (* ----------------------------------------------------------------- *)
  479.  function Prefixof(afilename:comstring) : comstring;
  480.  var i :integer;
  481.  label exit ;
  482.     begin (* Prefixof *)
  483.     while length(afilename)>0 do
  484.          If afilename[length(afilename)] in [':','\','/']
  485.              then goto exit
  486.              else delete(afilename,length(afilename),1);
  487.  exit:
  488.     Prefixof := afilename ;
  489.     end;  (* Prefixof *)
  490.  
  491. (* ----------------------------------------------------------------- *)
  492. (*  NewAsFile - returns a new ASFILE name in the parameter AsFile.   *)
  493. (*           MyFiles - is the wild char name.                        *)
  494. (*           Filename - is the filename to be renamed .              *)
  495. (*           AsFiles  - is the wild char name of new file.           *)
  496. (*           AsFile   - is the new file name.                        *)
  497. (*     returns TRUE if AsFile correctly assigned.                    *)
  498. (*     returns FALSE if AsFile detected an error in assignment       *)
  499. (*   There is a BUG in the MsDoS Call to get next Directory Entry    *)
  500. (*   therefore this function may return FALSE.                       *)
  501. (*                                                                   *)
  502. (* ----------------------------------------------------------------- *)
  503. Function NewAsFile (MyFiles,Filename,AsFiles: comstring;
  504.                     var AsFile : comstring                ): boolean;
  505. var
  506.     temp : comstring ;
  507.     si,ix,iy : integer ;
  508.     star : packed array[1..8] of string[20];
  509. Label  Subdir,Exit;
  510.  
  511. Begin (* NewAsFile Function *)
  512. for si := 1 to 8 do star[si] := '*';
  513. si := 0 ;
  514.  MyFiles  := Uppercase(Myfiles);
  515.  FileName := Uppercase(Filename);
  516.  AsFiles  := Uppercase(AsFiles);
  517.  ix := Pos(':',MyFiles) ;
  518.  If ix > 1 then delete(MyFiles,1,ix) ;  (* Eliminate filemode prefix *)
  519. subdir:
  520.  ix := Pos('\',MyFiles) ;
  521.  If ix > 1 then delete(MyFiles,1,ix) ;  (* Eliminate sub-dir  prefixs *)
  522.  if ix > 1 then goto subdir ;
  523.  ix := Pos(':',AsFiles) ;
  524.  If ix > 1 then delete(AsFiles,1,ix) ;  (* Eliminate filemode prefix *)
  525. While (length(Filename) > 0) and (length(Myfiles)>0) Do
  526.     Begin (* Scan filename *)
  527.     If MyFiles[1] = Filename[1] then
  528.         Begin delete(MyFiles,1,1) ; delete(Filename,1,1); end
  529.                                 else
  530.          Begin (* get star string *)
  531.          si:=si+1 ;
  532.          delete(MyFiles,1,1);
  533.          ix := Pos('*',MyFiles) - 1 ;  (* Next wild char *)
  534.          if ix <= 0 then  temp := MyFiles
  535.                     else  temp := copy(Myfiles,1,ix);
  536.          iy := Pos(temp,Filename)-1 ;
  537.          if iy < 0 then
  538.               begin NEWASFILE:=FALSE; Asfile:='temp.dat'; Goto exit ; end;
  539.          if iy = 0 then star[si] := filename
  540.                     else star[si] := copy(filename,1,iy);
  541.          delete(FileName,1,iy);
  542.          End ;(* get star string *)
  543.     End; (* Scan filename *)
  544. ix := 1 ;
  545. si := 1 ;
  546. AsFile := '';
  547. While ix <= length(AsFiles)  do
  548.     Begin (* Create AsFile name *)
  549.     If AsFiles[ix] in ['*','?'] then
  550.          Begin (* wild char *)
  551.          AsFile := Concat(AsFile,star[si]);
  552.          si := si + 1 ;
  553.          End
  554.                                 else
  555.         AsFile := Concat(AsFile,Asfiles[ix]);
  556.    ix := ix + 1 ;
  557.    End ; (* Create AsFile name *)
  558. NewAsFile := True ;
  559. Exit:
  560. End; (* NewASFile Function *)
  561.  
  562. (* ============ End of   U T I L I T Y   Procedures =================== *)
  563.  
  564. (* +FILE+ SYSFUNC.PASMS *)
  565. (* ================================================================= *)
  566. (*  MsDos SYSTEM  dependent Routines for Kermit .                    *)
  567. (* ================================================================= *)
  568. (* Global Declaration  *)
  569. CONST
  570.     (* FLAGS in flag register *)
  571.     Cflag = $0001 ;
  572.     Pflag = $0004 ;
  573.     Aflag = $0010 ;
  574.     Zflag = $0040 ;
  575.     Tflag = $0100 ;
  576.     Iflag = $0200 ;
  577.     Dflag = $0400 ;
  578.     Oflag = $0800 ;
  579.  
  580. TYPE
  581.     regtype = record case layouts of
  582.               one: ( ax,bx,cx,dx,bp,si,di,ds,es,flags          : integer ;);
  583.               two: ( al,ah,bl,bh,cl,ch,dl,dh                   : byte ; ) ;
  584.            three : ( Sectors,Clusters,BytesperSec,TotalClusters: integer;)
  585.               end ;
  586.     ScreenArray = array [1..4000] of byte ;
  587.  
  588. VAR
  589.     register  : regtype ;
  590.     MyDTA : array [1..43] of byte ;
  591.     Remotecursor,LocalCursor : integer ;
  592.  
  593.     Commandline : comstring absolute Cseg:$80 ;
  594.  
  595.  
  596.     MonoScreen      : ScreenArray absolute $B000:$0000 ; (* Monchrome Video *)
  597.     ColorScreen     : ScreenArray absolute $B800:$0000 ; (* Colour graphics *)
  598.     OldLocalScreen  : ScreenArray  ;
  599.     OldRemoteScreen : ScreenArray  ;
  600.     NumLock,ScrollLock : byte ;
  601.  
  602. (* ------------------------------------------------------------------ *)
  603. (* KeyChar - get a character from the Keyboard.                       *)
  604. (*           It returns TRUE if character found and the char is       *)
  605. (*           returned in the parameter.                               *)
  606. (*           It returns FALSE if no keyboard character.               *)
  607. (*                                                                    *)
  608. (* ------------------------------------------------------------------ *)
  609.     Function KeyChar (var Achar,Bchar : byte): boolean ;
  610.     Begin (* KeyChar *)
  611.     with register do
  612.            begin
  613.            ah := 1;
  614.            intr($16,register);
  615.            if (Zflag and flags)=Zflag then
  616.  
  617. (* ------ The following code is required only if we want to us the ----- *)
  618. (* ------ NUMLOCK and SCROLLLOCK key as function keys  ----------------- *)
  619.               begin (* check for Numlck and Scroll Lck *)
  620.               ah := 2;
  621.               intr($16,register);
  622.               If  (al and $10) <> ScrollLock then
  623.                    Case (al and $0F) of
  624.                    0:     Bchar := $46 ; (* not shifted *)
  625.                    1,2,3: Bchar := $86 ; (* shifted *)
  626.                    4,5,6,7: Bchar := $87 ; (* control *)
  627.                    else Bchar := $87 ; (* Alt *)
  628.                    end  (* case *)
  629.                                             else
  630.               If  (al and $20) <> NumLock then
  631.                    Case (al and $0F) of
  632.                     0:     Bchar := $45 ; (* not shifted *)
  633.                     1,2,3: Bchar := $85 ; (* shifted *)
  634.                     4,5,6,7: Bchar := $88 ; (* control *) (* Not Available *)
  635.                     Else Bchar := $88 ; (* Alt *)
  636.                    End (* case *)
  637.                                              else Bchar := 0 ;
  638.               ScrollLock := (al and $10) ;
  639.               NumLock := (al and $20) ;
  640.               Achar := 0 ;
  641.               If Bchar <> 0 then   KeyChar := true
  642.                             else   KeyChar := false
  643.               End   (* check for Numlck and Scroll Lck *)
  644. (*------ If you don't need this code, replace it with ------------------ *)
  645. (* --------   KeyChar := False ----------------------------------------- *)
  646.  
  647.                                      else
  648.               begin
  649.               ah := 0;
  650.               intr($16,register);
  651.               Achar := al ;
  652.               Bchar := ah ;
  653.               KeyChar := true;
  654.               end ;
  655.            end;
  656.     End ; (* KeyChar *)
  657.  
  658.  
  659. (* ------------------------------------------------------------------ *)
  660. (* CursorPosition - Returns Cursor Position in Reg DX.                *)
  661. (* ------------------------------------------------------------------ *)
  662.     Procedure CursorPosition ;
  663.     Begin (* CursorPosition *)
  664.     With register do
  665.          begin (* Get position *)
  666.          ah := 3;
  667.          intr($10,register);
  668.          end; (* Get position *)
  669.     End;
  670. (* ------------------------------------------------------------------ *)
  671. (* CursorUp -                                                         *)
  672. (* ------------------------------------------------------------------ *)
  673.     Procedure CursorUp ;
  674.     Begin (* CursorUp *)
  675.     With register do
  676.          begin (* Move up *)
  677.          ah := 3;  (* Function code 3 - Read Cursor Position *)
  678.          intr($10,register);
  679.          if dh > 1 then dh := dh - 1
  680.                    else dh := 24 ;
  681.          ah := 2 ;  (* Function code 2 - Set Cursor Position *)
  682.          intr($10,register);
  683.          end; (* Move up *)
  684.     End;  (* CursorUp *)
  685.  
  686. (* ------------------------------------------------------------------ *)
  687. (* CursorDown -                                                       *)
  688. (* ------------------------------------------------------------------ *)
  689.     Procedure CursorDown ;
  690.     Begin (* CursorDown *)
  691.     With register do
  692.          begin (* Move Down *)
  693.          ah := 3;  (* Function code 3 - Read Cursor Position *)
  694.          intr($10,register);
  695.          if dh < 24 then dh := dh + 1
  696.                    else dh := 1 ;
  697.          ah := 2 ;  (* Function code 2 - Set Cursor Position *)
  698.          intr($10,register);
  699.          end; (* Move Down *)
  700.     End;  (* CursorDown *)
  701.  
  702. (* ------------------------------------------------------------------ *)
  703. (* CursorRight -                                                      *)
  704. (* ------------------------------------------------------------------ *)
  705.     Procedure CursorRight ;
  706.     Begin (* CursorRight *)
  707.     With register do
  708.          begin (* Move Right *)
  709.          ah := 3;  (* Function code 3 - Read Cursor Position *)
  710.          intr($10,register);
  711.          if dl < 80 then dl := dl + 1
  712.                    else dl := 1 ;
  713.          ah := 2 ;  (* Function code 2 - Set Cursor Position *)
  714.          intr($10,register);
  715.          end; (* Move Right *)
  716.     End;  (* CursorRight *)
  717.  
  718. (* ------------------------------------------------------------------ *)
  719. (* CursorLeft -                                                       *)
  720. (* ------------------------------------------------------------------ *)
  721.     Procedure CursorLeft ;
  722.     Begin (* CursorLeft *)
  723.     With register do
  724.          begin (* Move Left *)
  725.          ah := 3;  (* Function code 3 - Read Cursor Position *)
  726.          intr($10,register);
  727.          if dl > 0 then dl := dl - 1
  728.                    else dl := 80 ;
  729.          ah := 2 ;  (* Function code 2 - Set Cursor Position *)
  730.          intr($10,register);
  731.          end; (* Move Left *)
  732.     End;  (* CursorLeft *)
  733. (* ------------------------------------------------------------------ *)
  734. (* FatCursor -                                                       *)
  735. (* ------------------------------------------------------------------ *)
  736.     Procedure FatCursor(flag :boolean);
  737.     Begin (* FatCursor *)
  738.     Port[$3D4] := $B ; (* Select Cursor end Register *)
  739.     If flag then Port[$3D5] := 9
  740.             else Port[$3D5] := 7 ;
  741.     End;  (* FatCursor *)
  742.  
  743.  
  744. (* ------------------------------------------------------------------ *)
  745. (* RemoteScreen - Procedure                                           *)
  746. (*                This procedure save the local screen and restores   *)
  747. (*                the remote screen.                                  *)
  748. (*                Also setup the 25th line to display settings        *)
  749. (* ------------------------------------------------------------------ *)
  750.     Procedure RemoteScreen ;
  751.     Begin (* RemoteScreen *)
  752.     If (OldRemoteScreen[4000]<>1) or (OldRemoteScreen[3999]<>32) then
  753.          Begin (* Initialize OldRemoteScreen *)
  754.          For i := 1 to 4000 do OldRemoteScreen[i] := 32 ;
  755.          OldRemoteScreen[4000] := 1 ;
  756.          RemoteCursor := $0000 ;
  757.          End ; (* Initialize OldRemoteScreen *)
  758.     With register do
  759.          begin (* Switch Screens *)
  760.          bx := 0 ;
  761.          ah := 15;  (* Function code 15 - Return Current video State *)
  762.          intr($10,register);
  763.          if al < 7 then
  764.               Begin (* Color Screen *)
  765.               OldLocalScreen := ColorScreen ;
  766.               ColorScreen := OldRemoteScreen ;
  767.               End  (* Color Screen *)
  768.                    else
  769.               Begin (* MonoChrome Screen *)
  770.               OldLocalScreen := MonoScreen ;
  771.               MonoScreen := OldRemoteScreen ;
  772.               End  (* MonoChrome Screen *)
  773.          end ; (* Switch Screens *)
  774.     With register do
  775.          begin (* Save ? Restore Cursor *)
  776.          bx := 0 ;
  777.          ah := 3;  (* Function code 3 - Read Cursor Position *)
  778.          intr($10,register);
  779.          localcursor := dx ;
  780.  
  781.          (* ---- set up 25th line with status ------ *)
  782.          ah := 2;       (* Function code 2 - Set Cursor Position *)
  783.          DX := $1800;   (* Set the cursor to Row 25 and column 0 *)
  784.          Intr($10,Register);
  785.          Textcolor(Blue); Textbackground(Yellow);
  786.          Write  (' Port ');
  787.          If PrimaryPort then Write('One : ')
  788.                         else Write('Two : ');
  789.          Write(Baudrate,' baud, ');
  790.          Case paritytype(parity) of
  791.              OddP : write('Odd  ');
  792.              EvenP: write('Even ');
  793.              MarkP: write('Mark ');
  794.              NoneP: write('None ');
  795.          end ; (* parity case *)
  796.          Write('parity, ');
  797.          If LocalEcho then Write('Half duplex, ')
  798.                       else Write('Full duplex, ');
  799.          If XonXoff then write('Xon-Xoff ')
  800.                     else if Series1 then write('Series/1 ')
  801.                                     else write('Standard ');
  802.          Write  ('    ExitChar=CTL ',chr($40+LocalChar),'  ' ) ;
  803.          Textcolor(LightGreen); Textbackground(0);
  804.  
  805.          (* -------------------------------------------- *)
  806.  
  807.          dx := remotecursor ;
  808.          ah := 2 ;  (* Function code 2 - Set Cursor Position *)
  809.          intr($10,register);
  810.          end; (* Save ? Restore Cursor *)
  811.     Window(1,1,80,24);
  812.     End;  (* RemoteScreen *)
  813.  
  814. (* ------------------------------------------------------------------ *)
  815. (* LocalScreen  - Procedure                                           *)
  816. (*                This procedure save the remote screen and restores  *)
  817. (*                the local  screen.                                  *)
  818. (* ------------------------------------------------------------------ *)
  819.     Procedure LocalScreen ;
  820.     Begin (* LocalScreen *)
  821.     With register do
  822.          begin (* Switch Screens *)
  823.          bx := 0 ;
  824.          ah := 15;  (* Function code 15 - Return Current video State *)
  825.          intr($10,register);
  826.          if al < 7 then
  827.               Begin (* Color Screen *)
  828.               OldRemoteScreen := ColorScreen ;
  829.               ColorScreen := OldLocalScreen ;
  830.               End  (* Color Screen *)
  831.                    else
  832.               Begin (* MonoChrome Screen *)
  833.               OldRemoteScreen := MonoScreen ;
  834.               MonoScreen := OldLocalScreen ;
  835.               End  (* MonoChrome Screen *)
  836.          end ; (* Switch Screens *)
  837.     With register do
  838.          begin (* Save and Restore Cursor *)
  839.          ah := 3;  (* Function code 3 - Read Cursor Position *)
  840.          intr($10,register);
  841.          Remotecursor := dx ;
  842.          dx := Localcursor ;
  843.          ah := 2 ;  (* Function code 2 - Set Cursor Position *)
  844.          intr($10,register);
  845.          end; (* Save and Restore Cursor *)
  846.     TextColor(Yellow); TextBackground(Black);
  847.     Window(1,1,80,25);
  848.     End;  (* LocalScreen *)
  849.  
  850. (* ----------------------------------------------------------------- *)
  851. (* FirstFile - Returns True if file found for file mask Myfile       *)
  852. (*                 and the first file name is returned in Filename   *)
  853. (*           - Returns False if no file Found.                       *)
  854. (* ----------------------------------------------------------------- *)
  855. Function FirstFile(Myfile:Comstring; var Filename:Comstring): Boolean ;
  856. Var
  857.     OldSegment,OldOffset,i : integer ;
  858.  
  859.     Begin (* FirstFile Function *)
  860.     Myfile := concat(myfile,chr(0));
  861.     With Register do
  862.          Begin { Search for File }
  863.  
  864.          Ax := $2F00 ;      { Get DTA Dos Function }
  865.          MsDos(Register);
  866.          OldSegment := Es ; OldOffset := Bx ;  (* save old DTA location *)
  867.  
  868.          Ds := Seg(MyDTA);  Dx := Ofs(MyDTA) ;
  869.          Ax := $1A00 ;      { Set DTA Dos Function }
  870.          MsDos(Register);                      (* set my  DTA location *)
  871.  
  872.          Ax := $4E00 ;      {get first directory entry }
  873.          Ds := Seg(Myfile); { mask location }
  874.          Dx := Ofs(Myfile)+1;
  875.          Cx := 2 ;          {option}
  876.          MsDos(Register);
  877.          if al = 0 then    { Got file }
  878.               Begin (* Got File *)
  879.               i := 1 ;
  880.               Repeat
  881.                  Filename[i] := Chr (MyDTA[30 + i]) ;
  882.                  i := i + 1 ;
  883.               until (not (Filename[i-1] in [' '..'~'])) ;
  884.               Filename[0] := chr(i - 2);
  885.               Firstfile := true ;
  886.               End  (* Got file *)
  887.                  else
  888.               Firstfile := False ;
  889.  
  890.          Ds := OldSegment ;  Dx := OldOffset ;
  891.          Ax := $1A00 ;      { Set DTA Dos Function }
  892.          MsDos(Register);                    (* reset old DTA location *)
  893.          End; { Search for File }
  894.     End; { FirstFile Function }
  895. (* ----------------------------------------------------------------- *)
  896. (*  NextFile - Returns True if file found for file mask Myfile       *)
  897. (*                 and the first file name is returned in Filename   *)
  898. (*           - Returns False if no file Found.                       *)
  899. (* ----------------------------------------------------------------- *)
  900. Function NextFile(Var Myfile, Filename : Comstring): Boolean ;
  901. Var
  902.     OldSegment,OldOffset,i : integer ;
  903.  
  904.     Begin (* NextFile Function *)
  905.     With Register do
  906.          Begin { Search for File }
  907.  
  908.          Ax := $2F00 ;      { Get DTA Dos Function }
  909.          MsDos(Register);
  910.          OldSegment := Es ; OldOffset := Bx ;  (* save old DTA location *)
  911.  
  912.          Ds := Seg(MyDTA);  Dx := Ofs(MyDTA) ;
  913.          Ax := $1A00 ;      { Set DTA Dos Function }
  914.          MsDos(Register);                      (* set my DTA location *)
  915.  
  916.          Ax := $4F00 ;      { get next directory entry }
  917.          MsDos(Register);
  918.          if al = 0 then    { Got file }
  919.               Begin (* Got File *)
  920.               i := 1 ;
  921.               Repeat
  922.                  Filename[i] := chr (MyDTA[30 + i]) ;
  923.                  i := i + 1 ;
  924.               until (not (Filename[i-1] in [' '..'~'])) ;
  925.               Filename[0] := chr(i - 2);
  926.               Nextfile := true ;
  927.               End  (* Got file *)
  928.                  else
  929.               Nextfile := False ;
  930.  
  931.          Ds := OldSegment ;  Dx := OldOffset ;
  932.          Ax := $1A00 ;      { Set DTA Dos Function }
  933.          MsDos(Register);                    (* reset old DTA location *)
  934.          End; { Search for File }
  935.     End; { NextFile Function }
  936.  
  937. (* ------------------------------------------------------------------ *)
  938. (* SetDefaultDrive -                                                  *)
  939. (* ------------------------------------------------------------------ *)
  940.     Procedure SetDefaultDrive (Drive : Byte);
  941.     Begin (* SetDefaultDrive *)
  942.     With register do
  943.          begin (* Select disk *)
  944.          DL := Drive ;
  945.          Ax := $0E00 ;      { Select default drive }
  946.          MsDos(Register);
  947.          end; (* Select disk *)
  948.     End;  (* SetDefaultDrive *)
  949.  
  950. (* ------------------------------------------------------------------ *)
  951. (* DefaultDrive - returns the value of the default drive              *)
  952. (*                 A=0,B=1,C=2 etc.                                   *)
  953. (* ------------------------------------------------------------------ *)
  954.     Function DefaultDrive : Byte ;
  955.     Begin (* DefaultDrive *)
  956.     With register do
  957.          begin (* Current disk *)
  958.          Ax := $1900 ;      { Find default drive }
  959.          MsDos(Register);
  960.          DefaultDrive := al ;
  961.          end; (* Current disk *)
  962.     End;  (* DefaultDrive *)
  963.  
  964. (* ----------------------------------------------------------------- *)
  965. (*  DisplayDiskStatus - Display the disk status for the default disk.*)
  966. (*                                                                   *)
  967. (* ----------------------------------------------------------------- *)
  968. Procedure DisplayDiskStatus  ;
  969. Var
  970.     Freebytes : real ;
  971. Begin (* DisplayDiskStatus *)
  972. With Register do
  973.     Begin { Get disk status }
  974.     dl := DefaultDrive + 1 ;  (* use default drive *)
  975.     Write (' Disk Drive ',chr(DX+$40),':     ');
  976.     Ax := $3600 ;      { Get diskstatus Function }
  977.     MsDos(Register);
  978.     Writeln('Bytes/sector = ',BytesperSec,'  Sector/cluster = ',Sectors);
  979.     Writeln('Total Clusters = ',TotalClusters);
  980.     FreeBytes := BytesperSec*Sectors; (* two steps required due to  *)
  981.     FreeBytes := FreeBytes*Clusters ; (* integer overflow *)
  982.     Writeln('Free Clusters  = ',Clusters,'  i.e. ',Freebytes:7:0,' bytes free');
  983.     End; (* Get disk status *)
  984. End;  (* DisplayDiskStatus *)
  985. (* ----------------------------------------------------------------- *)
  986. (* MkDir - Make Directory.                                           *)
  987. (* ----------------------------------------------------------------- *)
  988. Procedure MkDirFunc(DirName:Comstring) ;
  989.     Begin (* MkDir  *)
  990.     DirName := DirName + chr(0) ;
  991.     With Register do
  992.          Begin { MD  }
  993.          Ds := Seg(DirName);  Dx := Ofs(DirName)+1 ;
  994.          Ax := $3900 ;      { MkDir Function }
  995.          MsDos(Register);
  996.          While Mem[Ds:Dx] <> 0 Do
  997.               Begin Write(Chr(Mem[Ds:Dx])); Dx := Dx + 1 ; End ;
  998.         Case Al of
  999.             0: writeln(' - New Directory Made ');
  1000.             3: writeln(' - Path not found');
  1001.             5: writeln(' - Acess denied');
  1002.             else writeln(' - Return code =',al);
  1003.           end; (* case of Ax *)
  1004.         End ; { MD }
  1005.     End ; (* MkDir *)
  1006. (* ----------------------------------------------------------------- *)
  1007. (* RmDir - Remove Directory.                                         *)
  1008. (* ----------------------------------------------------------------- *)
  1009. Procedure RmDirFunc(DirName:Comstring) ;
  1010.     Begin (* RmDir  *)
  1011.     DirName := DirName + chr(0) ;
  1012.     With Register do
  1013.          Begin { Remove Directory }
  1014.          Ds := Seg(DirName);  Dx := Ofs(DirName)+1 ;
  1015.          Ax := $3A00 ;      { RmDir Function }
  1016.          MsDos(Register);
  1017.          While Mem[Ds:Dx] <> 0 Do
  1018.               Begin Write(Chr(Mem[Ds:Dx])); Dx := Dx + 1 ; End ;
  1019.          Case Al of
  1020.               0: writeln(' - Directory Removed ');
  1021.               3: writeln(' - Path not found');
  1022.               5: writeln(' - Acess denied');
  1023.             else writeln(' - Return code =',al);
  1024.             end; (* case of Ax *)
  1025.         End ; { Remove Directory }
  1026.     End ; (* RmDir *)
  1027. (* ----------------------------------------------------------------- *)
  1028. (* ChDir - Change Directory.                                         *)
  1029. (* ----------------------------------------------------------------- *)
  1030. Procedure ChDirFunc(DirName:Comstring) ;
  1031.     Begin (* ChDir  *)
  1032.     DirName := DirName + chr(0) ;
  1033.     With Register do
  1034.          Begin { CD  }
  1035.          Ds := Seg(DirName);  Dx := Ofs(DirName)+1 ;
  1036.          Ax := $3B00 ;      { ChDir Function }
  1037.          MsDos(Register);
  1038.          While Mem[Ds:Dx] <> 0 Do
  1039.               Begin Write(Chr(Mem[Ds:Dx])); Dx := Dx + 1 ; End ;
  1040.          Case Al of
  1041.               0: writeln(' - Current Directory  ');
  1042.               3: writeln(' - Path not found');
  1043.               5: writeln(' - Acess denied');
  1044.             else writeln(' - Return code =',al);
  1045.             end; (* case of Ax *)
  1046.         End ; { CD }
  1047.     End ; (* ChDir *)
  1048.  
  1049. (* ----------------------------------------------------------------- *)
  1050. (*  EXECFile - Exec a file.                                          *)
  1051. (*                                                                   *)
  1052. (* ----------------------------------------------------------------- *)
  1053. Procedure EXECFile (Var RunString : comstring) ;
  1054. Type
  1055.      FCB      = record
  1056.                 Drive    : char ;
  1057.                 filename : array [1..8] of char ;
  1058.                 filetype : array [1..3] of char ;
  1059.                 Curblock : integer ;
  1060.                 Recsize  : integer ;
  1061.                 DosUse   : array [1..16] of char ;
  1062.                 CurRec   : byte ;
  1063.                 Randlow  : integer ;
  1064.                 Randhigh : integer ;
  1065.                 end ;
  1066.      PPBrecord = record
  1067.                  SegAddr       : integer ;
  1068.                  ComlinePt     : ^Comstring ;
  1069.                  FCB1pt,FCB2pt : ^FCB ;
  1070.                  end;
  1071. Var
  1072.     PPB         : PPBrecord ;
  1073.     Myfile      : comstring ;
  1074.     FCB1,FCB2   : FCB ;
  1075.  
  1076. Begin (* RunFile *)
  1077. Myfile := Gettoken(Runstring);
  1078. If Pos('.',Myfile) = 0 then Myfile := Myfile + '.COM' ;
  1079. With Register do
  1080.     Begin (* SetBlock - Modify allocated Memory Blocks  *)
  1081.     Ax := $4A00 ;      (* Set Block - Free up unused memory  *)
  1082.     Es := CSeg ;       (* Point to begining of block *)
  1083.     Bx := SSeg ;       (* Amount of memory in use *)
  1084.     MsDos(Register);
  1085.     Writeln(Register.BX,' paragraphs of memory in use .');
  1086.     End ;  (* SetBlock - Modify allocated Memory Blocks  *)
  1087.  
  1088. Writeln(' Exec program  ',Myfile);
  1089. Myfile := Myfile + chr($00) ;
  1090. With Register do
  1091.     Begin (* Set up Run  *)
  1092.     Ax := $4B00 ;      (* Load and EXEC Function *)
  1093. (*  Ax := $4B03 ;  *)  (* Load Overlay  Function *)
  1094.     DS := Seg(Myfile); DX := Ofs(Myfile)+1 ; (* Point to Program name *)
  1095.     ES := Seg(PPB) ;   BX := Ofs(PPB);       (* Point to Program Parm block *)
  1096.     With PPB do
  1097.          BEGIN  (* set up Program Parameter Block *)
  1098.          SegAddr   :=  Memw[CSEG :$2C] ;
  1099.          Comlinept :=  Addr(RunString);
  1100.          FCB1pt    :=  Addr(FCB1);
  1101.          FCB2pt    :=  Addr(FCB2);
  1102.          End ;  (* set up Program Parameter Block *)
  1103.  
  1104. (*  MsDos(Register);      *)
  1105.      (* The following in line code does the same thing as the MsDos call *)
  1106.      (* with the exception that it also save and restores the SS and SP reg. *)
  1107.     Inline (  $BF/Register/  (* MOV DI,Register *)
  1108.               $1E/           (* PUSH DS *)
  1109.               $07/           (* POP  ES *)
  1110.               $1E/           (* PUSH DS *)
  1111.               $06/           (* PUSH ES *)
  1112.               $57/           (* PUSH DI *)
  1113.               $55/           (* PUSH BP *)
  1114.               $53/           (* PUSH BX *)
  1115.               $B9/$09/$00/   (* MOV  CX,0009 *)
  1116.               $26/           (* ES:     *)
  1117.               $FF/$35/       (* PUSH [DI] *)
  1118.               $47/           (* INC  DI *)
  1119.               $47/           (* INC  DI *)
  1120.               $E2/$F9/       (* LOOP back to PUSH [DI] *)
  1121.               $07/           (* POP  ES *)
  1122.               $1F/           (* POP  DS *)
  1123.               $5F/           (* POP  DI *)
  1124.               $5E/           (* POP  SI *)
  1125.               $5D/           (* POP  BP *)
  1126.               $5A/           (* POP  DX *)
  1127.               $59/           (* POP  CX *)
  1128.               $5B/           (* POP  BX *)
  1129.               $58/           (* POP  AX *)
  1130.     (* Now save SS and SP in location 104 of Code Segment *)
  1131.               $57/           (* PUSH DI *)
  1132.               $BF/$0104/     (* MOV  DI,0104 *)
  1133.               $2E/           (* CS:     *)
  1134.               $8C/$15/       (* MOV  [DI],SS *)
  1135.               $47/           (* INC  DI *)
  1136.               $47/           (* INC  DI *)
  1137.               $2E/           (* CS:     *)
  1138.               $89/$25/       (* MOV  [DI],SP *)
  1139.               $5F/           (* POP  DI *)
  1140.  
  1141.     (*  This dumb msdos call destroys all the register including SS and SP  *)
  1142.               $CD/$21/     (*  ********  MsDos Call  ******** *)
  1143.  
  1144.     (* Restore the SS and SP register from location 104 of Code Segment *)
  1145.               $BF/$0104/     (* MOV  DI,0104 *)
  1146.               $2E/           (* CS:     *)
  1147.               $8E/$15/       (* MOV  SS,[DI] *)
  1148.               $47/           (* INC  DI *)
  1149.               $47/           (* INC  DI *)
  1150.               $2E/           (* CS:     *)
  1151.               $8B/$25/       (* MOV  SP,[DI] *)
  1152.               $5F/           (* POP  DI *)
  1153.     (* Now restore the rest of the registers from the stack *)
  1154.               $9C/           (* PUSH F  *)
  1155.               $06/           (* PUSH ES *)
  1156.               $1E/           (* PUSH DS *)
  1157.               $57/           (* PUSH DI *)
  1158.               $56/           (* PUSH SI *)
  1159.               $55/           (* PUSH BP *)
  1160.               $52/           (* PUSH DX *)
  1161.               $51/           (* PUSH CX *)
  1162.               $53/           (* PUSH BX *)
  1163.               $50/           (* PUSH AX *)
  1164.               $8B/$EC/       (* MOV  BP,SP *)
  1165.               $8B/$7E/$18/   (* MOV  DI,[BP+18] *)
  1166.               $8E/$46/$1A/   (* MOV  ES,[BP+1A] *)
  1167.               $B9/$0A/$00/   (* MOV  CX,000A *)
  1168.               $26/           (* ES:     *)
  1169.               $8F/$05/       (* POP  [DI] *)
  1170.               $47/           (* INC  DI  *)
  1171.               $47/           (* INC  DI  *)
  1172.               $E2/$F9/       (* LOOP back to POP [DI] *)
  1173.               $5B/           (* POP  BX *)
  1174.               $5D/           (* POP  BP *)
  1175.               $5F/           (* POP  DI *)
  1176.               $07/           (* POP  ES *)
  1177.               $1F);          (* POP  DS *)
  1178.     Case Ax of
  1179.          2: writeln('File >>> ',Myfile, ' <<< not found');
  1180.          5: writeln('Acess denied');
  1181.          8: writeln('Insufficient Memory to load program');
  1182.         10: writeln('Invalid Environment');
  1183.         end; (* case of Ax *)
  1184.     End; (* Set up Run  *)
  1185.  Writeln(' Return from Execution of ',Myfile);
  1186. End;  (* RunFile *)
  1187.  
  1188. (* +FILE+ SYSFUNC.PASCPM *)
  1189. (* ================================================================= *)
  1190. (*  CP/M SYSTEM  dependent Routines for Kermit                       *)
  1191. (* ================================================================= *)
  1192. (* Global Declaration  *)
  1193. TYPE
  1194.     FCBrecord = record
  1195.                 Drive : byte ;
  1196.                 Fname : array [1..8] of char ;
  1197.                 Ftype : array [1..3] of char ;
  1198.                 Extent: byte ;
  1199.                 Sbite1: byte ;
  1200.                 Sbite2: byte ;
  1201.                 RCount: byte ;  (* record count *)
  1202.                 CBdata: array [1..16] of char ;
  1203.                 CurRec: byte ;
  1204.                 r0r1  : integer ;
  1205.                 r2    : byte ;
  1206.                 end ;
  1207.     listpointer = ^Filenamerec;
  1208.     Filenamerec = record
  1209.                   Link : listpointer ;
  1210.                   nextname : string[12] ;
  1211.                   end ;
  1212. VAR
  1213.     Commandline : string[80] absolute $80 ;
  1214.     FCB : FCBrecord absolute $005C ;
  1215.     DMA : array[0..255] of char ;
  1216.     FNHead : listpointer ;
  1217.     Marker : listpointer ;
  1218. (* ------------------------------------------------------------------ *)
  1219. (* Sound - Dummy sound routine for CPM system.                        *)
  1220. (* ------------------------------------------------------------------ *)
  1221.     Procedure Sound (dummy : integer );
  1222.     Begin (* Sound *)
  1223.     write(chr(7));
  1224.     End ; (* Sound *)
  1225.     Procedure Nosound ; begin end;
  1226.  
  1227. (* ------------------------------------------------------------------ *)
  1228. (* KeyChar - get a character from the Keyboard.                       *)
  1229. (*           It returns TRUE if character found and the char is       *)
  1230. (*           returned in the parameter.                               *)
  1231. (*           It returns FALSE if no keyboard character.               *)
  1232. (*                                                                    *)
  1233. (* ------------------------------------------------------------------ *)
  1234.     Function KeyChar (var Achar,Bchar : byte): boolean ;
  1235.     var mychar : char ;
  1236.     Begin (* KeyChar *)
  1237.     If keypressed then
  1238.          Begin (* got a key *)
  1239.          Read(KBD,mychar);
  1240.          Achar := Ord(mychar);
  1241.          Bchar := 0;
  1242.          KeyChar := true ;
  1243.          End
  1244.                   else
  1245.         Keychar := false ;
  1246.     End ; (* KeyChar *)
  1247.  
  1248.  
  1249. (* ------------------------------------------------------------------ *)
  1250. (* RemoteScreen - Save the local screen and restores the Remotescreen *)
  1251. (* ------------------------------------------------------------------ *)
  1252.     Procedure RemoteScreen ;
  1253.     Begin (* RemoteScreen *)
  1254.     Clrscr ;
  1255.     End;
  1256.  
  1257. (* ------------------------------------------------------------------ *)
  1258. (* LocalScreen - Save the local screen and restores the Remotescreen *)
  1259. (* ------------------------------------------------------------------ *)
  1260.     Procedure LocalScreen ;
  1261.     Begin (* LocalScreen *)
  1262.     Clrscr ;
  1263.     End;
  1264.  
  1265. (* ------------------------------------------------------------------ *)
  1266. (* CursorPosition - Returns Cursor Position in Reg DX.                *)
  1267. (* ------------------------------------------------------------------ *)
  1268.     Procedure CursorPosition ;
  1269.     Begin (* CursorPosition *)
  1270.     End;
  1271. (* ------------------------------------------------------------------ *)
  1272. (* CursorUp -                                                         *)
  1273. (* ------------------------------------------------------------------ *)
  1274.     Procedure CursorUp ;
  1275.     Begin (* CursorUp *)
  1276.     write(Chr($0B));     (* Vertical Tab *)
  1277.     End;  (* CursorUp *)
  1278.  
  1279. (* ------------------------------------------------------------------ *)
  1280. (* CursorDown -                                                       *)
  1281. (* ------------------------------------------------------------------ *)
  1282.     Procedure CursorDown ;
  1283.     Begin (* CursorDown *)
  1284.     write(Chr($0A));       (* LineFeed *)
  1285.     End;  (* CursorDown *)
  1286.  
  1287. (* ------------------------------------------------------------------ *)
  1288. (* CursorRight -                                                      *)
  1289. (* ------------------------------------------------------------------ *)
  1290.     Procedure CursorRight ;
  1291.     Begin (* CursorRight *)
  1292.     write(Chr($0C));      (* Form Feed *)
  1293.     End;  (* CursorRight *)
  1294.  
  1295. (* ------------------------------------------------------------------ *)
  1296. (* CursorLeft -                                                       *)
  1297. (* ------------------------------------------------------------------ *)
  1298.     Procedure CursorLeft ;
  1299.     Begin (* CursorLeft *)
  1300.     write(Chr($08));      (* BackSpace *)
  1301.     End;  (* CursorLeft *)
  1302.  
  1303. (* ------------------------------------------------------------------ *)
  1304. (* SetDefaultDrive -                                                  *)
  1305. (* ------------------------------------------------------------------ *)
  1306.     Procedure SetDefaultDrive (Drive : Byte);
  1307.     Var dummy : byte ;
  1308.     Begin (* SetDefaultDrive *)
  1309.     Dummy := Bdos(14,Drive);      (* Select Drive *)
  1310.     End;  (* SetDefaultDrive *)
  1311.  
  1312. (* ------------------------------------------------------------------ *)
  1313. (* DefaultDrive - returns the value of the default drive              *)
  1314. (*                 A=0,B=1,C=2 etc.                                   *)
  1315. (* ------------------------------------------------------------------ *)
  1316.     Function DefaultDrive : Byte ;
  1317.     Begin (* DefaultDrive *)
  1318.     DefaultDrive := Bdos(25) ;  (* Current Disk *)
  1319.     End;  (* DefaultDrive *)
  1320. (* ----------------------------------------------------------------- *)
  1321. (* ----------------- Build Next List Procedure --------------------- *)
  1322.     Procedure BuildNextList(var Pt : listpointer);
  1323.     Var dot,i,results : byte ;
  1324.         Newpt: listpointer ;
  1325.     Begin (* BuildNextList *)
  1326.     I := Bdos(26,addr(DMA));
  1327.     Results := Bdos(18);
  1328.     If Results < 4 then
  1329.          Begin (* found file *)
  1330.          New(Newpt);
  1331.          Pt := Newpt;
  1332.          With Newpt^ do
  1333.              Begin (* Get file name in list *)
  1334.              Link := nil ;
  1335.              nextname[0] := chr(12) ;
  1336.              results := results * 32 ;
  1337.              for i := 1 to 8 do nextname[i] := DMA[results+i] ;
  1338.              nextname[9] := ' ' ;
  1339.              dot := pos(' ',nextname) ;
  1340.              nextname[dot] := '.' ;
  1341.              for i := 1 to 3 do nextname[dot+i] := DMA[results+8+i] ;
  1342.              nextname[0] := Chr(dot+3) ;
  1343.              end ; (* Get file name in list *)
  1344.          BuildNextList(Newpt^.link)
  1345.          End ;   (* Found file *)
  1346.               (*  else do nothing *) ;
  1347.      End ; { BuildNextlist }
  1348. (* ----------------- Get Next Procedure ----------------------------------- *)
  1349.      Function GetNext ( Var FN : comstring ): boolean ;
  1350.      Var Pt : listpointer ;
  1351.      Begin (* GetNext *)
  1352.      If FNhead = Nil then
  1353.          Begin (* end of List *)
  1354.          GetNext := false ;
  1355.          Release(Marker);
  1356.          End   (* end of list *)
  1357.                      else
  1358.          Begin (* get name *)
  1359.          FN := FNhead^.nextname;
  1360.          pt := Fnhead ;
  1361.          FNhead := Fnhead^.link ;
  1362.          GetNext := true ;
  1363.          End ; (* get name *)
  1364.      End ; (* GetNext *)
  1365. (* ----------------------------------------------------------------- *)
  1366. (* ----------------------------------------------------------------- *)
  1367. (* FirstFile - Returns True if file found for file mask Myfile       *)
  1368. (*                 and the first file name is returned in Filename   *)
  1369. (*           - Returns False if no file Found.                       *)
  1370. (* note: because the CPM call FIND NEXT can not be issued after      *)
  1371. (*       an open or close operation, the find next must be done here *)
  1372. (*       for the the NEXTFILE function.  We will use a link list of  *)
  1373. (*       file names.                                                 *)
  1374. (* ----------------------------------------------------------------- *)
  1375.  
  1376. Function FirstFile(Myfile:Comstring; var Filename:Comstring): Boolean ;
  1377. Var
  1378.     colon,Dot,asterisk,I,results : byte ;
  1379.     temp : string[20] ;
  1380.  
  1381.     Begin (* FirstFile Function *)
  1382.     Myfile := uppercase(Myfile) ;
  1383.     With FCB do
  1384.          Begin (* set up FCB *)
  1385.          Drive := 0 ;
  1386.          colon := pos(':',Myfile) ;
  1387.          if colon <> 0 then
  1388.               begin (* disk drive specified *)
  1389.               drive := Ord(myfile[1])-$40 ;
  1390.               delete(Myfile,1,colon);
  1391.               end ; (* disk drive specified *)
  1392.          dot := pos('.',Myfile);
  1393.          if dot=0 then dot := 8 ;
  1394.          temp := myfile ;
  1395.          delete(temp,dot,12);
  1396.          asterisk := pos('*',temp);
  1397.          if asterisk <> 0 then
  1398.              begin (* wild char *)
  1399.              temp[asterisk] := '?' ;
  1400.              while length(temp)< 8 do insert('?',temp,asterisk);
  1401.              end ; (* wild char *)
  1402.          temp := temp + '       ' ;
  1403.          for i := 1 to 8 do FName[i] := temp[i] ;
  1404.          temp := myfile ;
  1405.          delete(temp,1,dot);
  1406.          asterisk := pos('*',temp);
  1407.          if asterisk <> 0 then
  1408.              begin (* wild char *)
  1409.              temp[asterisk] := '?' ;
  1410.              while length(temp)< 3 do insert('?',temp,asterisk);
  1411.              end ; (* wild char *)
  1412.          temp := temp + '   ' ;
  1413.          for i := 1 to 3 do FType[i] := temp[i] ;
  1414.          End ;  (* set up FCB *)
  1415.     I := Bdos(26,addr(DMA)) ;
  1416.     Results := Bdos(17,addr(FCB)) ;
  1417.     If Results < 4 then
  1418.          Begin (* found file *)
  1419.          filename[0] := chr(12) ;
  1420.          results := results * 32 ;
  1421.          for i := 1 to 8 do filename[i] := DMA[results+i] ;
  1422.          filename[9] := ' ' ;
  1423.          dot := pos(' ',filename) ;
  1424.          filename[dot] := '.' ;
  1425.          for i := 1 to 3 do filename[dot+i] := DMA[results+8+i] ;
  1426.          filename[0] := Chr(dot+3);
  1427.          FirstFile := true ;
  1428.          New(Marker); Mark(marker);
  1429.          Buildnextlist(FNhead);
  1430.          End    (* Found file *)
  1431.                         else
  1432.          FirstFile := false ;
  1433.     End; { FirstFile Function }
  1434. (* ----------------------------------------------------------------- *)
  1435. (*  NextFile - Returns True if file found for file mask Myfile       *)
  1436. (*                 and the first file name is returned in Filename   *)
  1437. (*           - Returns False if no file Found.                       *)
  1438. (* ----------------------------------------------------------------- *)
  1439. Function NextFile(Var Myfile, Filename : Comstring): Boolean ;
  1440.     Begin (* NextFile *)
  1441.     NextFile := Getnext(Filename) ;
  1442.     End ; (* NextFile *)
  1443. (* ----------------------------------------------------------------- *)
  1444. (*  DisplayDiskStatus - Display the disk status for the default disk.*)
  1445. (*                                                                   *)
  1446. (* ----------------------------------------------------------------- *)
  1447. Procedure DisplayDiskStatus  ;
  1448. Type
  1449.     DPBrec = record
  1450.              SPT     : integer ;  (* sectors per track *)
  1451.              BSH     : byte ;     (* data alloc. block shift factor *)
  1452.              BLM     : byte ;
  1453.              EXM     : byte ;
  1454.          (*  Blocks  : integer ; *) (* total storage capacity *)
  1455.              Blocklo : byte ;
  1456.              BLockhi : byte ;
  1457.              DRM     : integer ;  (* number of directory entries *)
  1458.              AL0,AL1 : byte ;
  1459.              CKS     : integer ;
  1460.              OFF     : integer ;
  1461.              end ;
  1462.    DKspace = record diskspace : array[0..100] of byte ; end ;
  1463. Var DPB : ^DPBrec ;
  1464.     DK : ^DKspace ;
  1465.     Diskspaceindex,
  1466.     Blocks : integer ;
  1467.     i,j,freeblock : integer ;
  1468.     DefDrive : byte ;
  1469. Begin (* DisplayDiskStatus *)
  1470. DefDrive := DefaultDrive ;  (* save def drive *)
  1471. i := BDos(13) ;             (* reset drive to r/w *)
  1472. SetDefaultDrive(DefDrive) ; (* restore def drive *)
  1473. writeln(' ');
  1474. Write('Disk Drive ',Chr(DefaultDrive+$41),':  ');
  1475. DPB := Ptr(BdosHL(31)) ;      (* get disk parameters *)
  1476. with DPB^ do
  1477.     Begin (* display disk data *)
  1478.     Blocks := (Blockhi*256 + Blocklo);
  1479.     Write (' Total User Space =',(Blocks+1)*(BLM+1) DIV 8,' Kbytes, ');
  1480.     End ; (* display disk data *)
  1481. DK  := Ptr(BdosHL(27)) ;      (* get disk space vector *)
  1482. freeblock := 0;
  1483. with DK^ do
  1484.   for i := 0 to blocks do
  1485.        if (Diskspace[ (i div 8)] shl (i mod 8)) and $80 = 0 then
  1486.           freeblock := freeblock + 1 ;
  1487.   writeln (' Available Space =',freeblock*(DPB^.BLM+1) DIV 8,' Kbytes ');
  1488. End;  (* DisplayDiskStatus *)
  1489.  
  1490. (* ----------------------------------------------------------------- *)
  1491. (*  EXECfile - Execute a file .                                      *)
  1492. (*                                                                   *)
  1493. (* ----------------------------------------------------------------- *)
  1494. Procedure EXECfile( myfile: comstring);
  1495. Begin (* EXECfile *)
  1496. Writeln(' RUN function is not available in CP/M version ');
  1497. End;  (* EXECfile *)
  1498.  
  1499. (* +FILE+ MODEMPRO.PASMS *)
  1500. (* ================================================================= *)
  1501. (*  MODEM - Routines and Global variables for IBMPC compatiables     *)
  1502. (* ================================================================= *)
  1503.  
  1504. CONST
  1505.     (* Modem Registers *)
  1506.     LowOrderDiv      = 0 ;
  1507.     HiOrderDiv       = 1 ;  InterruptEnable = 1 ;
  1508.     InterruptIdReg   = 2 ;
  1509.     LineControlReg   = 3 ;
  1510.     ModemControlReg  = 4 ;
  1511.     LineStatusReg    = 5 ;
  1512.     ModemStatusReg   = 6 ;
  1513.     ClockRate        = 18430 ;  (* CentiHertz. - use 17895 for PCjr *)
  1514.     (* 8259 Interrupt Controller addresses *)
  1515.     (* IC8259Reg1 = $20 ;   IC8259Reg2 = $21 ; *)
  1516.  
  1517.     MaxBuffsize = 20000 ;
  1518.     DefaultBaud = 9600 ;
  1519.  
  1520. VAR
  1521.     connected : boolean ;
  1522.     Modem     : Integer ;
  1523.     EnableMask,ResetMask : byte ;
  1524.     IntVector,
  1525.     Saveoffset,SaveSeg  : integer ;
  1526.  
  1527.     Buffer : Packed array [1..MaxBuffsize] of byte ;
  1528.     Iout,Iin : integer ;
  1529.  
  1530. (* ------------------------------------------------------------------ *)
  1531. (* IntHandler - Interrupt handler                                     *)
  1532. (*            This procedure handles the modem interrupts ,           *)
  1533. (*            which occur for incomming data only.                    *)
  1534. (*            1. Offset 16 into this procedure must be initialize     *)
  1535. (*               with the correct value of the DS register before     *)
  1536. (*               using this routine.                                  *)
  1537. (*            2. The routine is to start at offset 7, i.e. it         *)
  1538. (*              bypasses the normal pascal entry code.                *)
  1539. (*            (See InitModem Routine)                                 *)
  1540. (*                                                                    *)
  1541. (* ------------------------------------------------------------------ *)
  1542. Procedure IntHandler  ;
  1543.     (* Interrupt code starts at Inline code $50             *)
  1544.     (* which is offset 7 bytes from beginning of IntHandler *)
  1545.     Begin (* IntHandler *)
  1546.     (* Save Registers and set up the proper DS register *)
  1547.     Inline($50/$53/$51/$52/$57/$56/$06/$1E/ (* PUSH ax,bx,cx,dx,di,si,es,ds *)
  1548.            $B8/$00/$00/                 (* MOV  ax,immediatevalue    *)
  1549.            $50/                         (* PUSH ax                   *)
  1550.            $1F/                         (* POP  ds - set ds          *)
  1551.            $FB) ;                       (* STI  set interrupt enable *)
  1552.  
  1553.     If (Port[Modem+LineStatusReg] and $01) = $01 then
  1554.          begin (* put char in buffer *)
  1555.          buffer[Iin] := Port[Modem];
  1556.          Iin := Iin + 1 ;
  1557.          if Iin = MaxBuffsize then Iin := 1 ;
  1558.          end ; (* put char in buffer *)
  1559.     Port[$20] := ResetMask ;
  1560.  
  1561.     (* Restore the registers and Return *)
  1562.     Inline ($1F/$07/$5E/$5F/$5A/$59/$5B/$58/ (* POP ds,es,si,di,dx,cx,bx,ax *)
  1563.             $CF);                            (* IRET *)
  1564.     End ;  (* IntHandler *)
  1565.  
  1566. (* ------------------------------------------------------------------ *)
  1567. (* InitModem - Initialize the modem and setup interrupt procedure.    *)
  1568. (*            The interrupt procedure is at IntHandler+7, and         *)
  1569. (*            the DS register must be stored in IntHandler+16.        *)
  1570. (*                                                                    *)
  1571. (* ------------------------------------------------------------------ *)
  1572.     Procedure Initmodem ;
  1573.     Var rate : integer ;
  1574.     Begin (* Init modem *)
  1575.     If PrimaryPort then
  1576.          Begin (* Primary port *)
  1577.          Modem := $3F8 ;
  1578.          EnableMask := $EF ;
  1579.          ResetMask := $64 ;    (* end of interrupt for IRQ4 *)
  1580.          IntVector := $0030 ;
  1581.          End  (* Primary Port *)
  1582.                   else
  1583.         Begin (* Secondary Port *)
  1584.         Modem := $2F8 ;
  1585.         EnableMask := $F7 ;
  1586.         ResetMask := $63 ;   (* end of interrupt for IRQ3 *)
  1587.         IntVector := $002C ;
  1588.         End ; (* Secondary Port *)
  1589.     Iin := 1 ; Iout := 1 ;
  1590.  
  1591.     (* Initialize the Interrupt Procedure *)
  1592.     Saveoffset := MemW[$0000:IntVector] ;     (* save the Old interrupt  *)
  1593.     SaveSeg    := MemW[$0000:IntVector+2] ;   (* address of serial interrupt *)
  1594.  
  1595.     MemW[$0000:IntVector] := Ofs(IntHandler) + 7 ;  (* Use our own interrupt *)
  1596.     MemW[$0000:IntVector+2] := Cseg ;               (*  hanlder              *)
  1597.     MemW[Cseg:Ofs(IntHandler)+16] := Dseg ;     (* set in  for handler   *)
  1598.  
  1599.     Port[$21] := Port[$21] and EnableMask ;  (* Enable serial port interrupt *)
  1600.     Port[$20] := ResetMask ;
  1601.  
  1602.     (* Initialize baud rates and bits and parity *)
  1603.     Rate := round( (Clockrate/16) / (Baudrate/100)) ;
  1604.     Port[Modem+LineControlReg] := $80 ;     (* Enable baud rate setting *)
  1605.     Port[Modem+LowOrderDiv]    := (rate and $00FF) ;
  1606.     Port[Modem+HiOrderDiv]     := rate div $100 ;
  1607.     Port[Modem+LineControlReg] := (ord(Parity) shl 4) OR $0A ;
  1608.                                   (* parity, 7 bits,1 stop *)
  1609.     Port[Modem+ModemControlReg] := $0B ;   (* DTR and RTS *)
  1610.     Port[Modem+InterruptEnable] := $01 ;   (* Data Avail. Interrupt set *)
  1611.     End ; (* Init modem *)
  1612.  
  1613. (* ------------------------------------------------------------------ *)
  1614. (*  ResetModem - Reset the Interrupt back to the original.            *)
  1615. (*       Global variables - Saveoffset,SaveSeq                        *)
  1616. (* ------------------------------------------------------------------ *)
  1617.     Procedure ResetModem;
  1618.     Begin (* Reset Modem Interrupt *)
  1619.     MemW[$0000:IntVector] := Saveoffset ;    (* restore the Old interrupt    *)
  1620.     MemW[$0000:IntVector+2] := SaveSeg  ;    (* address of serial interrupt *)
  1621.     End; (* Reset Modem Interrupt *)
  1622.  
  1623. (* ------------------------------------------------------------------ *)
  1624. (*  SetModem -  Set the baud rate and parity for modem.               *)
  1625. (*       Global variables - Modem,Clockrate,Baudrate,Parity           *)
  1626. (* ------------------------------------------------------------------ *)
  1627.     Procedure SetModem ;
  1628.     Var rate : integer ;
  1629.     Begin (* SetModem *)
  1630.     If PrimaryPort then
  1631.          Begin (* Primary port *)
  1632.          Modem := $3F8 ;
  1633.          EnableMask := $EF ;
  1634.          ResetMask := $64 ;    (* end of interrupt for IRQ4 *)
  1635.          End  (* Primary Port *)
  1636.                   else
  1637.         Begin (* Secondary Port *)
  1638.         Modem := $2F8 ;
  1639.         EnableMask := $F7 ;
  1640.         ResetMask := $63 ;   (* end of interrupt for IRQ3 *)
  1641.         End ; (* Secondary Port *)
  1642.     Rate := round( (Clockrate/16) / (Baudrate/100)) ;
  1643.     Port[Modem+LineControlReg] := $80 ;     (* Enable baud rate setting *)
  1644.     Port[Modem+LowOrderDiv]    := (rate and $00FF) ;
  1645.     Port[Modem+HiOrderDiv]     := rate div $100 ;
  1646.     Port[Modem+LineControlReg] := (ord(Parity) shl 4) OR $0A ;
  1647.                                   (* parity, 7 bits,1 stop *)
  1648.     End ; (* SetModem *)
  1649.  
  1650. (* ------------------------------------------------------------------ *)
  1651. (*  DialModem - Check and waits for modem to be connected.            *)
  1652. (*              It waits for DTR and CTS signals to be detected.      *)
  1653. (*  Side Effect - global variable 'connected' is set true.            *)
  1654. (* ------------------------------------------------------------------ *)
  1655.    Procedure DialModem ;
  1656.    var abyte,bbyte : byte ;
  1657.    Begin (* Dial Modem *)
  1658.    While ((Port[Modem+ModemStatusReg] and $30) <> $30) and DTRcheck Do
  1659.          Begin (* Connect modem please *)
  1660.          If audioFlag then
  1661.            Begin Sound(600);delay(100);Sound(2000);delay(200); nosound;end;
  1662.          writeln('  Please connect your modem ');
  1663.          delay (1000);
  1664.          DTRcheck := not (keychar(abyte,bbyte) and (abyte=$20)) ;
  1665.          End ; (* Connect modem please *)
  1666.    connected := true ;
  1667.    If audioflag then
  1668.        for i:=1 to 50 do begin sound(100*i);delay(5);end; nosound;
  1669.    Writeln('  Connection completed ');
  1670.    End ; (* Dial Modem *)
  1671.  
  1672. (* ------------------------------------------------------------------ *)
  1673. (* RecvChar - Receive a Character from the modem port.                *)
  1674. (*            TRUE - if there is a character from the modem and       *)
  1675. (*                   the character is returned in the parmeter.       *)
  1676. (*            FALSE - if no character found .                         *)
  1677. (*                                                                    *)
  1678. (* ------------------------------------------------------------------ *)
  1679.     Function RecvChar (var mchar : byte) : boolean ;
  1680.     Begin (* RecvChar *)
  1681.     if Iin <> Iout then
  1682.          begin (* get char from buffer *)
  1683.          mchar := buffer[Iout] and $7F ;
  1684.          Iout := Iout + 1 ;
  1685.          If Iout = MaxBuffsize then Iout := 1 ;
  1686.          RecvChar := true ;
  1687.          if logging then
  1688.                      Begin {$I-}
  1689.                      write(Logfile,chr(mchar));
  1690.                      If IOresult <> 0 then
  1691.                         Begin (* IO error *)
  1692.                         Writeln(' Disk is Full - logging teminated');
  1693.                         logging := false  ;
  1694.                         Close(Logfile);
  1695.                         End ; (* IO error *)
  1696.                      End ; {$I+}
  1697.          end   (* get char from buffer *)
  1698.                    else
  1699.          RecvChar := false ;
  1700.     End ; (* RecvChar *)
  1701.  
  1702. (* ------------------------------------------------------------------ *)
  1703. (* SendChar - Send a character thru the modem port.                   *)
  1704. (*           It waits for the previous character to be sent before    *)
  1705. (*           sending the current character.                           *)
  1706. (* ------------------------------------------------------------------ *)
  1707.     Procedure SendChar(char : byte ) ;
  1708.     Begin (* Send Char *)
  1709.     While  (Port[Modem+LineStatusReg] and $20) <> $20 do delay(1);
  1710.          Port[modem] := char ;
  1711.     End ;  (* Send Char *)
  1712.  
  1713. (* ------------------------------------------------------------------ *)
  1714. (* SendBreak- Send a break via the modem port .                       *)
  1715. (* ------------------------------------------------------------------ *)
  1716.     Procedure SendBreak ;
  1717.     Var Tbyte : byte ;
  1718.     Begin (* Send Break *)
  1719.     Tbyte := Port[Modem+LineControlReg] ;  (* save setting *)
  1720.     Port[Modem+LineControlReg] := $40 ;    (* break for 200 millsec *)
  1721.     Writeln(' *** BREAK *** ');
  1722.     Delay(200) ;
  1723.     Port[Modem+LineControlReg] := Tbyte ;    (* restore setting *)
  1724.     End ;  (* Send Break *)
  1725.  
  1726. (* ================================================================= *)
  1727. (*    End of MODEM routines for IBMPC compatiables.                  *)
  1728. (* ================================================================= *)
  1729.  
  1730. (* +FILE+ MODEMPRO.PASAPPLE *)
  1731. (* ================================================================= *)
  1732. (*  MODEM - Routines and Global variables for Apple II - PDA232.     *)
  1733. (* ================================================================= *)
  1734.  
  1735. CONST
  1736.     (* Modem Registers - Port assignment *)
  1737.     Modem            = $E0A8 ;
  1738.     LowOrderDiv      = 0 ;
  1739.     HiOrderDiv       = 1 ;  InterruptEnable = 1 ;
  1740.     InterruptIdReg   = 2 ;
  1741.     LineControlReg   = 3 ;
  1742.     ModemControlReg  = 4 ;
  1743.     LineStatusReg    = 5 ;
  1744.     ModemStatusReg   = 6 ;
  1745.     ClockRate        = 18430 ;  (* CentiHertz. - use 17895 for PCjr *)
  1746.  
  1747. VAR
  1748.     connected : boolean ;
  1749.  
  1750. (* ------------------------------------------------------------------ *)
  1751. (* InitModem - Initialize the modem.                                  *)
  1752. (*                                                                    *)
  1753. (* ------------------------------------------------------------------ *)
  1754.     Procedure Initmodem ;
  1755.     Var Rate : integer ;
  1756.     Begin (* Init modem *)
  1757.     (* Initialize baud rates and bits and parity *)
  1758.     Rate := round( (Clockrate/16) / (Baudrate/100)) ;
  1759.     Mem[Modem+LineControlReg] := $80 ;    (* Enable baud rate setting *)
  1760.     Mem[Modem+LowOrderDiv]    := (rate and $00FF) ;
  1761.     Mem[Modem+HiOrderDiv]     := rate div $100 ;
  1762.     Mem[Modem+LineControlReg] := (ord(Parity) shl 4) OR $0A ;
  1763.                                   (* parity, 7 bits,1 stop *)
  1764.     Mem[Modem+ModemControlReg] := $0B ;  (* DTR and RTS *)
  1765.     Mem[Modem+InterruptEnable] := $00 ;  (* No Interrupt set *)
  1766.     End ; (* Init modem *)
  1767.  
  1768. (* ------------------------------------------------------------------ *)
  1769. (*  ResetModem - Reset the Interrupt back to the original.            *)
  1770. (*                                                                    *)
  1771. (* ------------------------------------------------------------------ *)
  1772.     Procedure ResetModem;
  1773.     Begin (* Reset Modem Interrupt *)
  1774.     End; (* Reset Modem Interrupt *)
  1775.  
  1776. (* ------------------------------------------------------------------ *)
  1777. (*  SetModem -  Set the baud rate and parity for modem.               *)
  1778. (*       Global variables - Modem,Clockrate,Baudrate,Parity           *)
  1779. (* ------------------------------------------------------------------ *)
  1780.     Procedure SetModem ;
  1781.     Var rate : Integer ;
  1782.     Begin (* SetModem *)
  1783.     Rate := round( (Clockrate/16) / (Baudrate/100)) ;
  1784.     Mem[Modem+LineControlReg] := $80 ;    (* Enable baud rate setting *)
  1785.     Mem[Modem+LowOrderDiv]    := (rate and $00FF) ;
  1786.     Mem[Modem+HiOrderDiv]     := rate div $100 ;
  1787.     Mem[Modem+LineControlReg] := (ord(Parity) shl 4) OR $0A ;
  1788.                                   (* parity, 7 bits,1 stop *)
  1789.     End ; (* SetModem *)
  1790.  
  1791. (* ------------------------------------------------------------------ *)
  1792. (*  DialModem - Check and waits for modem to be connected.            *)
  1793. (*              It waits for DTR and CTS signals to be detected.      *)
  1794. (*  Side Effect - global variable 'connected' is set true.            *)
  1795. (* ------------------------------------------------------------------ *)
  1796.    Procedure DialModem ;
  1797.    Var abyte,bbyte : byte ;
  1798.    Begin (* Dial Modem *)
  1799.    While ((Mem[Modem+ModemStatusReg] and $30) <> $30) and DTRcheck Do
  1800.          Begin (* Connect modem please *)
  1801.      (*   Sound(600);delay(100);Sound(2000);delay(200); nosound;*)
  1802.          writeln('  Please connect your modem ');
  1803.          delay (1000);
  1804.          DTRcheck := Not (keychar(abyte,bbyte) and (abyte = $20)) ;
  1805.          End ; (* Connect modem please *)
  1806.    connected := true ;
  1807. (*   for i:=1 to 100 do begin sound(100*i);delay(10);end; nosound;  *)
  1808.    Writeln('  Connection completed ');
  1809.    End ; (* Dial Modem *)
  1810.  
  1811. (* ------------------------------------------------------------------ *)
  1812. (* RecvChar - Receive a Character from the modem port.                *)
  1813. (*            TRUE - if there is a character from the modem and       *)
  1814. (*                   the character is returned in the parmeter.       *)
  1815. (*            FALSE - if no character found .                         *)
  1816. (*                                                                    *)
  1817. (* ------------------------------------------------------------------ *)
  1818.     Function RecvChar (var mchar : byte) : boolean ;
  1819.     Begin (* RecvChar *)
  1820.     If (Mem[Modem+LineStatusReg] and $01) = $01 then
  1821.          begin (* get char from buffer *)
  1822.          mchar := Mem[Modem] and $7F ;
  1823.          RecvChar := true ;
  1824.          if logging then
  1825.                      Begin {$I-}
  1826.                      write(Logfile,chr(mchar));
  1827.                      If IOresult <> 0 then
  1828.                         Begin (* IO error *)
  1829.                         Writeln(' Disk is Full - logging teminated');
  1830.                         logging := false  ;
  1831.                         Close(Logfile);
  1832.                         End ; (* IO error *)
  1833.                      End ; {$I+}
  1834.          end   (* get char from buffer *)
  1835.                    else
  1836.          RecvChar := false ;
  1837.     End ; (* RecvChar *)
  1838.  
  1839. (* ------------------------------------------------------------------ *)
  1840. (* SendChar - Send a character thru the modem port.                   *)
  1841. (*           It waits for the previous character to be sent before    *)
  1842. (*           sending the current character.                           *)
  1843. (* ------------------------------------------------------------------ *)
  1844.     Procedure SendChar(char : byte ) ;
  1845.     Begin (* Send Char *)
  1846.     While  (Mem[Modem+LineStatusReg] and $20) <> $20 do delay(1);
  1847.         Mem[Modem] := char ;
  1848.     End ;  (* Send Char *)
  1849.  
  1850. (* ------------------------------------------------------------------ *)
  1851. (* SendBreak- Send a break via the modem port .                       *)
  1852. (* ------------------------------------------------------------------ *)
  1853.     Procedure SendBreak ;
  1854.     Var Tbyte : byte ;
  1855.     Begin (* Send Break *)
  1856.     Tbyte := Mem[Modem+LineControlReg] ;  (* save setting *)
  1857.     Mem[Modem+LineControlReg] := $40 ;    (* break for 200 millsec *)
  1858.     Writeln(' *** BREAK *** ');
  1859.     Delay(200) ;
  1860.     Mem[Modem+LineControlReg] := Tbyte ;    (* restore setting *)
  1861.     End ;  (* Send Break *)
  1862.  
  1863. (* ================================================================= *)
  1864. (*    End of MODEM routines for Apple  II computers with PDA232.     *)
  1865. (* ================================================================= *)
  1866.  
  1867. (* +FILE+ MODEMPRO.PASKAYII *)
  1868. (* ================================================================= *)
  1869. (*  MODEM - Routines and Global variables for Kaypro II.             *)
  1870. (* ================================================================= *)
  1871.  
  1872. CONST
  1873.     (* Modem Registers - Port assignment *)
  1874.     BaudrateReg = $00 ;
  1875.     ModemData   = $04 ;
  1876.     ModemStatus = $06 ;
  1877.     Ptable : array [0..3] of byte = (1,3,2,0) ;
  1878.  
  1879.     (* Flag in the Modem status register *)
  1880.     RxChar   = $01 ;         (* received char in modem data reg *)
  1881.     TxChar   = $04 ;         (* transmit buffer empty *)
  1882.     CTS      = $20 ;         (* Clear to Send signal *)
  1883.     DCD      = $08 ;         (* Data Carrier Detect *)
  1884.  
  1885. VAR
  1886.     connected : boolean ;
  1887.  
  1888. (* ------------------------------------------------------------------ *)
  1889. (* InitModem - Initialize the modem.                                  *)
  1890. (*                                                                    *)
  1891. (* ------------------------------------------------------------------ *)
  1892.     Procedure Initmodem ;
  1893.     Var rate : string[5] ;
  1894.     Begin (* Init modem *)
  1895.  
  1896.     Port[ModemStatus] := $03 ;  (* Select Write Reg 3 - Receive Option *)
  1897.     Port[ModemStatus] := $81 ;  (* 7 databit(80), Rx Enable(01) *)
  1898.  
  1899.     Port[ModemStatus] := $04 ;  (* Select Write Reg 4 - Modem Options *)
  1900.     Port[ModemStatus] := $44 +  (* x16clock(40),1 stopbit(04)  *)
  1901.                          PTable[Ord(Parity)];   (*  Parity  *)
  1902.  
  1903.     Port[ModemStatus] := $05 ;  (* Select Write Reg 5 - Xmit Options *)
  1904.     Port[ModemStatus] := $AA ;  (* DTR(80),7-bits(20),Tx Enable(08) *)
  1905.                                     (* RTS(20) *)
  1906.  
  1907.     Str(Baudrate,rate);
  1908.     Port[BaudRateReg] := Pos(rate,'  50   75  110  135  150  300  600' +
  1909.                 ' 1200 1800 2000 2400 3600 4800 7200 9600 19200') div 5 ;
  1910.  
  1911.     End ; (* Init modem *)
  1912.  
  1913. (* ------------------------------------------------------------------ *)
  1914. (*  ResetModem - Reset the Interrupt back to the original.            *)
  1915. (*                                                                    *)
  1916. (* ------------------------------------------------------------------ *)
  1917.     Procedure ResetModem;
  1918.     Begin (* Reset Modem Interrupt *)
  1919.     End; (* Reset Modem Interrupt *)
  1920.  
  1921. (* ------------------------------------------------------------------ *)
  1922. (*  SetModem -  Set the baud rate and parity for modem.               *)
  1923. (*       Global variables - Modem,Clockrate,Baudrate,Parity           *)
  1924. (* ------------------------------------------------------------------ *)
  1925.     Procedure SetModem ;
  1926.     Var rate : string[5] ;
  1927.     Begin (* SetModem *)
  1928.     Port[ModemStatus] := $04 ;  (* Select Write Reg 4 - Modem Options *)
  1929.     Port[ModemStatus] := $44 +  (* x16clock(40),1 stopbit(04)  *)
  1930.                          PTable[Ord(Parity)];   (*  Parity  *)
  1931.     Str(Baudrate,rate);
  1932.     Port[BaudRateReg] := Pos(rate,'  50   75  110  135  150  300  600' +
  1933.                     ' 1200 1800 2000 2400 3600 4800 7200 9600 19200') div 5 ;
  1934.     End ; (* SetModem *)
  1935.  
  1936. (* ------------------------------------------------------------------ *)
  1937. (*  DialModem - Check and waits for modem to be connected.            *)
  1938. (*              It waits for DTR and CTS signals to be detected.      *)
  1939. (*  Side Effect - global variable 'connected' is set true.            *)
  1940. (* ------------------------------------------------------------------ *)
  1941.    Procedure DialModem ;
  1942.    Var abyte,bbyte : byte ;
  1943.    Begin (* Dial Modem *)
  1944.     While ((Port[ModemStatus] and DCD) <> DCD) and DTRcheck  Do
  1945.          Begin (* Connect modem please *)
  1946.          writeln('  Please connect your modem.  Status= ',Port[ModemStatus]);
  1947.          delay (1000);
  1948.          DTRcheck := Not (keychar(abyte,bbyte) and (abyte=$20)) ;
  1949.          End ; (* Connect modem please *)
  1950.    connected := true ;
  1951. (* Writeln('  Assume Connection completed '); *)
  1952.    End ; (* Dial Modem *)
  1953.  
  1954. (* ------------------------------------------------------------------ *)
  1955. (* RecvChar - Receive a Character from the modem port.                *)
  1956. (*            TRUE - if there is a character from the modem and       *)
  1957. (*                   the character is returned in the parmeter.       *)
  1958. (*            FALSE - if no character found .                         *)
  1959. (*                                                                    *)
  1960. (* ------------------------------------------------------------------ *)
  1961.     Function RecvChar (var mchar : byte) : boolean ;
  1962.     Begin (* RecvChar *)
  1963.     if (Port[ModemStatus] and RxChar) = RxChar then
  1964.          begin (* get char from buffer *)
  1965.          mchar := Port[ModemData] and $7F ;
  1966.          RecvChar := true ;
  1967.          if logging then write(Logfile,chr(mchar));
  1968.          end   (* get char from buffer *)
  1969.                    else
  1970.          RecvChar := false ;
  1971.     End ; (* RecvChar *)
  1972.  
  1973. (* ------------------------------------------------------------------ *)
  1974. (* SendChar - Send a character thru the modem port.                   *)
  1975. (*           It waits for the previous character to be sent before    *)
  1976. (*           sending the current character.                           *)
  1977. (* ------------------------------------------------------------------ *)
  1978.     Procedure SendChar(char : byte ) ;
  1979.     Begin (* Send Char *)
  1980.     While  (Port[ModemStatus] and TxChar) <> TxChar do delay(1);
  1981.     Port[ModemData] := char ;
  1982.     End ;  (* Send Char *)
  1983.  
  1984. (* ------------------------------------------------------------------ *)
  1985. (* SendBreak- Send a break via the modem port .                       *)
  1986. (* ------------------------------------------------------------------ *)
  1987.     Procedure SendBreak ;
  1988.     Var Tbyte : byte ;
  1989.     Begin (* Send Break *)
  1990.     Port[ModemStatus] := $05 ;  (* Select Write Reg 5 - Xmit Options *)
  1991.     Port[ModemStatus] := $10 ;  (* Send BREAK *)
  1992.     Writeln(' *** BREAK *** ');
  1993.     Delay(200) ;
  1994.     Port[ModemStatus] := $05 ;  (* Select Write Reg 5 - Xmit Options *)
  1995.     Port[ModemStatus] := $AA ;  (* DTR(80),7-bits(20),Tx Enable(08) *)
  1996.                                     (* RTS(20) *)
  1997.     End ;  (* Send Break *)
  1998.  
  1999. (* ================================================================= *)
  2000. (*    End of MODEM routines for Kaypro II computers                  *)
  2001. (* ================================================================= *)
  2002.  
  2003. (* +FILE+ DEFWORDS.PASMSCPM *)
  2004. (* Global DefWord variables *)
  2005. Var
  2006.     DefFile : text ;
  2007.     NewDefs : boolean ;
  2008.     DefList : DefPointer ;
  2009.  
  2010. (* ================================================================== *)
  2011. (* AssignDefWord  - Assigns the Defined Word  into the DefList.       *)
  2012. (*                   This is a recursive procedure.                   *)
  2013. (* Side Affects : The boolean variable NewDefs is set true            *)
  2014. (* ================================================================== *)
  2015. Procedure AssignDefWord (var PT : DefPointer;
  2016.                           DWord:Wstring ; Dstring: comstring);
  2017. Var TempPt : DefPointer ;
  2018. Begin (* AssignDefWord Procedure *)
  2019. NewDefs := true ;
  2020. TempPt := PT;
  2021. If PT <> nil then
  2022.     With PT^ do
  2023.          If DefWord = Dword then         (* Found existing Word *)
  2024.              If length(Dstring) > 0 then
  2025.                   DefString := Dstring
  2026.                                     else
  2027.                   Begin (* Drop DefWord *)
  2028.                   PT := Link ;  (* Drop entry *)
  2029.                   Dispose(tempPT);
  2030.                   End   (* Drop DefWord *)
  2031.  
  2032.                             else        (* Look down the list *)
  2033.              AssignDefWord(Link,DWord,Dstring)
  2034.  
  2035.             else
  2036.     If length(Dstring) > 0 then
  2037.          Begin (* Add new entry *)
  2038.          New(PT);
  2039.          With PT^ do
  2040.               Begin (* Add DefWord to list *)
  2041.               Link := Nil ;
  2042.               DefWord := DWord ;
  2043.               DefString := Dstring ;
  2044.               End;
  2045.          End ; (* Add new entry *)
  2046. End ; (* AssignDefWord Procedure *)
  2047.  
  2048.  
  2049. (* ================================================================== *)
  2050. (* DisplayDefWords - display the Defined Words in the DefList.        *)
  2051. (*                   This is a recursive procedure.                   *)
  2052. (*                                                                    *)
  2053. (* ================================================================== *)
  2054. Procedure DisplayDefWords (PT : DefPointer);
  2055. Begin (* DisplayDefWords Procedure *)
  2056. If PT <> nil then
  2057.       With PT^ do
  2058.          Begin (* Display Word and definition *)
  2059.          Writeln(DefWord,' := ',DefString);
  2060.          DisplayDefWords(Link);
  2061.          End ;
  2062. End ; (* DisplayDefWords Procedure *)
  2063. (* ================================================================== *)
  2064. (* CheckDefWords - Checks  for   Defined Words in the DefList.        *)
  2065. (*                 If it is found it concationates the DefString      *)
  2066. (*                 to the Instring and reset the first token          *)
  2067. (*                   This is a recursive procedure.                   *)
  2068. (*                                                                    *)
  2069. (* ================================================================== *)
  2070. Procedure CheckDefWords (PT : DefPointer;
  2071.                              var Dword : Wstring ; var Instring: comstring);
  2072. Begin (* CheckDefWords Procedure *)
  2073. If PT <> nil then
  2074.     With PT^ do
  2075.          If Dword = DefWord then
  2076.               Begin (* Update string *)
  2077.               Instring := DefString + ' ' + Instring ;
  2078.               Dword := uppercase(GetToken(Instring));
  2079.               End
  2080.                            else
  2081.               CheckDefWords(Link,Dword,Instring)
  2082. End ; (* CheckDefWords Procedure *)
  2083.  
  2084. (* ================================================================== *)
  2085. (* WriteDefWord - writes  the Defined Words in the DefList to the    *)
  2086. (*                 DefFile.                                           *)
  2087. (*                                                                    *)
  2088. (* ================================================================== *)
  2089. Procedure WriteDefWord (PT : DefPointer);
  2090. Begin (* WriteDefWord Procedure *)
  2091. If PT <> nil then
  2092.       With PT^ do
  2093.          Begin (* Write word and definition *)
  2094.          Writeln(DefFile,DefWord,' ',DefString);
  2095.          WriteDefWord(Link);
  2096.          End ;
  2097. End ; (* WriteDefWord Procedure *)
  2098.  
  2099. (* ================================================================== *)
  2100. (* DEFINEWORD - This procedure processes the DEFINE command.          *)
  2101. (*              It searches the DefList for the WORD specified        *)
  2102. (*              If it is found it replaces the definition string      *)
  2103. (*              with the new definition. Otherwise it creates an      *)
  2104. (*              new entry in the DefList.                             *)
  2105. (* ================================================================== *)
  2106. Procedure DEFINEWORD (Var Instring: comstring);
  2107. Var
  2108.     DWord : string[10] ;
  2109.  
  2110. Begin (* DefineWord Procedure *)
  2111. If length(Instring) < 1 then
  2112.     If DefList = Nil then  Writeln(' No Defined Words ')
  2113.                      else  DisplayDefWords (DefList)
  2114.                         else
  2115.     Begin (* Assign Defined Word *)
  2116.     DWord :=   Uppercase(GetToken(Instring));
  2117.     While (instring[1] = ' ') and (length(instring)>0) do
  2118.           Delete(instring,1,1);    (* eliminate leading blanks *)
  2119.     AssignDefWord(DefList,DWord,Instring);
  2120.     Instring := '';
  2121.     End ; (* Assign Define Word *)
  2122. End;  (* DefineWord Procedure *)
  2123.  
  2124. (* ================================================================== *)
  2125. (* LoadDefWords  - Loads the Defined Words into the DefList from      *)
  2126. (*                 the file KERMIT.DEF.                               *)
  2127. (*                                                                    *)
  2128. (* ================================================================== *)
  2129. Procedure LoadDefWords ;
  2130. Var Instring,dummy : comstring ;
  2131. Begin (* LoadDefWord Procedure *)
  2132. If FirstFile('KERMIT.DEF',DUMMY) then
  2133.     Begin (* Read file *)
  2134.     Assign(DefFile,'KERMIT.DEF');
  2135.     Reset(DefFile);
  2136.     While not Eof(DefFile) do
  2137.          Begin (* load DefList *)
  2138.          Readln(DefFile,Instring);
  2139.          DefineWord(Instring);
  2140.          End ; (* load DefList *)
  2141.     End ; (* Read file *)
  2142. End ; (* LoadDefWord Procedure *)
  2143.  
  2144. (* ================================================================== *)
  2145. (* SaveDefWords  - Saves the Defined Words from the DefList into      *)
  2146. (*                 the file KERMIT.DEF.                               *)
  2147. (*                                                                    *)
  2148. (* ================================================================== *)
  2149. Procedure SaveDefWords ;
  2150. Var Instring : comstring ;
  2151. Begin (* SaveDefWord Procedure *)
  2152. Writeln('Saving  DEFINE words in file KERMIT.DEF');
  2153. Assign(DefFile,'KERMIT.DEF');
  2154. Rewrite(DefFile);
  2155. WriteDefWord(DefList);
  2156. Close(DefFile);
  2157. End ; (* SaveDefWord Procedure *)
  2158.  
  2159. (* +FILE+ READCHAR.PASMSCPM *)
  2160. (* ------------------------------------------------------------------ *)
  2161. (* ReadChar - Read a character from the modem.                        *)
  2162. (*           Waits for a character to appear on the modem.            *)
  2163. (*           It returns TRUE when the character is received and       *)
  2164. (*           the value of the char is return in the parameter.        *)
  2165. (*           It returns FALSE if the keyboard char is detected before *)
  2166. (*           a character is received or it times out.                 *)
  2167. (*   Side Effects : if the keys ^Z ^X ^C or ^E are pressed then       *)
  2168. (*           BREAKSTATE is set to BZ, BX, BC, or BE respectively.     *)
  2169. (*   Note : The ticker value may need to change if code is added to   *)
  2170. (*           to this procedure or RecvChar or KeyChar. It is also     *)
  2171. (*           machine dependent.                                       *)
  2172. (* ------------------------------------------------------------------ *)
  2173.     Function ReadChar(var char : byte): boolean;
  2174.     var waiting : boolean ;
  2175.         dummy : byte ;
  2176.         Ticker,Timer : integer ;
  2177.     Begin (* Read Char *)
  2178.     waiting := true ;
  2179.     timer := 0 ;
  2180.     ticker := 0 ;
  2181.     While waiting Do
  2182.          Begin (* Wait for a Character *)
  2183.          If RecvChar(char) then
  2184.               Begin (* got char *)
  2185.               ReadChar := true ;
  2186.               waiting := false ;
  2187.               End  (* got char *)
  2188.                            else
  2189.               If KeyChar(char,dummy) then
  2190.                    Begin (* key char *)
  2191.                    ReadChar := false ;
  2192.                    waiting := false ;
  2193.                    if char = $03 then BREAKSTATE := BC ;
  2194.                    if char = $05 then BREAKSTATE := BE ;
  2195.                    if char = $18 then BREAKSTATE := BX ;
  2196.                    if char = $1A then BREAKSTATE := BZ ;
  2197.                    End   (* key char *)
  2198.                                     else
  2199.                    Begin (* Check for timeout *)
  2200.                    if Timer < Timeout then (* increment timer *)
  2201.                         If ticker = 1072 then
  2202.                              Begin ticker := 0 ; Timer := Timer + 1; end
  2203.                                         else ticker := ticker + 1
  2204.                                       else  (* times up *)
  2205.                         Begin Waiting := false; ReadChar := False; End;
  2206.                   End;   (* Check for timeout *)
  2207.         End ; (* Wait for a Character *)
  2208.     End; (* Read Char *)
  2209.  
  2210. (* +FILE+ PACKET.PASMSCPM *)
  2211. (* ===============================================================  *)
  2212. (* SENDPACKET -This procedure sends the SendData packet .           *)
  2213. (*          1. The COUNT sent includes SEQ,PACKETTYPE,and CHECKSUM  *)
  2214. (*             i.e. it is 3 larger than the OutCount or             *)
  2215. (*               if CheckType = 2 or 3 then COUNT is 4 or 5 larger. *)
  2216. (*          2. The COUNT and SEQ and CHECKSUM values are offset by  *)
  2217. (*             32 decimal (20hex) to make it a printable ASCII char.*)
  2218. (*          3. The CHECKSUM are calculated on the ASCII value of    *)
  2219. (*             the printable characters.                            *)
  2220. (*                                                                  *)
  2221. (* Assumptions:                                                     *)
  2222. (*       The following Global variables must be correctly set       *)
  2223. (*       before calling this procedure .                            *)
  2224. (*       1. OutDataCount - an integer-byte count of data characters.*)
  2225. (*       2. OUTSEQ    - an integer-byte count of sequence number.   *)
  2226. (*       3. OUTPACKETTYPE - an character    of type .               *)
  2227. (*       4. SendData   - a character array of data to be sent.      *)
  2228. (* ===============================================================  *)
  2229. PROCEDURE SENDPACKET ;
  2230.  VAR
  2231.     I,SUM,Checkbytes : INTEGER ;
  2232.     achar            : byte ;
  2233.     SOHecho          : boolean ;
  2234.  
  2235.     BEGIN (* SENDPACKET procedure *)
  2236. (*  SOHecho := Not (LocalEcho or (Series1 and  WaitXon)) ;  *)
  2237.     SOHecho := Not (LocalEcho or Series1) ;
  2238.     achar := 0 ;
  2239.     If WaitXon then
  2240.          While achar <> XON do if Readchar(achar) then
  2241.                                                   else achar := xon ;
  2242.     WaitXon := XonXoff ;
  2243.     While RecvChar(achar) do ; (* throw away all previous incoming data *)
  2244.     Delay(50);
  2245.      SUM := 0 ;
  2246.      CRC := 0 ;
  2247.      Checkbytes := 1 ;
  2248.      If (OutPacketType = ord('S')) or (OutPacketType = ord('I')) or
  2249.          (InpacketType = ord('S')) or  (InpacketType = ord('I')) or
  2250.          (InpacketType = ord('R')) then  (* leave Checkbytes := 1 *)
  2251.                               else
  2252.          If Checktype = ord('2') then Checkbytes := 2  else
  2253.               If Checktype = ord('3') then Checkbytes := 3 ;
  2254.  
  2255.     SendChar(StartChar) ;                                       (* SOH   *)
  2256.     If SOHecho then      (* wait for SOH to be echoed back *)
  2257.         While achar <> StartChar do
  2258.           if Not Readchar(achar) then achar:=StartChar ;
  2259.     OutCount := OutDataCount + 2 + Checkbytes ;
  2260.     SendChar(OutCount + $20) ;                             (* COUNT *)
  2261.       SUM := SUM + OutCount + $20 ;
  2262.       CRCheck(OutCount+$20) ;
  2263.     SendChar(OUTSEQ+$20) ;                                 (* SEQ   *)
  2264.       SUM := SUM + OUTSEQ + $20;
  2265.       CRCheck(OUTSEQ+$20);
  2266.     SendChar(OUTPACKETTYPE) ;                              (* TYPE  *)
  2267.       SUM := SUM + ORD(OUTPACKETTYPE) ;
  2268.       CRCheck(Ord(OutpacketType));
  2269.  
  2270.     IF OutDataCount > 0 THEN
  2271.      FOR I := 1 TO OutDataCount DO
  2272.          BEGIN (* Send Data *)
  2273.          SendChar(SendData[I]) ;                           (* DATA   *)
  2274.          SUM := SUM + SendData[I] ;
  2275.          CRCheck(SendData[I]);
  2276.          END ; (* Send Data *)
  2277.  
  2278.  
  2279.     If Checkbytes = 1 then
  2280.          Begin (* one Checksum *)
  2281.          CHECKSUM := (SUM + (SUM AND $C0) DIV $40 ) AND $3F ;
  2282.          SendChar(CHECKSUM+$20);                           (* CHECKSUM *)
  2283.          End   (* one Checksum *)
  2284.                      else
  2285.     If Checkbytes = 2 then
  2286.          Begin (* two Checksum *)
  2287.          Checksum := (Sum div $40) and $3F ; (* Bit 11 - 6 *)
  2288.          SendChar(Checksum+$20) ;
  2289.          Checksum :=  Sum and $3F ;          (* Bit 5 - 0 *)
  2290.          SendChar(Checksum+$20) ;
  2291.          End  (* two Checksum *)
  2292.                       else
  2293.     If Checkbytes = 3 then
  2294.         Begin (* CRC *)
  2295.         SendChar((CRC shr 12 ) and $0F + $20) ;
  2296.         SendChar((CRC shr 6  ) and $3F + $20) ;
  2297.         SendChar((CRC        ) and $3F + $20) ;
  2298.         End ; (* CRC *)
  2299.  
  2300.     SendChar(EndChar);                                     (* Cr *)
  2301.     If NumPad > 0 then
  2302.         For I := 1 to NumPad do SendChar(PadChar);         (* Padding *)
  2303.     END ; (* SENDPACKET procedure  *)
  2304.  
  2305. (* ===============================================================  *)
  2306. (* RECVPACKET -This Function returns TRUE if it successfully        *)
  2307. (*             recieved a packet and FALSE if it had an error.      *)
  2308. (*  Side Effects:                                                   *)
  2309. (*       The following global variables will be set.                *)
  2310. (*       1. InDataCount - an integer value of the msg char count.   *)
  2311. (*       2. INSEQ - an integer value of the sequence count.         *)
  2312. (*       3. TYPE  - a  character of message type (Y,N,D,F,etc)      *)
  2313. (*       4. RecvData - an array of data bytes to be sent.           *)
  2314. (*                                                                  *)
  2315. (* ===============================================================  *)
  2316. FUNCTION  RECVPACKET : BOOLEAN ;
  2317.  VAR
  2318.     I,SUM,RESENDS      : INTEGER ;
  2319.     INCHAR,Checkbytes  : Byte ;
  2320.     dummy              : Boolean ;
  2321.  
  2322. LABEL EXIT ;
  2323.  
  2324.     BEGIN (* RECVPACKET procedure *)
  2325.     RECVPACKET := false ;    (* assume false until proven otherwise *)
  2326.     If GotSOH then begin Inchar := StartChar; GotSOH := false; end
  2327.                      else Inchar := $20 ;
  2328.     While Inchar <> StartChar Do
  2329.          If Readchar(Inchar) then                     (* SOH   *)
  2330.                              else goto exit ;
  2331.     SUM := 0 ;
  2332.     CRC := 0 ;
  2333.  
  2334.     If not ReadChar (InCount) then goto exit ;        (* COUNT *)
  2335.       SUM := SUM + InCount ;
  2336.       CRCheck(InCount) ;
  2337.       InCount := InCount - $20 ; (* To absolute value *)
  2338.  
  2339.     if not ReadChar (INSEQ) then  goto exit ;         (* SEQ   *)
  2340.       SUM := SUM + INSEQ ;
  2341.       CRCheck(INSEQ) ;
  2342.       INSEQ := INSEQ - $20 ;
  2343.  
  2344.     If not ReadChar (INPACKETTYPE ) then goto exit ;  (* TYPE  *)
  2345.       SUM := SUM + INPACKETTYPE ;
  2346.       CRCheck(InPacketType);
  2347.      Checkbytes := 1 ;
  2348.      If (OutPacketType = ord('S')) or
  2349.          (InpacketType = ord('S')) or
  2350.          (InpacketType = ord('R')) then  (* leave Checkbytes := 1 *)
  2351.                                    else
  2352.          If Checktype = ord('2') then Checkbytes := 2  else
  2353.               If Checktype = ord('3') then Checkbytes := 3 ;
  2354.  
  2355.     InDataCount := InCount - 2 - Checkbytes ;
  2356.     IF InDataCount >  0 THEN
  2357.      FOR I := 1 TO InDataCount  DO
  2358.          BEGIN (* Recv Data *)
  2359.          If ReadChar (RecvData[I]) then               (* DATA   *)
  2360.               Begin (* checksum and CRC *)
  2361.               SUM := SUM + RecvData[I] ;
  2362.               CRCheck(RecvData[I]);
  2363.               End  (* checksum and CRC *)
  2364.                                    else
  2365.               goto exit ;
  2366.          END ; (* Revc Data *)
  2367.  
  2368.     RECVPACKET := True ;    (* Assume Ok until check fails *)
  2369.     If Checkbytes = 1 then
  2370.          Begin (* one char Checksum *)
  2371.          CHECKSUM := (SUM + (SUM AND $C0) DIV $40 ) AND $3F ;
  2372.          If ReadChar (INCHAR) then
  2373.               IF INCHAR <> CHECKSUM+$20  THEN  RECVPACKET := FALSE ;
  2374.          End  (* one char Checksum *)
  2375.                       else
  2376.     If Checkbytes = 2 then
  2377.          Begin (* two char Checksum *)
  2378.          Checksum := (Sum div $40) and $3F ;
  2379.          If ReadChar(Inchar) then
  2380.               If Inchar <> Checksum+$20 then RECVPACKET := false ;
  2381.          Checksum := Sum and $3F ;
  2382.          If ReadChar(Inchar) then
  2383.               If Inchar <> Checksum+$20 then RECVPACKET := false ;
  2384.          End   (* two char Checksum *)
  2385.                       else
  2386.     If Checkbytes = 3 then
  2387.          Begin (* CRC char Checksum *)
  2388.          Checksum := (CRC shr 12) and $0F ;
  2389.          If ReadChar(Inchar) then
  2390.           (*  If Inchar <> Checksum+$20 then
  2391.                    Writeln('CRC1 ',Inchar,' ',checksum+$20);    *)
  2392.               If Inchar <> Checksum+$20 then RECVPACKET := false ;
  2393.          Checksum := (CRC shr 6 ) and  $3F ;
  2394.          If ReadChar(Inchar) then
  2395.           (*  If Inchar <> Checksum+$20 then
  2396.                Writeln('CRC2 ',Inchar,' ',checksum+$20); *)
  2397.               If Inchar <> Checksum+$20 then RECVPACKET := false ;
  2398.          Checksum := (CRC       ) and  $3F ;
  2399.          If ReadChar(Inchar) then
  2400.          (*   If Inchar <> Checksum+$20 then
  2401.                    Writeln('CRC3 ',Inchar,' ',checksum+$20); *)
  2402.               If Inchar <> Checksum+$20 then RECVPACKET := false ;
  2403.          End;  (* CRC char Checksum *)
  2404.  
  2405. Exit:
  2406.     END ; (* RECVPACKET procedure  *)
  2407.  
  2408. (* ===============================================================  *)
  2409. (* RESENDIT -  This procedure RESENDS the packet if it gets a nak   *)
  2410. (*             It calls itself recursively upto the number of times *)
  2411. (*             specified in the intial parameter list.              *)
  2412. (* Side Effects - If it fails then the STATE in the message is set  *)
  2413. (*                to 'A' which means ABORT .                        *)
  2414. (*              - Global variable RetryCount is incremented         *)
  2415. (* ===============================================================  *)
  2416. PROCEDURE RESENDIT ( RETRIES : INTEGER ) ;
  2417.  
  2418.     BEGIN (* RESENDIT procedure *)
  2419.     RetryCount := RetryCount + 1 ;
  2420.     IF RETRIES > 0 THEN
  2421.          BEGIN (* Try again *)
  2422.          SENDPACKET ;
  2423.          IF RECVPACKET THEN
  2424.               IF INPACKETTYPE = ord('Y') THEN
  2425.                                          ELSE
  2426.               IF INPACKETTYPE = ord('N') THEN RESENDIT(RETRIES-1)
  2427.                                          ELSE STATE := A
  2428.                        ELSE STATE := A  ;
  2429.          END   (* Try again *)
  2430.                    ELSE STATE := A ;  (* Retries failed - ABORT *)
  2431.     END ; (* RESENDIT procedure  *)
  2432.  
  2433. (* ------------------------------------------------------------ *)
  2434. (*  SendPacketType - Procedure  will send a packet of the       *)
  2435. (*            type specified in  the Character  parameter.      *)
  2436. (*            i.e. SendPacketType('Y')  an ACK packet           *)
  2437. (*                 SendPacketType('N')  an NAK packet           *)
  2438. (* ------------------------------------------------------------ *)
  2439.      PROCEDURE SendPacketType  (PacketType : char);
  2440.          BEGIN (* SEND ACK or NAK or B or Z *)
  2441.          OutDataCount := 0 ;
  2442.          IF PacketType <> 'N' THEN  OUTSEQ := OUTSEQ + 1 ;
  2443.          IF OUTSEQ >= 64 THEN OUTSEQ := 0;
  2444.          OUTPACKETTYPE := Ord(PacketType) ;
  2445.          SENDPACKET ;
  2446.          END ; (* SEND ACK or NAK or B or Z *)
  2447. (* ------------------------------------------------------------ *)
  2448.     PROCEDURE PutInitPacket  ;
  2449.          Begin (* Put Parameters into Init Packet *)
  2450.          OutDataCount := 9 ;
  2451.          OUTSEQ := 0 ;
  2452.          (* The values  are tranformed by adding hex 20 to    *)
  2453.          (* the true value, making the value a printable char *)
  2454.          SendData[1] := PacketSize+ $20 ;  (* Buffsize       *)
  2455.          SendData[2] := Timeout   + $20 ;  (* Time out sec   *)
  2456.          SendData[3] := NumPad    + $20 ;  (* Num padchars   *)
  2457.          SendData[4] := PadChar   + $20 ;  (* Pad char       *)
  2458.          SendData[5] := EndChar   + $20 ;  (* EOL char       *)
  2459.          SendData[6] := CntrlQuote ;      (* Quote character  *)
  2460.          SendData[7] := Bit8Quote ;       (* Quote character  *)
  2461.          SendData[8] := CheckType ;       (* Check Type       *)
  2462.          SendData[9] := RepChar   ;       (* Repeat Character *)
  2463.          IF Bit8Quote = $00 then OutDataCount := 6  (* Don't send bit8_quote *)
  2464.                             else
  2465.               If CheckType = $00 then OutDataCount := 7
  2466.                                  else
  2467.                    If RepChar = $00 then OutDataCount := 8 ;
  2468.          End ; (* Put Parameters into Init Packet *)
  2469. (* ------------------------------------------------------------ *)
  2470.     PROCEDURE GetInitPacket ;
  2471.          Begin  (* Get init parameters *)
  2472.          IF InDataCount >= 1 then   PacketSize := RecvData[1]-$20 ;
  2473.          IF InDataCount >= 2 then   TimeOut    := RecvData[2]-$20 ;
  2474.          IF InDataCount >= 3 then   NumPad     := RecvData[3]-$20 ;
  2475.          IF InDataCount >= 4 then   PadChar    := RecvData[4]-$20 ;
  2476.          IF InDataCount >= 5 then   EndChar    := RecvData[5]-$20 ;
  2477.          IF InDataCount >= 6 then   CntrlQuote := RecvData[6] ;
  2478.          IF InDataCount >= 7 then
  2479.               Begin (* Validate bit8Quote *)
  2480.               Bit8Quote  := RecvData[7] ;
  2481.               If RecvData[7] = ord('Y') then Bit8Quote := ord('&') ;
  2482.               If Not (chr(Bit8Quote) in ['!'..'?','`'..'~'])
  2483.                    then Bit8Quote := 0 ;
  2484.               End  (* Validate bit8Quote *)
  2485.                              else   Bit8Quote  := $00 ;
  2486.          IF (InDataCount >= 8) and (chr(RecvData[8]) in ['1','2','3'] )
  2487.               then   CheckType  := RecvData[8]
  2488.               else   CheckType  := ord('1') ;
  2489.          IF InDataCount >= 9 then
  2490.              If chr(RecvData[9]) in ['!'..'?','`'..'~']
  2491.                    then RepChar := RecvData[9]
  2492.                    else RepChar := $00
  2493.                              else   RepChar    := $00 ;
  2494.          End ;  (* Get init parameters *)
  2495. (* ------------------------------------------------------------ *)
  2496.  
  2497. (* +FILE+ SENDFILE.PASMS *)
  2498. (* **************************************************************** *)
  2499. (* SENDFILE  - This routine handles the sending of a file from    * *)
  2500. (*             the micro computer.                                * *)
  2501. (*                                                                * *)
  2502. (* **************************************************************** *)
  2503.  PROCEDURE SENDFILE (var InParms : ComString);
  2504.  
  2505.  VAR
  2506.     MyFiles,FileName,AsFileNames,AsFileName,Atoken   : Comstring ;
  2507.     SENDING, GETREPLY, LastFile, rawfile    : Boolean ;
  2508.     abyte, Kchar,Kbchar : byte ;
  2509.     ErrorMsg            : String[80];
  2510.     PacketCount,i,ix       : Integer ;
  2511.     FILETOSEND          : File of byte ;
  2512.  
  2513. Label Subdir,GetAsName,GetNextFile,Exit ;
  2514.  
  2515.  
  2516.     (* --------------------------------------------------- *)
  2517.     (* SENDRAW - This routine send the file in unpacket    *)
  2518.     (*           mode, Simply read and send.               *)
  2519.     (* --------------------------------------------------- *)
  2520.     Procedure SENDRAW ;
  2521.     Begin (* SendRaw Procedure *)
  2522.     Sending := true ;
  2523.     While Sending Do
  2524.          Begin (* Send a file *)
  2525.          ClrScr; Writeln('       Sending File >>>>>>> ',Filename,' <<<<<<< ');
  2526.          Assign(FileToSend,Prefixof(Myfiles)+FileName);
  2527.          RESET(FileToSend);
  2528.          While not EOF(FileToSend) do
  2529.               Begin (* Send data *)
  2530.               Read(FileToSend,abyte);
  2531.               SendChar(abyte);
  2532.               If LocalEcho then Write(chr(abyte))
  2533.                            else If Readchar(abyte) then Write(chr(abyte));
  2534.               If XonXoff and (abyte = $0D) then  (* wait for Xon *)
  2535.                   While abyte<>XON do
  2536.                         If Readchar(abyte) then
  2537.                                            else abyte := xon ;
  2538.               End ; (* Send data *)
  2539.          CLOSE(FileToSend);
  2540.          Sending := Nextfile(Myfiles,Filename);
  2541.          End ; (* Send a file *)
  2542.     Writeln(' ');
  2543.     End ; (* SendRaw Procedure *)
  2544.  
  2545. (* **************************************************************** *)
  2546.  
  2547.     BEGIN (* SENDFILE procedure *)
  2548.     rawfile := false ;
  2549.     RetryCount := 0 ;
  2550.   (* Check the file to be sent here *)
  2551.     If length(InParms) < 1 then
  2552.          Begin (* Get name of file to send *)
  2553.          Write  (' Enter name of file to be sent >');
  2554.          Readln(InParms);
  2555.          End;
  2556.     MyFiles := '                                     ';
  2557.     MyFiles := UpperCase(GetToken(InParms));
  2558.     AsFileNames := MyFiles ;
  2559.     Atoken := UpperCase(GetToken(InParms));
  2560.     If Atoken = 'AS' then
  2561.         If length(InParms)<1  then AsFileNames := MyFiles
  2562.                               else AsFileNames := UpperCase(GetToken(InParms))
  2563.                      else
  2564.         If Atoken = 'RAW' then  rawfile := true
  2565.                           else  InParms := Atoken + InParms ;
  2566. subdir:
  2567.  ix := Pos('\',AsFilenames) ;
  2568.  If ix > 1 then delete(AsFilenames,1,ix) ;  (* Eliminate sub-dir  prefixs *)
  2569.  if ix > 1 then goto subdir ;
  2570.  
  2571.     If FirstFile(Myfiles,Filename) then
  2572.                                    else
  2573.          begin (* No file found *)
  2574.          Writeln (' File "',MyFiles,'" not found.');
  2575.          Goto Exit ;
  2576.          end ; (* No file found *)
  2577.     AsFilename := 'Blank' ;
  2578.  
  2579.     If rawfile then
  2580.         begin SendRaw ; goto exit ; end ;
  2581.  
  2582. GetAsName:
  2583. writeln('Filename is =',Filename);
  2584.   If NewAsFile(Myfiles,Filename,AsFileNames,AsFileName) then
  2585.                                                         else
  2586.                  If NextFile(Myfiles,Filename) then goto GetAsName
  2587.                                                else
  2588.          begin (* No file found *)
  2589.          Writeln (' File "',MyFiles,'" not found on disk.');
  2590.          Goto Exit ;
  2591.          end ; (* No file found *)
  2592.  
  2593.     STATE := S ;
  2594.     BreakState := NoBreak ;
  2595.     GETREPLY := FALSE ;
  2596.     LastFile := false ;
  2597.     SENDING := TRUE ;
  2598.     ClrScr;
  2599.     GotoXY(10,4); Write(' Number of Packets Sent = ');
  2600.     GotoXY(10,5); Write(' Number of Retries      = ');
  2601.     PacketCount := 0 ;
  2602.     WHILE SENDING DO
  2603.        BEGIN (* Send files *)
  2604.        IF GETREPLY THEN
  2605.            IF RECVPACKET THEN
  2606.               IF InPacketType = Ord('Y') THEN
  2607.                                     ELSE
  2608.               IF InPacketType = Ord('N') THEN RESENDIT(10)
  2609.                                     ELSE
  2610.               IF InPacketType = Ord('R') THEN STATE := S
  2611.                                     ELSE STATE := A
  2612.                        ELSE  RESENDIT(10) ;
  2613.          GotoXY(36,5); Write (RetryCount);
  2614.          GETREPLY := TRUE ;
  2615.          If (InPacketType = Ord('Y')) and (InDataCount > 1) then
  2616.               If RecvData[1] = Ord('X') then  STATE := SZ  else
  2617.               If RecvData[1] = Ord('Z') then
  2618.                    Begin STATE := SZ ; LastFile := true ;  End ;
  2619.          If STATE = SD then
  2620.           Case Breakstate of
  2621.             NoBreak :  ;
  2622.             BC : Sending := False ;
  2623.             BE : STATE := A ;
  2624.             BX : STATE := SZ ;
  2625.             BZ : Begin STATE := SZ ; LastFile := true ;  End ;
  2626.          End ; (* Case Breakstate *)
  2627.  
  2628.             CASE STATE OF
  2629.     S :  BEGIN (* Send INIT packit *)
  2630.          OutPacketType := Ord('S') ;
  2631.          PutInitPacket ;
  2632.          SENDPACKET ;
  2633.          STATE := SF ;
  2634.          END ; (* Send INIT packit *)
  2635.  
  2636.     SF:  BEGIN (* Send file header *)
  2637. (*       If InDataCount = 0 then
  2638.               Begin    Not a Init packet, Resend our Init Packet
  2639.               GetReply := False;
  2640.               State := S ;
  2641.               End
  2642.                          Else      *)
  2643.               Begin  (* Got Init packet, Get init parameters *)
  2644.               If InDataCount > 1 then GetInitPacket ;
  2645.               OUTSEQ := OUTSEQ + 1 ;
  2646.               IF OUTSEQ >= 64 THEN OUTSEQ := 0 ;
  2647.               OutPacketType := Ord('F') ;
  2648.               OutDataCount := LENGTH(AsFileName);
  2649.               For i := 1 to OutDataCount do SendData[i] := Ord(AsFilename[i]) ;
  2650.               GotoXY(10,2);
  2651.               Write(' Sending file ',Filename,' as ',AsFileName,
  2652.                      '                                   ');
  2653.               Assign(FileToSend,Prefixof(MyFiles)+FileName);
  2654.               RESET(FILETOSEND);
  2655.               STATE := SD ;
  2656.               SENDPACKET ;
  2657.               End  (* Got Init packet, Get init parameters *)
  2658.          END ; (* Send file header *)
  2659.  
  2660.     SD:  BEGIN (* Send data *)
  2661.          OutDataCount := 0 ;
  2662.          OUTSEQ   := OUTSEQ + 1 ;
  2663.          IF OUTSEQ >= 64 THEN OUTSEQ := 0 ;
  2664.          OutPacketType := Ord('D') ;
  2665.          WHILE (OutDataCount<PacketSize-3-4) AND (NOT EOF(FILETOSEND)) DO
  2666.               BEGIN (* Read a char *)
  2667.               OutDataCount := OutDataCount + 1 ;
  2668.               READ(FILETOSEND,abyte);
  2669.               SendData[OutDataCount] := abyte;
  2670.               IF SendData[OutDataCount] >= $80 THEN
  2671.                    IF Bit8Quote = $00 THEN (* No bit8 quoting *)
  2672.                         (* Just drop the 8th bit  *)
  2673.                         SendData[OutDataCount] := SendData[OutDataCount]-$80
  2674.                                        ELSE
  2675.                         BEGIN (* BIT8 QUOTING *)
  2676.                         SendData[OutDataCount+1] := SendData[OutDataCount]-$80;
  2677.                         SendData[OutDataCount] := Bit8Quote ;
  2678.                         OutDataCount := OutDataCount + 1 ;
  2679.                         END ; (* BIT8 QUOTING *)
  2680.               IF SendData[OutDataCount] < $20   THEN
  2681.                    BEGIN (* CONTROL QUOTING *)
  2682.                    SendData[OutDataCount+1] := SendData[OutDataCount] + $40 ;
  2683.                    SendData[OutDataCount] := CntrlQuote ;
  2684.                    OutDataCount := OutDataCount + 1 ;
  2685.                    END ; (* CONTROL QUOTING *)
  2686.               IF SendData[OutDataCount] = $7F THEN
  2687.                    BEGIN (* DEL QUOTING *)
  2688.                    SendData[OutDataCount+1] := $3F ;
  2689.                    SendData[OutDataCount] := CntrlQuote ;
  2690.                    OutDataCount := OutDataCount + 1 ;
  2691.                    END ; (* DEL QUOTING *)
  2692.               IF (SendData[OutDataCount] = CntrlQuote) OR
  2693.                          (SendData[OutDataCount] = Bit8Quote) THEN
  2694.                    BEGIN (* Quote the  quote *)
  2695.                    SendData[OutDataCount+1] := SendData[OutDataCount] ;
  2696.                    SendData[OutDataCount] := CntrlQuote ;
  2697.                    OutDataCount := OutDataCount + 1 ;
  2698.                    END ; (* Quote the  quote *)
  2699.               END ; (* Read a char *)
  2700.  
  2701.          PacketCount := PacketCount + 1 ;
  2702.          GotoXY(36,4) ;  WRITE (PacketCount);
  2703.          IF EOF(FILETOSEND) THEN STATE := SZ ;
  2704.          SENDPACKET ;
  2705.          END ; (* Send data *)
  2706.  
  2707.     SZ:  BEGIN (* End of File *)
  2708.      (*  WRITELN ('end of file');  *)
  2709.          Close(FILETOSEND);
  2710.          GotoXY(10,6) ;
  2711.          If BreakState = NoBreak then
  2712.            WRITELN ('File ',Filename,' has been sent as ',AsFileName,
  2713.                    '                              ')
  2714.                                   else
  2715.            Writeln('File ',Filename,' Partially sent as ',AsFileName,
  2716.                    '                              ');
  2717.          If Lastfile then STATE := SB
  2718.                      else
  2719. GetNextFile:
  2720.          (* Get next file  *)
  2721.          If Nextfile(Myfiles,Filename)  then
  2722.             If NewAsFile(Myfiles,Filename,AsFilenames,AsFilename)
  2723.                      then  STATE := SF
  2724.                      else  goto GetNextFile
  2725.                                         else STATE := SB ;
  2726.         If Breakstate = BX then Breakstate := NoBreak ;
  2727.          SendPacketType('Z') ;
  2728.          END ; (* End of File *)
  2729.  
  2730.     SB:  BEGIN (* Last file sent *)
  2731.   (*     WRITELN ('SENT last file completed');  *)
  2732.          SendPacketType('B') ;
  2733.          STATE := C ;
  2734.          END ; (* Last file sent *)
  2735.  
  2736.      C:  BEGIN (* Completed Sending *)
  2737.          GotoXY(10,7) ;
  2738.          If BreakState = NoBreak then
  2739.               WRITELN ('Sending FILEs completed OK ')
  2740.                                  else
  2741.               WRITELN ('Sending FILEs terminated due to manual Interruption ');
  2742.          SENDING := FALSE ;
  2743.          END ; (* Completed Sending *)
  2744.  
  2745.      A:  BEGIN (* Abort Sending *)
  2746.          Close(FILETOSEND);
  2747.          GotoXY(10,7) ;
  2748.          WRITELN ('SENDing files ABORTED');
  2749.          ABORT := BADSF ;
  2750.          SENDING := FALSE ;
  2751.                (* SEND ERROR packet *)
  2752.               OutDataCount := 15 ;
  2753.               OUTSEQ   := 0 ;
  2754.               ErrorMsg := 'Send file abort' ;
  2755.               for i := 1 to OutDataCount do SendData[i] := Ord(ErrorMsg[i]) ;
  2756.               OutPacketType := Ord('E');
  2757.               SENDPACKET ;
  2758.  
  2759.          END ; (* Abort Sending *)
  2760.               END ; (* CASE of STATE *)
  2761.        END ; (* Send files *)
  2762. Exit:
  2763.     END ; (* SENDFILE procedure *)
  2764.  
  2765. (* +FILE+ SENDFILE.PASCPM *)
  2766. (* **************************************************************** *)
  2767. (* SENDFILE  - This routine handles the sending of a file from    * *)
  2768. (*             the micro computer.                                * *)
  2769. (*                                                                * *)
  2770. (* **************************************************************** *)
  2771. const
  2772.     MaxBlocks = 10 ;
  2773.     MaxBuffer = 2560 ;
  2774. var
  2775.     FileToSend : file;
  2776.     NumRec,Records,Bufferindex,lastchar : integer ;
  2777.     Buffer : Array  [1..MaxBuffer] of byte ;
  2778.     Endfile,Truncate : boolean ;
  2779.     abyte : byte ;
  2780.  
  2781.  
  2782. Procedure ResetFileToSend ;
  2783.     Begin (* ResetFile Procedure *)
  2784.     Reset (FiletoSend);
  2785.     Records := Filesize(FileToSend);
  2786.     EndFile := false ;
  2787.     BufferIndex := 0 ; lastchar := 0 ;
  2788.     End ; (* ResetFile Procedure *)
  2789.  
  2790. Procedure ReadFileToSend (var abyte : byte );
  2791. var i : integer ;
  2792.     Begin (* ReadFile Procedure *)
  2793.     Bufferindex := Bufferindex + 1 ;
  2794.     If Bufferindex > Lastchar then
  2795.       If Records > 0 then
  2796.          Begin (* get next block *)
  2797.          If Records > MaxBlocks then  NumRec := MaxBlocks
  2798.                                 else  NumRec := Records ;
  2799.          BlockRead(FiletoSend,Buffer,Numrec);
  2800.          Records := Records - NumRec ;
  2801.          Bufferindex := 1 ;  Lastchar := NumRec * 128 ;
  2802.          abyte := Buffer[Bufferindex] ;
  2803.          End   (* get next block *)
  2804.                      else
  2805.          EndFile := true
  2806.                               else
  2807.  
  2808.       abyte := Buffer[Bufferindex] ;
  2809.     If (abyte=$1A) and (Records=0) and ((lastchar-bufferindex<128)) then
  2810.          Begin (* probable eof *)
  2811.          EndFile := true ;
  2812.          For i := bufferindex +1 to lastchar-1 do
  2813.              if Buffer[i] <> Buffer[i+1] then EndFile :=  false ;
  2814.          if truncate then EndFile := true ;
  2815.          End ; (* probable eof *)
  2816.     End ; (* ReadFile Procedure *)
  2817.  
  2818.  
  2819.  PROCEDURE SENDFILE (var InParms : ComString);
  2820.  
  2821.  VAR
  2822.     MyFiles,FileName,AsFileNames,AsFileName,Atoken   : Comstring ;
  2823.     SENDING, GETREPLY, LastFile, rawfile    : Boolean ;
  2824.     abyte, Kchar,Kbchar : byte ;
  2825.     achar : char ;
  2826.     ErrorMsg            : String[80];
  2827.     PacketCount,i       : Integer ;
  2828.  
  2829. Label GetAsName,GetNextFile,Exit ;
  2830.  
  2831.  
  2832.     (* --------------------------------------------------- *)
  2833.     (* SENDRAW - This routine send the file in unpacket    *)
  2834.     (*           mode, Simply read and send.               *)
  2835.     (* --------------------------------------------------- *)
  2836.     Procedure SENDRAW ;
  2837.     Begin (* SendRaw Procedure *)
  2838.     Sending := true ;
  2839.     While Sending Do
  2840.          Begin (* Send a file *)
  2841.          ClrScr; Writeln('       Sending File >>>>>>> ',Filename,' <<<<<<< ');
  2842.          Assign(FileToSend,FileName);
  2843.          RESETFileToSend;
  2844.          While not EndFile do
  2845.               Begin (* Send data *)
  2846.               ReadFileToSend(Abyte);
  2847.               SendChar(abyte);
  2848.               If LocalEcho then Write(chr(abyte))
  2849.                            else If Readchar(abyte) then Write(chr(abyte));
  2850.               If XonXoff and (abyte = $0D) then  (* wait for Xon *)
  2851.                   While abyte<>XON do
  2852.                         If Readchar(abyte) then
  2853.                                            else abyte := xon ;
  2854.               End ; (* Send data *)
  2855.          CLOSE(FileToSend);
  2856.          Sending := Nextfile(Myfiles,Filename);
  2857.          End ; (* Send a file *)
  2858.     Writeln(' ');
  2859.     End ; (* SendRaw Procedure *)
  2860.  
  2861. (* **************************************************************** *)
  2862.  
  2863.     BEGIN (* SENDFILE procedure *)
  2864.     rawfile := false ;
  2865.     RetryCount := 0 ;
  2866.   (* Check the file to be sent here *)
  2867.     If length(InParms) < 1 then
  2868.          Begin (* Get name of file to send *)
  2869.          Write  (' Enter name of file to be sent >');
  2870.          Readln(InParms);
  2871.          End;
  2872.     MyFiles := '                                     ';
  2873.     MyFiles := UpperCase(GetToken(InParms));
  2874.     AsFileNames := MyFiles ;
  2875.     Atoken := UpperCase(GetToken(InParms));
  2876.     If Atoken = 'AS' then
  2877.         If length(InParms)<1  then AsFileNames := MyFiles
  2878.                               else AsFileNames := UpperCase(GetToken(InParms))
  2879.                      else
  2880.         If Atoken = 'RAW' then  rawfile := true
  2881.                           else  InParms := Atoken + InParms ;
  2882.     If FirstFile(Myfiles,Filename) then
  2883.                                    else
  2884.          begin (* No file found *)
  2885.          Writeln (' File "',MyFiles,'" not found.');
  2886.          Goto Exit ;
  2887.          end ; (* No file found *)
  2888.     AsFilename := 'Blank' ;
  2889.  
  2890.     If rawfile then
  2891.         begin SendRaw ; goto exit ; end ;
  2892.  
  2893. GetAsName:
  2894.   If NewAsFile(Myfiles,Filename,AsFileNames,AsFileName) then
  2895.                                                         else
  2896.                  If NextFile(Myfiles,Filename) then goto GetAsName
  2897.                                                else
  2898.          begin (* No file found *)
  2899.          Writeln (' File "',MyFiles,'" not found on disk.');
  2900.          Goto Exit ;
  2901.          end ; (* No file found *)
  2902.  
  2903.     STATE := S ;
  2904.     BreakState := NoBreak ;
  2905.     GETREPLY := FALSE ;
  2906.     LastFile := false ;
  2907.     SENDING := TRUE ;
  2908.     ClrScr;
  2909.     GotoXY(10,4); Write(' Number of Packets Sent = ');
  2910.     GotoXY(10,5); Write(' Number of Retries      = ');
  2911.     PacketCount := 0 ;
  2912.     WHILE SENDING DO
  2913.        BEGIN (* Send files *)
  2914.        IF GETREPLY THEN
  2915.            IF RECVPACKET THEN
  2916.               IF InPacketType = Ord('Y') THEN
  2917.                                     ELSE
  2918.               IF InPacketType = Ord('N') THEN RESENDIT(10)
  2919.                                     ELSE
  2920.               IF InPacketType = Ord('R') THEN STATE := S
  2921.                                     ELSE STATE := A
  2922.                        ELSE  RESENDIT(10) ;
  2923.          GotoXY(36,5); Write (RetryCount);
  2924.          GETREPLY := TRUE ;
  2925.          If (InPacketType = Ord('Y')) and (InDataCount > 1) then
  2926.               If RecvData[1] = Ord('X') then  STATE := SZ  else
  2927.               If RecvData[1] = Ord('Z') then
  2928.                    Begin STATE := SZ ; LastFile := true ;  End ;
  2929.          If STATE = SD then
  2930.           Case Breakstate of
  2931.             NoBreak :  ;
  2932.             BC : Sending := False ;
  2933.             BE : STATE := A ;
  2934.             BX : STATE := SZ ;
  2935.             BZ : Begin STATE := SZ ; LastFile := true ;  End ;
  2936.          End ; (* Case Breakstate *)
  2937.  
  2938.             CASE STATE OF
  2939.     S :  BEGIN (* Send INIT packit *)
  2940.          OutPacketType := Ord('S') ;
  2941.          PutInitPacket ;
  2942.          SENDPACKET ;
  2943.          STATE := SF ;
  2944.          END ; (* Send INIT packit *)
  2945.  
  2946.     SF:  BEGIN (* Send file header *)
  2947.          If InDataCount = 0 then
  2948.               Begin    (* Not a Init packet, Resend our Init Packet *)
  2949.               GetReply := False;
  2950.               State := S ;
  2951.               End
  2952.                          Else
  2953.               Begin  (* Got Init packet, Get init parameters *)
  2954.               GetInitPacket ;
  2955.               OUTSEQ := OUTSEQ + 1 ;
  2956.               IF OUTSEQ >= 64 THEN OUTSEQ := 0 ;
  2957.               OutPacketType := Ord('F') ;
  2958.               OutDataCount := LENGTH(AsFileName);
  2959.               For i := 1 to OutDataCount do SendData[i] := Ord(AsFilename[i]) ;
  2960.               GotoXY(10,2);
  2961.               Write(' Sending file ',Filename,' as ',AsFileName,
  2962.                      '                                   ');
  2963.               Assign(FileToSend,FileName);
  2964.               RESETFILETOSEND;
  2965.               STATE := SD ;
  2966.               SENDPACKET ;
  2967.               End  (* Got Init packet, Get init parameters *)
  2968.          END ; (* Send file header *)
  2969.  
  2970.     SD:  BEGIN (* Send data *)
  2971.          OutDataCount := 0 ;
  2972.          OUTSEQ   := OUTSEQ + 1 ;
  2973.          IF OUTSEQ >= 64 THEN OUTSEQ := 0 ;
  2974.          OutPacketType := Ord('D') ;
  2975.          WHILE (OutDataCount<PacketSize-3-4) AND (NOT EndFile)  DO
  2976.               BEGIN (* Read a char *)
  2977.               OutDataCount := OutDataCount + 1 ;
  2978.               ReadFileToSend(Abyte);
  2979.               SendData[OutDataCount] := abyte;
  2980.               IF SendData[OutDataCount] >= $80 THEN
  2981.                    IF Bit8Quote = $00 THEN (* No bit8 quoting *)
  2982.                         (* Just drop the 8th bit  *)
  2983.                         SendData[OutDataCount] := SendData[OutDataCount] -$80
  2984.                                        ELSE
  2985.                         BEGIN (* BIT8 QUOTING *)
  2986.                         SendData[OutDataCount+1] := SendData[OutDataCount]-$80;
  2987.                         SendData[OutDataCount] := Bit8Quote ;
  2988.                         OutDataCount := OutDataCount + 1 ;
  2989.                         END ; (* BIT8 QUOTING *)
  2990.               IF SendData[OutDataCount] < $20   THEN
  2991.                    BEGIN (* CONTROL QUOTING *)
  2992.                    SendData[OutDataCount+1] := SendData[OutDataCount] +$40;
  2993.                    SendData[OutDataCount] := CntrlQuote ;
  2994.                    OutDataCount := OutDataCount + 1 ;
  2995.                    END ; (* CONTROL QUOTING *)
  2996.               IF SendData[OutDataCount] = $7F THEN
  2997.                    BEGIN (* DEL QUOTING *)
  2998.                    SendData[OutDataCount+1] := $3F ;
  2999.                    SendData[OutDataCount] := CntrlQuote ;
  3000.                    OutDataCount := OutDataCount + 1 ;
  3001.                    END ; (* DEL QUOTING *)
  3002.               IF (SendData[OutDataCount] = CntrlQuote) OR
  3003.                          (SendData[OutDataCount] = Bit8Quote) THEN
  3004.                    BEGIN (* Quote the  quote *)
  3005.                    SendData[OutDataCount+1] := SendData[OutDataCount] ;
  3006.                    SendData[OutDataCount] := CntrlQuote ;
  3007.                    OutDataCount := OutDataCount + 1 ;
  3008.                    END ; (* Quote the  quote *)
  3009.               END ; (* Read a char *)
  3010.  
  3011.          PacketCount := PacketCount + 1 ;
  3012.          GotoXY(36,4) ;  WRITE (PacketCount);
  3013.          IF EndFile THEN STATE := SZ ;
  3014.          SENDPACKET ;
  3015.          END ; (* Send data *)
  3016.  
  3017.     SZ:  BEGIN (* End of File *)
  3018.      (*  WRITELN ('end of file');  *)
  3019.          Close(FILETOSEND);
  3020.          GotoXY(10,6) ;
  3021.          If BreakState = NoBreak then
  3022.            WRITELN ('File ',Filename,' has been sent as ',AsFileName,
  3023.                    '                              ')
  3024.                                   else
  3025.            Writeln('File ',Filename,' Partially sent as ',AsFileName,
  3026.                    '                              ');
  3027.          If Lastfile then STATE := SB
  3028.                      else
  3029. GetNextFile:
  3030.          (* Get next file  *)
  3031.          If Nextfile(Myfiles,Filename)  then
  3032.             If NewAsFile(Myfiles,Filename,AsFilenames,AsFilename)
  3033.                      then  STATE := SF
  3034.                      else  goto GetNextFile
  3035.                                         else STATE := SB ;
  3036.         If Breakstate = BX then Breakstate := NoBreak ;
  3037.          SendPacketType('Z') ;
  3038.          END ; (* End of File *)
  3039.  
  3040.     SB:  BEGIN (* Last file sent *)
  3041.   (*     WRITELN ('SENT last file completed');  *)
  3042.          SendPacketType('B') ;
  3043.          STATE := C ;
  3044.          END ; (* Last file sent *)
  3045.  
  3046.      C:  BEGIN (* Completed Sending *)
  3047.          GotoXY(10,7) ;
  3048.          If BreakState = NoBreak then
  3049.               WRITELN ('Sending FILEs completed OK ')
  3050.                                  else
  3051.               WRITELN ('Sending FILEs terminated due to manual Interruption ');
  3052.          SENDING := FALSE ;
  3053.          END ; (* Completed Sending *)
  3054.  
  3055.      A:  BEGIN (* Abort Sending *)
  3056.          Close(FILETOSEND);
  3057.          GotoXY(10,7) ;
  3058.          WRITELN ('SENDing files ABORTED');
  3059.          ABORT := BADSF ;
  3060.          SENDING := FALSE ;
  3061.                (* SEND ERROR packet *)
  3062.               OutDataCount := 15 ;
  3063.               OUTSEQ   := 0 ;
  3064.               ErrorMsg := 'Send file abort' ;
  3065.               for i := 1 to OutDataCount do SendData[i] := Ord(ErrorMsg[i]) ;
  3066.               OutPacketType := Ord('E');
  3067.               SENDPACKET ;
  3068.  
  3069.          END ; (* Abort Sending *)
  3070.               END ; (* CASE of STATE *)
  3071.        END ; (* Send files *)
  3072. Exit:
  3073.     END ; (* SENDFILE procedure *)
  3074.  
  3075. (* +FILE+ RECVFILE.PASMSCPM *)
  3076. (* ------------------------------------------------------------ *)
  3077. (*  BreakACK - Procedure   will send a ACK  plus a break char   *)
  3078. (*              X or Z .                                        *)
  3079. (* ------------------------------------------------------------ *)
  3080.      PROCEDURE BreakACK (Achar : Char);
  3081.          BEGIN (* SEND ACK or NAK *)
  3082.          OutDataCount := 1 ;
  3083.          OUTSEQ   := OUTSEQ + 1 ;
  3084.          IF OUTSEQ >= 64 then OUTSEQ := 0;
  3085.          OUTPACKETTYPE := ord('Y');
  3086.          SendData[1] := Ord(Achar);
  3087.          SENDPACKET ;
  3088.          END ; (* SEND ACK or NAK *)
  3089. (* ------------------------------------------------------------ *)
  3090. (*  RenameDup- Procedure   will check to see if a file is       *)
  3091. (*              already present if it is it returns a new       *)
  3092. (*              name modified with &.                           *)
  3093. (*      Note : this procedure is maybe called recursively.      *)
  3094. (* ------------------------------------------------------------ *)
  3095.      PROCEDURE RenameDup(var MyFile:comstring);
  3096.          BEGIN (* RenameDup  *)
  3097.          If Firstfile(MyFile,MyFile) then
  3098.               Begin (* change name of file *)
  3099.               Insert ('&',Myfile,Pos('.',Myfile));
  3100.               if Pos('.',Myfile) > 9 then
  3101.                    Delete(Myfile,Pos('&',Myfile)-1,1);
  3102.               RenameDup(Myfile);
  3103.               End ; (* change name of file *)
  3104.          END ; (* RenameDup  *)
  3105.  
  3106. (* **************************************************************** *)
  3107. (* RECVFILE  - This routine handles the Receiving of a file from    *)
  3108. (*             the Main frame computer.                             *)
  3109. (*                                                                  *)
  3110. (* **************************************************************** *)
  3111.  PROCEDURE RECVFILE (var InParms : comstring);
  3112. VAR
  3113.     Bit8                      : BYTE ;
  3114.     Lastseqnum                : INTEGER ;
  3115.     Receiving,ReplaceFile     : BOOLEAN ;
  3116.     Retries,PacketCount,
  3117.     CharCount,i,j             : INTEGER ;
  3118.     Filenames,FileName,
  3119.     Myfiles,Myfile,Astring    : ComString ;
  3120.     ErrorMsg                  : ComString ;
  3121.     FileComing                : TEXT ;
  3122.  
  3123. Label Gotinit;
  3124.  
  3125.     (* ------------------------------------------------------------ *)
  3126.     (*  SENDNAK - Procedure of RECVFILE, will check the number of   *)
  3127.     (*            RETRIES , if it is greater than 0 it will send a  *)
  3128.     (*            call SendPacketType('N') which send a NAK packet  *)
  3129.     (*            and decrements the RETRIES by 1.                  *)
  3130.     (*  Side Effect - RETRIES is decremented by 1.                  *)
  3131.     (*                STATE is set to A if no more retries.         *)
  3132.     (*              - RetryCount is incremented                     *)
  3133.     (* ------------------------------------------------------------ *)
  3134.      PROCEDURE SENDNAK ;
  3135.          BEGIN (* SEND  NAK *)
  3136.          RetryCount := RetryCount + 1;
  3137.          IF RETRIES > 0 then
  3138.               BEGIN  (* Ask for a retransmission *)
  3139.               SendPacketType('N');
  3140.               RETRIES := RETRIES - 1 ;
  3141.               END    (* Ask for a retransmission *)
  3142.                         else
  3143.               STATE := A ;
  3144.          END ; (* SEND  NAK *)
  3145.  
  3146.  
  3147.  
  3148.     BEGIN (* ------- RECVFILE procedure ------- *)
  3149.     WRITELN (' RECEIVE file command . ',InParms);
  3150.     Packetcount := 0 ;
  3151.     ReplaceFile := false ;
  3152.     Lastseqnum := 0 ;
  3153.  
  3154.     (* Scan Parameter string *)
  3155.     FileNames := GETTOKEN(InParms);
  3156.     MyFiles := FileNames ;
  3157.     Astring := Uppercase(GetToken(Inparms));
  3158.     If Astring = 'AS' then
  3159.          if length(InParms) > 0 then
  3160.               Begin (* get AS name *)
  3161.               MyFiles := GetToken(Inparms);
  3162.               Astring := Uppercase(GetToken(Inparms));
  3163.               If Pos(Astring,' REPLACE') = 2 then ReplaceFile := True
  3164.                                              else InParms := Astring + InParms;
  3165.               End   (* get AS name *)
  3166.                                 else MyFiles := FileNames
  3167.                       else
  3168.          If Pos(Astring,' REPLACE') = 2 then ReplaceFile := True
  3169.                                         else InParms := Astring + InParms ;
  3170.  
  3171.     If FileNames <> '' then
  3172.          Begin (* Send a R type packet requesting the file *)
  3173.          OutDataCount := length(Filenames);
  3174.          OutSeq := 0 ;
  3175.          OutPacketType := ord('R');
  3176.          For i := 1 to length(Filenames) do
  3177.               SendData[i] := Ord(FileNames[i]) ;
  3178.          WaitXon := false ;
  3179.          SendPacket ;
  3180.          End   (* Send a R type packet requesting the file *)
  3181.                       else
  3182.          WaitXon := XonXoff ;
  3183.     STATE := R ;
  3184.     RECEIVING := TRUE ;
  3185.     BreakState := NoBreak ;
  3186.     RETRIES := 10 ;       (* Up to 10 retries allowed. *)
  3187.     RetryCount := 0 ;
  3188.     clrscr ;
  3189.     GotoXY(10,4) ;
  3190.     Write('Number of Data Packets Received = ');
  3191.     GotoXY(10,5) ;
  3192.     Write('Number of Nak  responses sent   = ');
  3193.     WHILE RECEIVING DO  CASE STATE OF
  3194.  
  3195.     (* R ------ Initial receive State ------- *)
  3196.     (* Valid received msg type  : S           *)
  3197.     R : BEGIN (* Initial Receive State  *)
  3198.         If InPacketType =Ord('S')  then goto Gotinit;
  3199.         IF (NOT RECVPACKET) OR (INPACKETTYPE=Ord('N')) then  SENDNAK
  3200.                                                        else
  3201. Gotinit:
  3202.         (* Get a packet *)
  3203.         IF INPACKETTYPE = Ord('S') then
  3204.               BEGIN (* Got INIT packet *)
  3205.               GetInitPacket ;  (* Get Init parameters *)
  3206.               (* Reply with ACK and init parameters *)
  3207.               OutPacketType := Ord('Y');
  3208.               PutInitPacket ;
  3209.               SENDPACKET ;
  3210.               STATE := RF ;
  3211.               END   (* Got  INIT  packet *)
  3212.                               else
  3213.               BEGIN (* Not init packet *)
  3214.               STATE := A ;   (* ABORT if not INIT packet *)
  3215.               ABORT := NOT_S ;
  3216.               END ; (* Not init packet *)
  3217.         END ; (* Initial Receive State  *)
  3218.  
  3219.  
  3220.     (* RF ----- Receive Filename State ------- *)
  3221.     (* Valid received msg type  : S,Z,F,B     *)
  3222.     RF: IF (NOT RECVPACKET) OR (INPACKETTYPE=Ord('N')) then  SENDNAK
  3223.                                                        else
  3224.         (* Get a packet *)
  3225.         IF INPACKETTYPE = Ord('S') then STATE:=R             else
  3226.         IF INPACKETTYPE = Ord('Z') then SendPacketType('N')  else
  3227.         IF INPACKETTYPE = Ord('B') then STATE:=C             else
  3228.         IF INPACKETTYPE = Ord('F') then
  3229.               BEGIN (* Got file header *)
  3230.               For i := 1 to InDataCount do
  3231.                    FileName[i] := Chr(RecvData[i]) ;
  3232.               FileName[0] := Chr(InDataCount) ;
  3233.               If Filenames = '' then
  3234.                   Myfile := Filename
  3235.                                  else
  3236.                   If NewAsfile(Filenames,Filename,MyFiles,Myfile) then;
  3237.               GotoXY(10,2);
  3238.               If ReplaceFile then (* write over old file *)
  3239.                              else ReNameDup(Myfile);
  3240.               Writeln('Receiving file ',Filename,' as ',Myfile,
  3241.                        '                          ');
  3242.               Assign(FileComing,Prefixof(Filenames)+MyFile);
  3243.               STATE := RD ;
  3244.               If not ForPrinter then
  3245.                      Begin {$I-}
  3246.                      REWRITE(FileComing);
  3247.                      If IOresult <> 0 then
  3248.                         Begin (* IO error *)
  3249.                         Writeln(' Directory Full ');
  3250.                         STATE := A ;
  3251.                         SendPacketType('N');
  3252.                         End ; (* IO error *)
  3253.                      End ; {$I+}
  3254.               SendPacketType('Y');
  3255.               END   (* Got file header *)
  3256.                                    else
  3257.          BEGIN (* Not S,F,B,Z packet *)
  3258.          STATE := A ;   (* ABORT if not a S,F,B,Z type packet *)
  3259.          ABORT := NOT_SFBZ ;
  3260.          END ; (* Not S,F,B,Z packet *)
  3261.  
  3262.  
  3263.     (* RD ----- Receive Data State ------- *)
  3264.     (* Valid received msg type  : D,Z      *)
  3265.     RD: IF (NOT RECVPACKET) OR (INPACKETTYPE=Ord('N')) then SENDNAK
  3266.                                                        else
  3267.         If lastseqnum = inseq then  SendPacketType('Y')
  3268.                               else
  3269.         BEGIN  (* Got a good packet *)
  3270.         lastseqnum := inseq ;
  3271.         IF INPACKETTYPE = Ord('D') then
  3272.               BEGIN (* Receive data *)
  3273.         (*    WRITELN ('RECEIVE data ');  *)
  3274.               PacketCount := PacketCount + 1 ;
  3275.               GotoXY(44,4) ; Write (PacketCount);
  3276.               GotoXY(44,5) ; Writeln(RetryCount);
  3277.               I := 1 ;
  3278.               WHILE I <= InDataCount DO
  3279.                  BEGIN (* Write Data to file  *)
  3280.                    IF RecvData[I] = RepChar   then
  3281.                         BEGIN (* Repeat char   *)
  3282.                         I := I+1 ;
  3283.                         charcount := RecvData[I] - 32 ;
  3284.                         I := I + 1 ;
  3285.                         For j := 1 to charcount - 1 do
  3286.                             If ForPrinter then  Write(LST,Chr(RecvData[i]))
  3287.                                           else
  3288.                      Begin {$I-}
  3289.                      Write(FileComing,Chr(RecvData[i]));
  3290.                      If IOresult <> 0 then
  3291.                         Begin (* IO error *)
  3292.                         Writeln(' Disk is Full or file too large');
  3293.                         STATE := A ;
  3294.                         SendPacketType('N');
  3295.                         End ; (* IO error *)
  3296.                      End ; {$I+}
  3297.  
  3298.                         END ;  (* Repeat char  *)
  3299.                    IF RecvData[I] = Bit8Quote then
  3300.                         BEGIN (* 8TH BIT QUOTING  *)
  3301.                         I := I+1 ;
  3302.                         BIT8 := $80 ;
  3303.                         END   (* 8TH BIT QUOTING  *)
  3304.                                             else
  3305.                         BIT8 := 0 ;
  3306.                    IF RecvData[I] = CntrlQuote then
  3307.                         BEGIN (* CONTROL character *)
  3308.                         I := I+1 ;
  3309.                         IF RecvData[I] = $3F then   (* Make it a del *)
  3310.                                                    RecvData[I] := $7F
  3311.                                              else
  3312.                         IF RecvData[I] >= 64 then   (* Make it a control *)
  3313.                                           RecvData[I] := RecvData[I] - 64 ;
  3314.  
  3315.                        END ; (* CONTROL character *)
  3316.                    RecvData[I] := RecvData[I] + BIT8 ;
  3317.                    If ForPrinter then  Write(LST,Chr(RecvData[i]))
  3318.                                  else
  3319.                      Begin {$I-}
  3320.                      Write(FileComing,Chr(RecvData[i]));
  3321.                      If IOresult <> 0 then
  3322.                         Begin (* IO error *)
  3323.                         Writeln(' Disk is Full or file too large');
  3324.                         STATE := A ;
  3325.                         SendPacketType('N');
  3326.                         End ; (* IO error *)
  3327.                      End ; {$I+}
  3328.                  I := I + 1 ;
  3329.                  END ; (* Write Data to File *)
  3330.               Case Breakstate of
  3331.                    NoBreak : SendPacketType('Y');
  3332.                    BC : RECEIVING:=false ;
  3333.                    BE : SendPacketType('N') ;
  3334.                    BX : BreakAck('X') ;
  3335.                    BZ : BreakAck('Z') ;
  3336.                End; (* Case BreakState *)
  3337.               If Breakstate <> NoBreak then
  3338.               Writeln('Receiving file ',Filename,' as ',Myfile,' Interrupted');
  3339.               If BreakState = BX then Breakstate := NoBreak ;
  3340.               END   (* Receive data *)
  3341.                               else
  3342.          IF INPACKETTYPE = Ord('F') then
  3343.               BEGIN (* repeat *)
  3344.               OutSeq := OutSeq - 1 ;
  3345.               SendPacketType('Y') ;
  3346.               END   (* repeat *)
  3347.                               else
  3348.          IF INPACKETTYPE = Ord('Z') then
  3349.               BEGIN (* End of Incoming File *)
  3350.               If not ForPrinter then
  3351.                      Begin {$I-}
  3352.                      CLOSE(FileComing);
  3353.                      If IOresult <> 0 then
  3354.                         Begin (* IO error *)
  3355.                         Writeln(' Disk is Full or file too large');
  3356.                         End ; (* IO error *)
  3357.                      End ; {$I+}
  3358.               STATE := RF ;
  3359.               SendPacketType('Y');
  3360.               END   (* End of Incoming File *)
  3361.                               else
  3362.          BEGIN (* Not D,Z packet *)
  3363.          STATE := A;   (* ABORT - Type not  D,Z, *)
  3364.          ABORT := NOT_DZ ;
  3365.          END ; (* Not D,Z packet *)
  3366.         END ;  (* Got a good packet *)
  3367.  
  3368.  
  3369.     (* C ----- COMPLETED  State ------- *)
  3370.      C:  BEGIN (* COMPLETED Receiving *)
  3371.          SendPacketType('Y');
  3372.          If BreakState = NoBreak then
  3373.               Writeln ('Receiving files completed OK.')
  3374.                                  else
  3375.               Writeln('Receiving Files terminated by manual interruption');
  3376.          RECEIVING := FALSE ;
  3377.          END ; (* COMPLETED Receiving *)
  3378.  
  3379.     (* A ----- A B O R T  State ------- *)
  3380.      A:  BEGIN (* Abort Sending *)
  3381.          {$I-}
  3382.          CLOSE(FileComing);
  3383.          If IOresult <> 0 then
  3384.                  Writeln(' Unable to close file, is DISK FULL ');
  3385.          {$I+}
  3386.          WRITELN ('RECEIVEing files ABORTED');
  3387.          RECEIVING := FALSE ;
  3388.          (* SEND ERROR packet *)
  3389.          OutSeq   := 0 ;
  3390.          ErrorMsg :=' RECVfile abort' ;
  3391.          OutDataCount := length(ErrorMsg) ;
  3392.          For i := 1 to length(ErrorMsg) do
  3393.               SendData[i] := Ord(ErrorMsg[i]) ;
  3394.          OutPacketType := Ord('E');
  3395.          SENDPACKET ;
  3396.          END ; (* Abort Sending *)
  3397.  
  3398.          END ; (* CASE of STATE *)
  3399.  
  3400.     END ; (* ------- RECVFILE procedure -------*)
  3401.  
  3402. (* +FILE+ CONNECT.PASVT52 *)
  3403. (* ================================================================== *)
  3404. (*  Global Var                                                        *)
  3405. (* ================================================================== *)
  3406. Const
  3407.      Gversion = '  ' ;
  3408.      TermType = ' VT52   ' ;
  3409.      Graphics = '- Not applicable         ' ;
  3410. (* ================================================================== *)
  3411. (* ReadkeyTable - Dummy procedure                                     *)
  3412. (* ================================================================== *)
  3413. Procedure ReadKeyTable ; Begin End ;
  3414.  
  3415. (* ================================================================== *)
  3416. (*  Connection - Connect to the other computer and simulates          *)
  3417. (*               a VT52 type terminal .                               *)
  3418. (*                                                                    *)
  3419. (* ================================================================== *)
  3420. Procedure Connection ;
  3421.     VAR
  3422.          achar,bchar : byte ;
  3423.          i : integer ;
  3424.      (* -------------------------------------------------------- *)
  3425.          Procedure Escape ;
  3426.          Type
  3427.              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);
  3428.          Var
  3429.               Xpos,Ypos : byte ;
  3430.  
  3431.          Begin (* Escape Sequence *)
  3432.          If Readchar(achar) then
  3433.              CASE EscapeType(achar-$41) of
  3434.            A: CursorUp ;    (* System Dependent Routine *)
  3435.            B: CursorDown ;  (* System Dependent Routine *)
  3436.            C: CursorRight ; (* System Dependent Routine *)
  3437.            D: CursorLeft ;  (* System Dependent Routine *)
  3438.            H: (* Clear Screen *)
  3439.               If ReadChar(achar) then    (* read next ESC char *)
  3440.                  If ReadChar(achar) then  (* read J char *)
  3441.                     ClrScr;
  3442.            K: ClrEol ;
  3443.            Y: Begin (* Cursor Position *)
  3444.               If ReadChar(achar) then Ypos := achar - $1F ;
  3445.               If ReadChar(achar) then Xpos := achar - $1F ;
  3446.               GotoXY(Xpos,Ypos);
  3447.               End ; (* Cursor Position *)
  3448.              End ; (* Case *)
  3449.          End ; (* Escape Sequence *)
  3450.     (* -------------------------------------------------------- *)
  3451.          Procedure RemoteCommand  ;
  3452.          Var
  3453.               i : integer ;
  3454.               Filename : Comstring ;
  3455.          Begin (* RemoteCommand procedure *)
  3456.          GotSOH := true ;
  3457.          If RecvPacket then
  3458.               Begin (* Got a Packet *)
  3459.               If  InPacketType = Ord('S') then        (* Send Packet *)
  3460.                    Begin (* Receive *)
  3461.                    writeln('Got a Send    request ');
  3462.                    Filename :=  '' ;
  3463.                    RecvFile(filename);
  3464.                    End   (* Receive *)
  3465.                                           else
  3466.               If  InPacketType = Ord('R') then        (* Receive Packet *)
  3467.                    Begin (* Receive *)
  3468.                    writeln('Got a receive request ');
  3469.                    for i := 1 to InCount-3 do
  3470.                        filename[i] := chr(RecvData[i]);
  3471.                    Filename[0] :=  chr(InCount-3) ;
  3472.                    waitxon := XonXoff ;
  3473.                    SendFile(filename);
  3474.                    End   (* Receive *)
  3475.                                           else
  3476.               If  InPacketType = Ord('G') then        (* General Packet *)
  3477.                    Begin (* Receive *)
  3478.                    writeln('Got a General request ');
  3479.                    SendPacketType('Y');
  3480.                    End   (* Receive *)
  3481.                                           else
  3482.  
  3483.                    Begin (* Unknow packet Type *)
  3484.                    OutCount := 15 ;
  3485.                    Outseq := 0 ;
  3486.                    OutPacketType := Ord('E');
  3487.         (*           SendData := 'Unknow Command';  *)
  3488.                    End;   (* Unknown packet Type *)
  3489.               End   (* Got a Packet *)
  3490.          End ; (* RemoteCommand Procedure *)
  3491.     (* -------------------------------------------------------- *)
  3492.  
  3493.     Begin (* Connection *)
  3494.     DialModem ;
  3495.     RemoteScreen ;      (* Save local screen, restore remote screen *)
  3496.     While connected do
  3497.          Begin (* connected *)
  3498.          If RecvChar(achar) then
  3499.               if achar < $20 then
  3500.                    Begin (* Control Character *)
  3501.                    if achar = SOH then RemoteCommand
  3502.                                   else
  3503.                    if achar = EOT then connected := false
  3504.                                   else
  3505.                    if achar = ESC then Escape
  3506.                                   else
  3507.                         if achar in [7,8,10,13] then write(chr(achar));
  3508.                    End   (* Control Character *)
  3509.                              else
  3510.                    If achar <> DEL then  write(chr(achar));
  3511.  
  3512.          if KeyChar(achar,bchar) then
  3513.               Begin (* key input *)
  3514.               if achar = $00 then
  3515.                 if bchar = 83 then SendChar($7F)    (* DEL *)
  3516.                               else
  3517.                 if bchar = 82 then SendChar($19)     (* INS *)
  3518.                               else
  3519.                    Begin (* Special Key *)
  3520.                    SendChar(Esc);
  3521.                      CASE bchar of
  3522.                    $3B,$3C,$3D,$3E,$3F,$40,$41,$42,$43:
  3523.                        SendChar(bchar-10);      (* PF1 to PF9 keys *)
  3524.                    $44: SendChar($30) ;            (* PF10 key *)
  3525.                    $54: SendChar($2D) ;            (* PF11 key *)
  3526.                    $55: SendChar($3D) ;            (* PF12 key *)
  3527.                    $56: SendChar($71) ;            (* PF13 key *)
  3528.                    $57: SendChar($77) ;            (* PF14 key *)
  3529.                    $58: SendChar($65) ;            (* PF15 key *)
  3530.                    $59: SendChar($72) ;            (* PF16 key *)
  3531.                    $5A: SendChar($74) ;            (* PF17 key *)
  3532.                    $5B: SendChar($79) ;            (* PF18 key *)
  3533.                    $5C: SendChar($75) ;            (* PF19 key *)
  3534.                    $5D: SendChar($69) ;            (* PF20 key *)
  3535.  
  3536.                    $48: SendChar($41) ;            (* Esc A - up arrow *)
  3537.                    $50: SendChar($42) ;            (* Esc B - down arrow *)
  3538.                    $4D: SendChar($43) ;            (* Esc C - rightarrow *)
  3539.                    $4B: SendChar($44) ;            (* Esc D - left arrow *)
  3540.                    $47,$4C:
  3541.                         SendChar($48) ;            (* Esc H - home arrow *)
  3542.                    $51,$77:
  3543.                         SendChar($4A) ;            (* Esc J - Clear      *)
  3544.                    $4F,$75:
  3545.                         SendChar($4B) ;            (* Esc K - Erase Eol  *)
  3546.                      End; (* Case bchar *)
  3547.                    End   (* Special Key *)
  3548.                              else
  3549.                    Begin (* Normal Key *)
  3550.                    if achar = LocalChar then connected := false else
  3551.                    if achar = BreakChar then SendBreak
  3552.                                   else Sendchar(achar);
  3553.                    if LocalEcho and connected then write(chr(achar));
  3554.                    End ; (* Normal Key *)
  3555.              End; (* key input *)
  3556.          End; (* connected *)
  3557.     LocalScreen ;  (* save remote screen , restore local screen *)
  3558.     End ; (* Connection *)
  3559.  
  3560. (* +FILE+ CONNECT.PASADM3A *)
  3561. (* ================================================================== *)
  3562. (*  Global Declarations - for ADM3A type of terminal emulation        *)
  3563. (* ================================================================== *)
  3564. Const
  3565.     Gversion = '  ' ;
  3566.     TermType = ' ADM3A  ' ;
  3567.     Graphics = '- Not Implemented        ' ;
  3568.  
  3569. Procedure ReadKeytable ;
  3570.      Begin End ;  (* dummy procedure - for MsDos systems only *)
  3571.  
  3572. (* ================================================================== *)
  3573. (*  Connection - Connect to the other computer and simulates          *)
  3574. (*               a DUMB      terminal .                               *)
  3575. (*                                                                    *)
  3576. (* ================================================================== *)
  3577. Procedure Connection ;
  3578.     VAR
  3579.          achar,bchar : byte ;
  3580.          i : integer ;
  3581.     (* -------------------------------------------------------- *)
  3582.          Procedure RemoteCommand  ;
  3583.          Var
  3584.               i : integer ;
  3585.               Filename : Comstring ;
  3586.          Begin (* RemoteCommand procedure *)
  3587.          GotSOH := true ;
  3588.          If RecvPacket then
  3589.               Begin (* Got a Packet *)
  3590.               If  InPacketType = Ord('S') then        (* Send Packet *)
  3591.                    Begin (* Receive *)
  3592.                    writeln('Got a Send    request ');
  3593.                    Filename :=  '' ;
  3594.                    RecvFile(filename);
  3595.                    End   (* Receive *)
  3596.                                           else
  3597.               If  InPacketType = Ord('R') then        (* Receive Packet *)
  3598.                    Begin (* Receive *)
  3599.                    writeln('Got a receive request ');
  3600.                    for i := 1 to InCount-3 do
  3601.                        filename[i] := chr(RecvData[i]);
  3602.                    Filename[0] :=  chr(InCount-3) ;
  3603.                    waitxon := XonXoff ;
  3604.                    SendFile(filename);
  3605.                    End   (* Receive *)
  3606.                                           else
  3607.               If  InPacketType = Ord('G') then        (* General Packet *)
  3608.                    Begin (* Receive *)
  3609.                    writeln('Got a General request ');
  3610.                    SendPacketType('Y');
  3611.                    End   (* Receive *)
  3612.                                           else
  3613.  
  3614.                    Begin (* Unknow packet Type *)
  3615.                    OutCount := 15 ;
  3616.                    Outseq := 0 ;
  3617.                    OutPacketType := Ord('E');
  3618.         (*           SendData := 'Unknow Command';  *)
  3619.                    End;   (* Unknown packet Type *)
  3620.               End   (* Got a Packet *)
  3621.          End ; (* RemoteCommand Procedure *)
  3622.     (* -------------------------------------------------------- *)
  3623.  
  3624.     Begin (* Connection *)
  3625.     DialModem ;
  3626.     RemoteScreen ;      (* Save local screen, restore remote screen *)
  3627.     While connected do
  3628.          Begin (* connected *)
  3629.          If RecvChar(achar) then
  3630.               if achar = SOH then RemoteCommand
  3631.                              else
  3632.               if achar = EOT then connected := false
  3633.                              else
  3634.                    if achar in [17,19,127] then  (* don't write *)
  3635.                                            else Ritechar(achar);
  3636.  
  3637.          if KeyChar(achar,bchar) then
  3638.               Begin (* key input *)
  3639.                    Begin (* Normal Key *)
  3640.                    if LocalEcho then Ritechar(achar);
  3641.                    if achar = LocalChar then connected := false else
  3642.                    if achar = BreakChar then SendBreak
  3643.                                         else Sendchar(achar);
  3644.                    End ; (* Normal Key *)
  3645.              End; (* key input *)
  3646.          End; (* connected *)
  3647.     LocalScreen ;  (* save remote screen , restore local screen *)
  3648.     End ; (* Connection *)
  3649.  
  3650. (* +FILE+ CONNECT.PASVT100 *)
  3651. (* ================================================================== *)
  3652. (*  Global Var and Procedures for special key specifications.         *)
  3653. (* ================================================================== *)
  3654. Const
  3655.      Gversion = '  ' ;
  3656.      TermType = ' VT100  ' ;
  3657.      Graphics = '- Not applicable         ' ;
  3658.  
  3659. Var
  3660.      EscSeq : Array [1..$88,1..2] of char ;
  3661.      KeyTableName : String[14] ;
  3662.      KeyTable : Text ;
  3663. (*------------------------------------------------------------------- *)
  3664. Function hexinteger (chars : string2): byte ;
  3665.     begin (* HexInteger *)
  3666.     If chars[1] in ['A'..'F'] then chars[1]:=chr(ord(chars[1])+9);
  3667.     If chars[2] in ['A'..'F'] then chars[2]:=chr(ord(chars[2])+9);
  3668.     hexinteger := (ord(chars[1]) shl 4) + (ord(chars[2]) and $0F) ;
  3669.     end  ; (* HexInteger *)
  3670. (*------------------------------------------------------------------- *)
  3671.  
  3672. Procedure ReadKeytable ;
  3673. var I : integer ;
  3674.     Newname : string[15] ;
  3675.     comment : string[80] ;
  3676. label retry ;
  3677.  
  3678.     Begin (* ReadKeytable *)
  3679.     keytablename := 'KEYTABLE.DAT' ;
  3680.     Assign(keytable,keytablename) ;
  3681. retry :
  3682.     {$I-}  Reset(keytable);  {$I+}
  3683.     If IORESULT = 0 then
  3684.          Begin (* Initiate key table *)
  3685.          For i := 1 to $88 do
  3686.               Begin (* init EscSeq table *)
  3687.               Readln(KeyTable,EscSeq[i,1],EscSeq[i,2],comment) ;
  3688.               If copy(comment,2,2) <> '  ' then
  3689.                  EscSeq[i,1] := Chr(HexInteger(copy(comment,2,2))) ;
  3690.               If copy(comment,4,2) <> '  ' then
  3691.                  EscSeq[i,2] := Chr(HexInteger(copy(comment,4,2))) ;
  3692.               End ; (* init EscSeq table *)
  3693.          Close(keytable);
  3694.          End   (* Initiate key table *)
  3695.                   else
  3696.          Begin (* Warning *)
  3697.          ClrScr ;
  3698.          Writeln('*** File ',Keytablename,' not found on drive.');
  3699.          Writeln('    Please specify drive or new name of keytable file. ');
  3700.          Readln(newname);
  3701.          If Length(Newname) = 1 then
  3702.               keytablename := Newname + ':' + keytablename
  3703.                                 else
  3704.               keytablename := Newname ;
  3705.          Assign(keytable,keytablename);
  3706.          If length(keytablename)<3 then Running := false
  3707.                                    else Goto Retry ;
  3708.          End ; (* Warning *)
  3709.     End ; (* ReadKeytable *)
  3710.  
  3711. const
  3712.      APLTABLE : array [0..127] of byte =
  3713. {00}  ($00,$01,$02,$03,$04,$05,$06,$07,$08,$09,$0A,$0B,$0C,$0D,$0E,$0F,  {0F}
  3714. {01}   $10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$1A,$1B,$1C,$1D,$1E,$1F,  {1F}
  3715. {02}   $20,$05,$29,$3C,$F3,$3D,$3E,$5D,$FA,$5E,$86,$F6,$2C,$2B,$2E,$2F,  {1F}
  3716. {03}   $30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$28,$5B,$3B,$78,$3A,$5C,  {3F}
  3717. {04}   $FD,$E0,$E6,$EF,$8F,$EE,$5F,$EC,$91,$E2,$F8,$27,$95,$FE,$E7,$F9,  {4F}
  3718. {05}   $2A,$3F,$FB,$8D,$7E,$19,$FC,$17,$0E,$18,$0B,$1B,$1D,$1A,$F2,$2D,  {5F}
  3719. {06}   $40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$4A,$4B,$4C,$4D,$4E,$4F,  {6F}
  3720. {07}   $50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$5A,$7B,$1C,$7D,$24,$2D); {7F}
  3721.    Over1 = 'T('#$E5'T)'#$EA'GM'#$1F'HM'#$1E'OM'#$E8'O?'#$ED'O_'#$E9'OP'#$0F ;
  3722.    Over2 = 'BN'#$15'GT'#$13'BJ'#$F5'NJ'#$F4'?_'#$A7'/_'#$EB'CJ'#$A6'KL'#$97 ;
  3723.    Over3 = 'K.'#$21'L+'#$98 ;
  3724.    Over4 = 'aFabFbcFcdFdeFefFfgFghFhiFijFjkFklFlmFmnFnoFopFpqFqrFrsFs' ;
  3725.    Over5 = 'tFtuFuvFvwFwxFxyFyzFz' ;
  3726. (* ================================================================== *)
  3727. (*  Connection - Connect to the other computer and simulates          *)
  3728. (*               a VT100 type terminal .                              *)
  3729. (*                                                                    *)
  3730. (* ================================================================== *)
  3731.  
  3732. Procedure Connection ;
  3733.     VAR
  3734.          achar,bchar : byte ;
  3735.          i : integer ;
  3736.          overchar : string[2] ;
  3737.          overchars : string[160] ;
  3738.          EscapeFlag : boolean ;
  3739.     (* -------------------------------------------------------- *)
  3740.     Procedure Escape ;
  3741.          Var Pn,Pc : byte ;
  3742.  
  3743.          Function PNumber (var achar : byte) : integer ;
  3744.           var Numstr : string[3];
  3745.               Num,result : integer ;
  3746.               Begin (* PNumber *)
  3747.               Numstr := '' ;
  3748.               While chr(achar) in ['0'..'9']  do
  3749.                    Begin (* get number *)
  3750.                    Numstr := Numstr + chr(achar) ;
  3751.                    If Readchar(achar) then ;
  3752.                    End ; (* get number *)
  3753.               Val(Numstr,Num,Result);
  3754.               PNumber := Num ;
  3755.               End ; (* PNumber *)
  3756.  
  3757.     Begin (* Escape Sequence *)
  3758.     If Readchar(achar) then
  3759.     CASE chr(achar) of  (* First Level *)
  3760.          '[':
  3761.                If Readchar(achar) then
  3762.                CASE chr(achar) of   (* Second level *)
  3763.                  'C': CursorRight ;
  3764.                  'D': CursorLeft  ;
  3765.                  'J': ClrScr ; (* Erase End of Display *)
  3766.                  'K': ClrEol ; (* Erase End of Line *)
  3767.                  '?': ;        (* Special functions - not yet implemented *)
  3768.                  'H': GoToXY(0,0);  (* Cursor Home *)
  3769.                  'm':(* NormVideo*) ;  (* Exit all attribute modes *)
  3770.                 else
  3771.                      Begin (* Esc [ Pn x   functions *)
  3772.                      Pn := PNumber(achar);
  3773.                      CASE chr(achar) of (* third level *)
  3774.                         'A': For i := 1 to Pn do Cursorup ;
  3775.                         'B': For i := 1 to Pn do Cursordown ;
  3776.                         'C': For i := 1 to Pn do CursorRight ;
  3777.                         'D': For i := 1 to Pn do CursorLeft ;
  3778.                         ';': Begin (* Direct cursor addressing *)
  3779.                              If readchar(achar) then ;
  3780.                              Pc := PNumber (achar);
  3781.                              GoToXY(Pc,Pn);
  3782.                              If (pn<1) or (pc<1) then
  3783.                               writeln('***',pn,' ',pc,'***');
  3784.                              End ; (* Direct cursor addressing *)
  3785.                         'q': FatCursor(Pn=1) ;
  3786.                         'm',
  3787.                         '}':
  3788.                              Case Pn of      (* Field specs *)
  3789.                              0: begin (* Normal *)
  3790.                                 TextColor(LightGray);
  3791.                                 Textbackground(black);
  3792.                                 end ;
  3793.                              1: begin (* High Intensity *)
  3794.                                 TextColor(White);
  3795.                                 Textbackground(black);
  3796.                                 end ;
  3797.                              4: begin (* Underline *)
  3798.                                 TextColor(White);
  3799.                                 Textbackground(black);
  3800.                                 end ;
  3801.                              5: begin (* Blink *)
  3802.                                 TextColor(White+ blink);
  3803.                                 Textbackground(black);
  3804.                                 end ;
  3805.                              7: begin (* Reverse *)
  3806.                                 TextColor(Black);
  3807.                                 Textbackground(white);
  3808.                                 end ;
  3809.                              8: begin (* Invisible *)
  3810.                                 TextColor(Black);
  3811.                                 Textbackground(black);
  3812.                                 end ;
  3813.                             30: Textcolor(Black);
  3814.                             31: Textcolor(Red);
  3815.                             32: Textcolor(Green);
  3816.                             33: Textcolor(yellow);
  3817.                             34: Textcolor(Blue);
  3818.                             35: Textcolor(Magenta);
  3819.                             36: Textcolor(Cyan);
  3820.                             37: Textcolor(White);
  3821.  
  3822.                             40: Textbackground(Black);
  3823.                             41: Textbackground(Red);
  3824.                             42: Textbackground(Green);
  3825.                             43: Textbackground(Yellow);
  3826.                             44: Textbackground(Blue);
  3827.                             45: Textbackground(Magenta);
  3828.                             46: Textbackground(Cyan);
  3829.                             47: Textbackground(White);
  3830.  
  3831.                              End ; (* case of Field specs *)
  3832.                         'J': Case Pn of
  3833.                              0: ClrScr ;
  3834.                              1: ClrScr ; (* clear to beginning *)
  3835.                              2: ClrScr ;
  3836.                              End ; (*  J - Pn Case *)
  3837.                         'K': Case Pn of
  3838.                              1: ClrEol ; (* clear to beginning *)
  3839.                              2: ClrEol ; (* clear line *)
  3840.                              End ; (*  J - Pn Case *)
  3841.                         'L': For i := 1 to Pn do InsLine ; (* Insert Line *)
  3842.                         'M': For i := 1 to Pn do DelLine ; (* Delete Line *)
  3843.                         '@': For i := 1 to Pn do (* InsertChar *)  ;
  3844.                         'P': For i := 1 to Pn do (* DeleteChar *)  ;
  3845.                      End ; (* Case third level *)
  3846.                      End ; (* Esc [ Pn x   functions *)
  3847.  
  3848.                End ; (* second level Case *)
  3849.  
  3850.          'D': CursorDown ;    (* Index *)
  3851.          'M': CursorUp   ;    (* Reverse Index *)
  3852.          'H':            ;    (* Set Tab Stop *)
  3853.          '(':            ;    (* G0 *)
  3854.          ')':            ;    (* G1 *)
  3855.          End ; (* First Level Case  *)
  3856.  
  3857.     End ; (* Escape Sequence *)
  3858.     (* -------------------------------------------------------- *)
  3859.          Procedure RemoteCommand  ;
  3860.          Var
  3861.               i : integer ;
  3862.               Filename : Comstring ;
  3863.          Begin (* RemoteCommand procedure *)
  3864.          GotSOH := true ;
  3865.          If RecvPacket then
  3866.               Begin (* Got a Packet *)
  3867.               If  InPacketType = Ord('S') then        (* Send Packet *)
  3868.                    Begin (* Receive *)
  3869.                    writeln('Got a Send    request ');
  3870.                    Filename :=  '' ;
  3871.                    RecvFile(filename);
  3872.                    End   (* Receive *)
  3873.                                           else
  3874.               If  InPacketType = Ord('R') then        (* Receive Packet *)
  3875.                    Begin (* Receive *)
  3876.                    writeln('Got a receive request ');
  3877.                    for i := 1 to InCount-3 do
  3878.                        filename[i] := chr(RecvData[i]);
  3879.                    Filename[0] :=  chr(InCount-3) ;
  3880.                    waitxon := XonXoff ;
  3881.                    SendFile(filename);
  3882.                    End   (* Receive *)
  3883.                                           else
  3884.               If  InPacketType = Ord('G') then        (* General Packet *)
  3885.                    Begin (* Receive *)
  3886.                    writeln('Got a General request ');
  3887.                    SendPacketType('Y');
  3888.                    End   (* Receive *)
  3889.                                           else
  3890.  
  3891.                    Begin (* Unknow packet Type *)
  3892.                    OutCount := 15 ;
  3893.                    Outseq := 0 ;
  3894.                    OutPacketType := Ord('E');
  3895.         (*           SendData := 'Unknow Command';  *)
  3896.                    End;   (* Unknown packet Type *)
  3897.               End   (* Got a Packet *)
  3898.          End ; (* RemoteCommand Procedure *)
  3899.     (* -------------------------------------------------------- *)
  3900.  
  3901.     Begin (* Connection *)
  3902.     DialModem ;
  3903.     Overchars := Over1+Over2+Over3+Over4+Over5 ;
  3904.     RemoteScreen ;      (* Save local screen, restore remote screen *)
  3905.     While KeyChar(achar,bchar) do ;    (* Empty keyboard buffer *)
  3906.     While connected do
  3907.          Begin (* connected *)
  3908.          If RecvChar(achar) then
  3909.               if achar < $20 then
  3910.                    Begin (* Control Character *)
  3911.                    if achar = StartChar then  RemoteCommand
  3912.                                         else
  3913.                    if achar = EOT then connected := false
  3914.                                   else
  3915.                    if achar = ESC then Escape
  3916.                                   else
  3917.                    if (achar=BS) and AplFlag then
  3918.                         Begin (* Overstrick character *)
  3919.                         overchar[0] := chr(2) ;
  3920.                         If Readchar(achar) then overchar[2]:=chr(achar);
  3921.                         i:=Pos(overchar,overchars);
  3922.                         If i > 0 then  achar := ord(overchars[i+2])
  3923.                                  else
  3924.                               begin (* reverse order *)
  3925.                               overchar[2] := overchar[1] ;
  3926.                               overchar[1] := chr(achar);
  3927.                               i:=Pos(overchar,overchars);
  3928.                               If i>0 then achar := ord(overchars[i+2])
  3929.                                      else achar := AplTable[ord(overchar[2])];
  3930.                               end ; (* reverse order *)
  3931.                         write(chr(BS),chr(achar));
  3932.                         End  (* Overstrick character *)
  3933.                                              else
  3934.                    if achar in [7,8,10,13] then write(chr(achar));
  3935.                    End   (* Control Character *)
  3936.                              else
  3937.                    If achar <> DEL then
  3938.                              if AplFlag then begin (* APL char *)
  3939.                                              write(chr(APLTABLE[achar]));
  3940.                                              overchar[1] := chr(achar) ;
  3941.                                              end
  3942.                                         else write(chr(achar));
  3943.          if KeyChar(achar,bchar) then
  3944.               Begin (* key input *)
  3945.               if bchar = $70 then connected := false else  (* Alt F9  *)
  3946.               if bchar = $71 then SendBreak          else  (* Alt F10 *)
  3947.  
  3948.               If ((achar=0) or (EscSeq[bchar,1]<>' ')
  3949.                             or (EscSeq[bchar,2]<>' ') ) and
  3950.                           (achar <> $09)  then
  3951.                    Begin (* Send escape sequence *)
  3952.  
  3953.                    If EscSeq[Bchar,1]<>' ' then SendChar(Esc);
  3954.                    If EscSeq[Bchar,1]<>' ' then
  3955.                              SendChar(Ord(EscSeq[bchar,1])) ;
  3956.                    If EscSeq[bchar,2]<>' ' then
  3957.                              SendChar(Ord(EscSeq[bchar,2])) ;
  3958.                    End  (* Send Escape Sequence *)
  3959.                                                     else
  3960.                    Begin (* Normal Key *)
  3961.                    If EscapeFlag then
  3962.                         if achar = $7B then AplFlag := true  else
  3963.                         if achar = $7D then AplFlag := false ;
  3964.                    Escapeflag := achar = ESC ;
  3965.                    if achar = LocalChar then connected := false else
  3966.                       if achar = BreakChar then SendBreak
  3967.                                            else Sendchar(achar);
  3968.                    if LocalEcho and connected then
  3969.                              if AplFlag then write(chr(APLTABLE[achar]))
  3970.                                         else write(chr(achar));
  3971.                    End ; (* Normal Key *)
  3972.  
  3973.              End; (* key input *)
  3974.          End; (* connected *)
  3975.     LocalScreen ;  (* save remote screen , restore local screen *)
  3976.     End ; (* Connection *)
  3977.  
  3978. (* +FILE+ CONNECT.PASTEK10 *)
  3979. (* ================================================================== *)
  3980. (*  Global Var and Procedures for special key specifications.         *)
  3981. (* ================================================================== *)
  3982. Const
  3983.      Gversion = 'G ' ;
  3984.      TermType = ' TEK4010' ;
  3985.      Graphics = ' by Victoria Henderson   ' ;
  3986.  
  3987. Var
  3988.      EscSeq : Array [1..$88,1..2] of char ;
  3989.      KeyTableName : String[14] ;
  3990.      KeyTable : Text ;
  3991. (*------------------------------------------------------------------- *)
  3992. Function hexinteger (chars : string2): byte ;
  3993.     begin (* HexInteger *)
  3994.     If chars[1] in ['A'..'F'] then chars[1]:=chr(ord(chars[1])+9);
  3995.     If chars[2] in ['A'..'F'] then chars[2]:=chr(ord(chars[2])+9);
  3996.     hexinteger := (ord(chars[1]) shl 4) + (ord(chars[2]) and $0F) ;
  3997.     end  ; (* HexInteger *)
  3998. (*------------------------------------------------------------------- *)
  3999.  
  4000. Procedure ReadKeytable ;
  4001. var I : integer ;
  4002.     Newname : string[15] ;
  4003.     comment : string[80] ;
  4004. label retry ;
  4005.     Begin (* ReadKeytable *)
  4006.     keytablename := 'KEYTABLE.DAT' ;
  4007.     Assign(keytable,keytablename) ;
  4008. retry :
  4009.     {$I-}  Reset(keytable);  {$I+}
  4010.     If IORESULT = 0 then
  4011.          Begin (* Initiate key table *)
  4012.          For i := 1 to $88 do
  4013.               Begin (* init EscSeq table *)
  4014.               Readln(KeyTable,EscSeq[i,1],EscSeq[i,2],comment) ;
  4015.               If copy(comment,2,2) <> '  ' then
  4016.                  EscSeq[i,1] := Chr(HexInteger(copy(comment,2,2))) ;
  4017.               If copy(comment,4,2) <> '  ' then
  4018.                  EscSeq[i,2] := Chr(HexInteger(copy(comment,4,2))) ;
  4019.               End ; (* init EscSeq table *)
  4020.          Close(keytable);
  4021.          End   (* Initiate key table *)
  4022.                   else
  4023.          Begin (* Warning *)
  4024.          Writeln('No ',Keytablename);
  4025.          Readln(Keytablename);
  4026.          Assign(keytable,keytablename);
  4027.          If length(keytablename)<1 then Running := false
  4028.                                    else Goto Retry ;
  4029.          End ; (* Warning *)
  4030.     End ; (* ReadKeytable *)
  4031.  
  4032.  
  4033. (* ================================================================== *)
  4034. (*  Connection - Connect to the other computer and simulates          *)
  4035. (*               a VT100 type terminal with Tek4010 graphics.         *)
  4036. (*                                                                    *)
  4037. (* ================================================================== *)
  4038.  
  4039. Procedure Connection ;
  4040.     CONST
  4041.  
  4042.          us = #31;
  4043.          rs = #30;
  4044.          gs = #29;
  4045.          fs = #28;
  4046.          ff = #12;
  4047.          syn = #22;
  4048.          exclam = #33;
  4049.     VAR
  4050.          achar,bchar : byte ;
  4051.          i : integer ;
  4052.          LastX, LastY: INTEGER;
  4053.          HiY, LoY, HiX, LoX, NewX, NewY: INTEGER;
  4054.          TextColour: Integer;
  4055.          DrawMode: Boolean;
  4056.          Heapmark : ^WrkString ;
  4057.  
  4058.     (* -------------------------------------------------------- *)
  4059.  
  4060. PROCEDURE InitGraph;
  4061.    BEGIN
  4062.      Mark(heapmark);
  4063.      InitGraphic;
  4064.      DefineWorld (1,0,779,1023,0);
  4065.      DefineWindow(1,0,0,xmaxglb,ymaxglb);
  4066.      SelectWorld(1);
  4067.      SelectWindow(1);
  4068.      SetWindowModeOn;
  4069.      DrawMode := True;
  4070.    END;
  4071.  
  4072. PROCEDURE EndGraph;
  4073.    BEGIN
  4074.      Repeat Until Keypressed;
  4075.      LeaveGraphic;   {clear graphics screen and return to text mode}
  4076.      DrawMode := False;
  4077.      Release(Heapmark);
  4078.  END;
  4079.  
  4080.     (* -------------------------------------------------------- *)
  4081.  
  4082. PROCEDURE EscapeSequence (VAR ach:byte);
  4083.  
  4084.    CONST
  4085.         Percent = #37;
  4086.         Exclam  = #33;
  4087.         ff      = #12;
  4088.         sub     = #26;
  4089.  
  4090.    VAR
  4091.         Xpos, Ypos : BYTE;
  4092.          Pn,Pc : byte ;
  4093.  
  4094.          Function PNumber (var achar : byte) : integer ;
  4095.           var Numstr : string[3];
  4096.               Num,result : integer ;
  4097.               Begin (* PNumber *)
  4098.               Numstr := '' ;
  4099.               While chr(achar) in ['0'..'9']  do
  4100.                    Begin (* get number *)
  4101.                    Numstr := Numstr + chr(achar) ;
  4102.                    If Readchar(achar) then ;
  4103.                    End ; (* get number *)
  4104.               Val(Numstr,Num,Result);
  4105.               PNumber := Num ;
  4106.               End ; (* PNumber *)
  4107.  
  4108.     Begin (* Escape Sequence *)
  4109.       IF ReadChar(ach) THEN
  4110.            IF DrawMode THEN
  4111.               CASE chr(ach) OF
  4112.                   sub: EndGraph;
  4113.                    ff: BEGIN
  4114.                          LeaveGraphic;
  4115.                          DrawMode := False;
  4116.                          END; {ff}
  4117.                END  {case}
  4118.             ELSE   {not drawmode, check system functions}
  4119.     CASE chr(achar) of  (* First Level *)
  4120.          '[':
  4121.                If Readchar(achar) then
  4122.                CASE chr(achar) of   (* Second level *)
  4123.                  'C': CursorRight ;
  4124.                  'D': CursorLeft  ;
  4125.                  'J': ClrScr ; (* Erase End of Display *)
  4126.                  'K': ClrEol ; (* Erase End of Line *)
  4127.                  '?': ;        (* Special functions - not yet implemented *)
  4128.                  'H': GoToXY(0,0);  (* Cursor Home *)
  4129.                  'm':(* NormVideo*) ;  (* Exit all attribute modes *)
  4130.                 else
  4131.                      Begin (* Esc [ Pn x   functions *)
  4132.                      Pn := PNumber(achar);
  4133.                      CASE chr(achar) of (* third level *)
  4134.                         'A': For i := 1 to Pn do Cursorup ;
  4135.                         'B': For i := 1 to Pn do Cursordown ;
  4136.                         'C': For i := 1 to Pn do CursorRight ;
  4137.                         'D': For i := 1 to Pn do CursorLeft ;
  4138.                         ';': Begin (* Direct cursor addressing *)
  4139.                              If readchar(achar) then ;
  4140.                              Pc := PNumber (achar);
  4141.                              GoToXY(Pc,Pn);
  4142.                              End ; (* Direct cursor addressing *)
  4143.                         'q': FatCursor(Pn=1) ;
  4144.                         'm',
  4145.                         '}':
  4146.                              Case Pn of      (* Field specs *)
  4147.                              0: begin (* Normal *)
  4148.                                 TextColor(LightGray);
  4149.                                 Textbackground(black);
  4150.                                 end ;
  4151.                              1: begin (* High Intensity *)
  4152.                                 TextColor(White);
  4153.                                 Textbackground(black);
  4154.                                 end ;
  4155.                              4: begin (* Underline *)
  4156.                                 TextColor(White);
  4157.                                 Textbackground(black);
  4158.                                 end ;
  4159.                              5: begin (* Blink *)
  4160.                                 TextColor(White+ blink);
  4161.                                 Textbackground(black);
  4162.                                 end ;
  4163.                              7: begin (* Reverse *)
  4164.                                 TextColor(Black);
  4165.                                 Textbackground(white);
  4166.                                 end ;
  4167.                              8: begin (* Invisible *)
  4168.                                 TextColor(Black);
  4169.                                 Textbackground(black);
  4170.                                 end ;
  4171.                             30: Textcolor(Black);
  4172.                             31: Textcolor(Red);
  4173.                             32: Textcolor(Green);
  4174.                             33: Textcolor(yellow);
  4175.                             34: Textcolor(Blue);
  4176.                             35: Textcolor(Magenta);
  4177.                             36: Textcolor(Cyan);
  4178.                             37: Textcolor(White);
  4179.  
  4180.                             40: Textbackground(Black);
  4181.                             41: Textbackground(Red);
  4182.                             42: Textbackground(Green);
  4183.                             43: Textbackground(Yellow);
  4184.                             44: Textbackground(Blue);
  4185.                             45: Textbackground(Magenta);
  4186.                             46: Textbackground(Cyan);
  4187.                             47: Textbackground(White);
  4188.  
  4189.                              End ; (* case of Field specs *)
  4190.                         'J': Case Pn of
  4191.                              0: ClrScr ;
  4192.                              1: ClrScr ; (* clear to beginning *)
  4193.                              2: ClrScr ;
  4194.                              End ; (*  J - Pn Case *)
  4195.                         'K': Case Pn of
  4196.                              1: ClrEol ; (* clear to beginning *)
  4197.                              2: ClrEol ; (* clear line *)
  4198.                              End ; (*  J - Pn Case *)
  4199.                         'L': For i := 1 to Pn do InsLine ; (* Insert Line *)
  4200.                         'M': For i := 1 to Pn do DelLine ; (* Delete Line *)
  4201.                         '@': For i := 1 to Pn do (* InsertChar *)  ;
  4202.                         'P': For i := 1 to Pn do (* DeleteChar *)  ;
  4203.                      End ; (* Case third level *)
  4204.                      End ; (* Esc [ Pn x   functions *)
  4205.  
  4206.                End ; (* second level Case *)
  4207.  
  4208.          'D': CursorDown ;    (* Index *)
  4209.          'M': CursorUp   ;    (* Reverse Index *)
  4210.          'H':            ;    (* Set Tab Stop *)
  4211.          '(':            ;    (* G0 *)
  4212.          ')':            ;    (* G1 *)
  4213.          End ; (* First Level Case  *)
  4214.  
  4215.     End ; (* Escape Sequence *)
  4216.  
  4217.     (* -------------------------------------------------------- *)
  4218. PROCEDURE DrawVector (VAR ach:byte);
  4219.  
  4220.   CONST
  4221.     ParityBit = 127;
  4222.     BitCheck  =  96;
  4223.     LoYBit    =  96;
  4224.     LoXBit    =  64;
  4225.     HiBit     =  32;
  4226.     FiveBits  =  31;
  4227.     ScaleX    =  1.6;  {tek4010 co-ordinates are 1024 x 780}
  4228.     ScaleY    =  3.47;  {scale into screen size 640 x 225 }
  4229.     us = #31;
  4230.     gs = #29;
  4231.     esc = #27;
  4232.     sub = #26;
  4233.  
  4234.    VAR
  4235.      XFlag, DrawFlag: BOOLEAN;
  4236.      CByte: Integer;
  4237.      ch: char;
  4238.  
  4239.   BEGIN
  4240.      XFlag := FALSE;
  4241.      DrawFlag := FALSE;
  4242.      ch := chr(ach);
  4243.      WHILE (ch <> us) and (ch <> esc) DO
  4244.         BEGIN
  4245.           IF ReadChar(ach) THEN
  4246.             BEGIN
  4247.              IF ch = gs THEN DrawFlag := False;
  4248.              ch := chr(ach);
  4249.              CByte := ord(ch) and ParityBit;  {remove parity bit}
  4250.              IF (CByte and BitCheck) = HiBit THEN
  4251.                 IF XFlag THEN
  4252.                    HiX := CByte and FiveBits
  4253.                 ELSE
  4254.                    HiY := CByte and FiveBits
  4255.              ELSE
  4256.                 IF (CByte and BitCheck) = LoYBit THEN
  4257.                    BEGIN
  4258.                      LoY := CByte and FiveBits;
  4259.                      XFlag := TRUE;
  4260.                    END
  4261.              ELSE
  4262.                 IF (CByte and BitCheck) = LoXBit THEN
  4263.                    BEGIN
  4264.                      LoX := CByte and FiveBits;
  4265.                      XFlag := FALSE;
  4266.                      NewX := (HiX*32 + LoX);
  4267.                      NewY := 779 - (HiY*32 + LoY);
  4268.                      IF DrawFlag THEN
  4269.                         DrawLine ( LastX, LastY, NewX, NewY)
  4270.                      ELSE
  4271.                         BEGIN
  4272.                           SetColorBlack;
  4273.                           DrawPoint( NewX, NewY);
  4274.                           SetColorWhite;
  4275.                           DrawFlag := TRUE;
  4276.                         END;
  4277.                      LastX := NewX;
  4278.                      LastY := NewY;
  4279.                    END; {IF}
  4280.                 END; {IF}
  4281.        END;  {while}
  4282.    END; {drawvector}
  4283.  
  4284. PROCEDURE  AlphaMode (VAR ach:byte);
  4285.  
  4286.     VAR
  4287.        I: INTEGER;
  4288.        Str: String[255];
  4289.  
  4290.     BEGIN
  4291.        Str := '';
  4292.        I := 1;
  4293.        IF ReadChar(ach) THEN
  4294.           WHILE (chr(ach) <> gs) and (I <= 255) and (ach <> esc) DO
  4295.                 BEGIN
  4296.                   Str := Str + chr(ach); I := I+1;
  4297.                   IF ReadChar(ach) THEN
  4298.                 END; {while}
  4299.            DrawTextW(LastX*1.0,LastY*1.0,1,Str);
  4300.            IF (chr(ach) = gs) and (not DrawMode) THEN  InitGraph;
  4301.            IF (ach = esc) THEN EndGraph;
  4302.     END; {alphamode}
  4303.  
  4304.     (* -------------------------------------------------------- *)
  4305.  
  4306.          Procedure RemoteCommand  ;
  4307.          Var
  4308.               i : integer ;
  4309.               Filename : Comstring ;
  4310.          Begin (* RemoteCommand procedure *)
  4311.          GotSOH := true ;
  4312.          If RecvPacket then
  4313.               Begin (* Got a Packet *)
  4314.               If  InPacketType = Ord('S') then        (* Send Packet *)
  4315.                    Begin (* Receive *)
  4316.             (*     writeln('Got a Send request');    *)
  4317.                    Filename :=  '' ;
  4318.                    RecvFile(filename);
  4319.                    End   (* Receive *)
  4320.                                           else
  4321.               If  InPacketType = Ord('R') then        (* Receive Packet *)
  4322.                    Begin (* Receive *)
  4323.               (*   writeln('Got a receive request ');  *)
  4324.                    for i := 1 to InCount-3 do
  4325.                        filename[i] := chr(RecvData[i]);
  4326.                    Filename[0] :=  chr(InCount-3) ;
  4327.                    waitxon := XonXoff ;
  4328.                    SendFile(filename);
  4329.                    End   (* Receive *)
  4330.                                           else
  4331.               If  InPacketType = Ord('G') then        (* General Packet *)
  4332.                    Begin (* Receive *)
  4333.               (*   writeln('Got a General request ');    *)
  4334.                    SendPacketType('Y');
  4335.                    End   (* Receive *)
  4336.                                           else
  4337.  
  4338.                    Begin (* Unknow packet Type *)
  4339.                    OutCount := 15 ;
  4340.                    Outseq := 0 ;
  4341.                    OutPacketType := Ord('E');
  4342.         (*           SendData := 'Unknow Command';  *)
  4343.                    End;   (* Unknown packet Type *)
  4344.               End   (* Got a Packet *)
  4345.          End ; (* RemoteCommand Procedure *)
  4346.     (* -------------------------------------------------------- *)
  4347.  
  4348.     Begin (* Connection *)
  4349.     DialModem ;
  4350.     RemoteScreen ;      (* Save local screen, restore remote screen *)
  4351.     While KeyChar(achar,bchar) do ;    (* Empty keyboard buffer *)
  4352.     HiY := 0; LoY := 0; HiX := 0; LoX := 0;
  4353.     LastX := 0; LastY := 0; DrawMode := False;
  4354.     While connected do
  4355.          Begin (* connected *)
  4356.          If RecvChar(achar) then
  4357.               if achar < $20 then
  4358.                    Begin (* Control Character *)
  4359.                    if achar = SOH then (* RemoteCommand *)
  4360.                                   else
  4361.                    if achar = EOT then connected := false
  4362.                                   else
  4363.                    if achar in [7,8,10,13] then write(chr(achar))
  4364.                     ELSE
  4365.                  IF chr(achar) = gs THEN
  4366.                       BEGIN
  4367.                          IF not DrawMode THEN  InitGraph;
  4368.                          WHILE chr(achar) = gs DO
  4369.                            BEGIN
  4370.                              DrawVector(achar);
  4371.                              IF achar = esc THEN EscapeSequence(achar)
  4372.                                 ELSE
  4373.                              AlphaMode(achar);
  4374.                            END; {while}
  4375.                       END  {if}
  4376.                     ELSE
  4377.                  IF chr(achar) = fs THEN DrawVector(achar)
  4378.                     ELSE
  4379.                  IF chr(achar) = syn THEN  {ignore}
  4380.                     ELSE
  4381.                  IF achar = esc THEN  EscapeSequence(achar)
  4382.                     ELSE
  4383.                  IF char(achar) = rs THEN EndGraph; {sas terminator}
  4384.                    End   (* Control Character *)
  4385.                              else
  4386.                    If achar <> DEL then   write(chr(achar));
  4387.  
  4388.          if KeyChar(achar,bchar) then
  4389.               Begin (* key input *)
  4390.               If ((achar=0) or (EscSeq[bchar,1]<>' ')
  4391.                             or (EscSeq[bchar,2]<>' ') ) and
  4392.                           (achar <> $09)  then
  4393.                    Begin (* Send escape sequence *)
  4394.                    If EscSeq[Bchar,1]<>' ' then SendChar(Esc);
  4395.                    If EscSeq[Bchar,1]<>' ' then
  4396.                              SendChar(Ord(EscSeq[bchar,1])) ;
  4397.                    If EscSeq[bchar,2]<>' ' then
  4398.                              SendChar(Ord(EscSeq[bchar,2])) ;
  4399.                    End  (* Send Escape Sequence *)
  4400.                                                     else
  4401.                    Begin (* Normal Key *)
  4402.                    if achar = LocalChar then connected := false else
  4403.                       if achar = BreakChar then SendBreak
  4404.                                            else Sendchar(achar);
  4405.                    if LocalEcho and connected then write(chr(achar));
  4406.                    End ; (* Normal Key *)
  4407.  
  4408.              End; (* key input *)
  4409.          End; (* connected *)
  4410.     LocalScreen ;  (* save remote screen , restore local screen *)
  4411.     End ; (* Connection *)
  4412.  
  4413. (* +FILE+ SETSHOW.PASMSCPM *)
  4414. (* ================================================================== *)
  4415. (* ShowOptions - Show Parameter Options setting for Kermit.           *)
  4416. (*                                                                    *)
  4417. (* ================================================================== *)
  4418. Procedure ShowOptions ;
  4419.  
  4420. Begin (* ShowOptions Procedure *)
  4421. ClrScr ; (* Clear the Screen *)
  4422. GotoXY(1,2);   (* Start at line 2 *)
  4423. Writeln('         QK-KERMIT  version ',version,Gversion,' -  ',Date);
  4424. Writeln(' ');
  4425. Writeln('  Current Setting           Options ');
  4426. Writeln('-------------------    --------------------------------------');
  4427. Writeln('Baud Rate  = ',Baudrate,'      ( 300 600 1200 2400 4800 9600 19.2 )');
  4428. Write  ('Parity     = ') ;
  4429.   Case paritytype(parity) of
  4430.      OddP : write('Odd  ');
  4431.      EvenP: write('Even ');
  4432.      MarkP: write('Mark ');
  4433.      NoneP: write('None ');
  4434.   end ; (* parity case *)
  4435. Writeln('     ( Odd   Even  Mark  None ) ');
  4436. Write  ('Duplex     = ');
  4437.   If LocalEcho then Write('Half ')
  4438.                else Write('Full ');
  4439.   writeln('     ( Half  Full ) ');
  4440.  
  4441. Write  ('Protocol   = ');
  4442.     If Series1 then write('Series/1 ')
  4443.                else If XonXoff then write('Xon-Xoff ')
  4444.                                else write('Standard ');
  4445.     writeln(' ( Xon-Xoff   Series/1   Standard )');
  4446. Writeln(' ');
  4447. Write  ('Disk Drive = ',chr(DefaultDrive+$41),':   ') ;
  4448.   writeln('     ( A:    B:    C:    D:   )');
  4449. Write  ('Com Port   = ');
  4450.   If PrimaryPort then Write('One  ')
  4451.                  else Write('Two  ');
  4452.   writeln('     ( One   Two  ) ' );
  4453. Write  ('Destination=');
  4454.   If ForPrinter  then Write(' Printer ')
  4455.                  else Write(' Disk    ');
  4456.   writeln('  ( Disk  Printer )');
  4457. Writeln(' ');
  4458. If ParmFlag then Begin (* Display Packet Parameters *)
  4459. Writeln('-------------------------------------------------------------');
  4460. Writeln('Packet Parameters');
  4461. Writeln('    Packetsize = ',Packetsize,'  Timeout   = ',Timeout:2,'   *');
  4462. Writeln('    NumPad     = ',NumPad:2,'  PadChar   = ',PadChar:2,'   *');
  4463. Write  ('    Startchar  = ',StartChar:2,'  EndChar   = ',EndChar:2);
  4464. Writeln('   * use decimal values ');
  4465. Write  ('    CntrlQuote =  ',chr(CntrlQuote),'  Bit8Quote =  ',chr(Bit8quote));
  4466. Writeln('   | use character values ');
  4467. Write  ('    CheckType  =  ',chr(CheckType),'  RepChar   =  ',chr(RepChar));
  4468. Writeln('   |   use NULL for null character )');
  4469.                 End ; (* Display Packet Parameters *)
  4470. If logging then
  4471.     Begin writeln(' '); writeln(' Logging data to file ',LogName); end;
  4472.  
  4473. End;  (* ShowOptions Procedure *)
  4474. (* ================================================================== *)
  4475. (* SetOptions - Set Parameter Options setting for Kermit.             *)
  4476. (*                                                                    *)
  4477. (* ================================================================== *)
  4478. Procedure SetOptions (var instring:comstring);
  4479. Const
  4480.     OP1Table : String[40] = '     300  600  1200 2400 4800 9600 19.2 ';
  4481.     OP2Table : String[30] = 'ODD  EVEN MARK NONE HALF FULL ';
  4482.     OP3Table : String[40] = 'XON-XOFF  SERIES/1  STANDARD  ONE  TWO  ';
  4483.     OP4Table : String[40] = 'A:   B:   C:   D:   DISK PRINTER  ';
  4484.     PP1Table : String[44] = '           PACKETSIZE TIMEOUT    NUMPAD     ';
  4485.     PP2Table : String[44] = 'PADCHAR    STARTCHAR  ENDCHAR    CNTRLQUOTE ';
  4486.     PP3Table : String[33] = 'BIT8QUOTE  CHECKTYPE  REPCHAR    ' ;
  4487. Type
  4488.     Options = (zero,b300,b600,b1200,b2400,b4800,b9600,b19200,
  4489.                PO,PE,PM,PN,HALF,FULL,
  4490.                Xon,xon1,Series,ser1,Stand,stand1,one,two,
  4491.                A,B,C,D,Disk,Print,print1) ;
  4492.    PParms = (Pzero,Psize,PTime,PNumPad,PPadChar,
  4493.              PStartChar,PEndChar,PcntrlQuote,Pbit8Quote,
  4494.              PChecktype,PRepChar);
  4495. Var
  4496.     Option : comstring ;
  4497.     OptionTable : String[255];
  4498.     PParmTable : String[122];
  4499.     Ix : integer ;
  4500.     ScanOptions : boolean ;
  4501.  
  4502.          Procedure SetValue ( var Pvalue : byte );
  4503.          var I,Retcode : integer ;
  4504.          Begin (* Set Value *)
  4505.          Val(Gettoken(Instring),I,Retcode);
  4506.          If Retcode = 0 then Pvalue := I
  4507.                         else
  4508.               Begin Writeln('>>> Invalid value specified <<<');Delay(2000);End;
  4509.          End ; (* Set Value *)
  4510.  
  4511.          Procedure SetChar ( var Pchar : byte );
  4512.          Var atoken : string[10];
  4513.          Begin (* set char *)
  4514.          Atoken := UpperCase(Gettoken(Instring)) ;
  4515.          If Atoken = 'NULL' then Pchar := 0 else
  4516.          If Length(Atoken) = 1 then Pchar := Ord(Atoken[1])
  4517.                                else
  4518.               Begin Writeln('>>> Invalid Specification <<<');delay(2000);End;
  4519.          End ; (* set char *)
  4520.  
  4521. Begin (* SetOptions Procedure *)
  4522. OptionTable := OP1Table + OP2Table + OP3Table + OP4Table ;
  4523. PParmTable := PP1Table + PP2Table + PP3Table ;
  4524. If length(instring)<1 then
  4525.     Begin (* Get Settings *)
  4526.     ShowOptions;
  4527.     Write  ('Enter Option Setting >');
  4528.     If audioflag then
  4529.        Begin Sound(1000); Delay(250); Sound(2000); Delay(50); Nosound;end;
  4530.     Readln(instring);
  4531.     End ; (* Get Settings *)
  4532. ScanOptions := true ;
  4533. While (length(instring)>0) and ScanOptions do
  4534.     Begin (* Parse instring *)
  4535.     Option := GetToken(instring);
  4536.     ScanOptions := Option<>';';
  4537.     Option := Concat(' ',Uppercase(Option));
  4538.     ix := Pos(Option,OptionTable) div 5 ;
  4539.     If ix <> 0 then
  4540.          Case Options(ix) of
  4541.          b300   : Baudrate := 300 ;
  4542.          b600   : Baudrate := 600 ;
  4543.          b1200  : Baudrate := 1200 ;
  4544.          b2400  : Baudrate := 2400 ;
  4545.          b4800  : Baudrate := 4800 ;
  4546.          b9600  : Baudrate := 9600 ;
  4547.          b19200 : Baudrate := 19200 ;
  4548.          PO     : Parity   := OddP ;
  4549.          PE     : parity   := EvenP ;
  4550.          PM     : Parity   := MarkP ;
  4551.          PN     : parity   := NoneP ;
  4552.          HALF   : LocalEcho:= True ;
  4553.          FULL   : LocalEcho:= False ;
  4554.          Xon    : Begin XonXoff := True;  Series1 := False; End;
  4555. (*       Series : Begin XonXoff := True;  Series1 := True;  End;  *)
  4556.          Series : Begin XonXoff := False; Series1 := True;  End;
  4557.          Stand  : Begin XonXoff := False; Series1 := False; End;
  4558.          One    : PrimaryPort := True ;
  4559.          Two    : PrimaryPort := False ;
  4560.          A      : SetDefaultDrive(0) ;
  4561.          B      : SetDefaultDrive(1) ;
  4562.          C      : SetDefaultDrive(2) ;
  4563.          D      : SetDefaultDrive(3) ;
  4564.          Disk   : ForPrinter := false ;
  4565.          Print  : ForPrinter := true ;
  4566.          End   (* case of options *)
  4567.                else
  4568.          Begin (* check packet parms *)
  4569.          ix := Pos(Option,PParmTable) div 11 ;
  4570.          If (ix <> 0) and ParmFlag then
  4571.               Case PParms(ix) of
  4572.          Psize:          SetValue(Packetsize) ;
  4573.          PTime:          SetValue(Timeout) ;
  4574.          PNumPad:        SetValue(NumPad) ;
  4575.          PPadChar:       SetValue(PadChar) ;
  4576.          PStartChar:     SetValue(StartChar) ;
  4577.          PEndChar:       SetValue(EndChar) ;
  4578.          PcntrlQuote:    SetChar(CntrlQuote) ;
  4579.          Pbit8Quote:     SetChar(Bit8Quote) ;
  4580.          PChecktype:     SetChar(CheckType) ;
  4581.          PRepChar :      SetChar(RepChar) ;
  4582.               End ; (* Case of  PParms *)
  4583.          If chr(CheckType) in ['1','2','3'] then else CheckType := 49 ;
  4584.          End ; (* check packet parms *)
  4585.     ResetModem; Initmodem ;
  4586.     SetModem ;
  4587.     End ; (* Parse instring *)
  4588. ShowOptions ;
  4589. End ; (* SetOptions Procedure *)
  4590.  
  4591. (* ================================================================== *)
  4592. (* DisplayCommands - Display all the valid Kermit Commands.           *)
  4593. (*                                                                    *)
  4594. (* ================================================================== *)
  4595. Procedure DisplayCommands;
  4596.  
  4597. Begin (* DisplayCommands Procedure *)
  4598. ClrScr ;
  4599. Writeln('     The Following are the valid Kermit Commands :');
  4600. Writeln('---------------------------------------------------------------');
  4601. Writeln('CONNECT <options>  - connect to a remote host as a dumb terminal.');
  4602. Writeln(' ');
  4603. Writeln('SEND    <local-filename > AS <remote-filename> RAW');
  4604. Writeln('RECEIVE <remote-filename> AS <local-filename > REPLACE');
  4605. Writeln('                        ');
  4606. Writeln('SET    <options>   - set option settings.');
  4607. Writeln('STATUS             - display optional settings and status');
  4608. Writeln('            ');
  4609. Writeln('DIRECTORY,ERASE,RENAME,TYPE,RUN <filename> - local commands');
  4610. Writeln('MKDIR,CHDIR,RMDIR  <directoryname>         - local commands');
  4611. Writeln('REMOTE <commands>                          - remote commands');
  4612. Writeln('            ');
  4613. Writeln('LOG  <filename>    - Record data received in a log file.');
  4614. Writeln('TAKE <filename>    - Take and execute commands from a  file.');
  4615. Writeln('DEFINE <dword> <dstring> - define a word to equal a string.');
  4616. Writeln('AUDIO,PARMS        - toggle options .');
  4617. Writeln('QUIT  <QuitOption> - terminate local or remote kermit program.');
  4618. Writeln('                     QuitOptions : LOCAL,REMOTE,DISCONnect,ALL');
  4619. Writeln(' ');
  4620. Writeln('   Note: All parameters are optional and all commands maybe');
  4621. Writeln('         abbreviated to a minimum of unique characters.');
  4622. Writeln('---------------------------------------------------------------');
  4623. End; (* DisplayCommand Procedure *)
  4624.  
  4625. (* +FILE+ LOCAL.PASMSCPM *)
  4626. (* ----------------------------------------------------------------- *)
  4627. (*  DisplayDir - Displays the directory for the mask given in the    *)
  4628. (*              input parameter string.                              *)
  4629. (* ----------------------------------------------------------------- *)
  4630. Procedure DisplayDir (Myfiles : Comstring) ;
  4631. var
  4632.   filename : comstring ;
  4633.   column,row : integer ;
  4634. Begin (* DisplayDir Procedure *)
  4635. if (length(myfiles)<1) or (Myfiles[length(myfiles)] in ['\','/',':'])
  4636.      then myfiles := myfiles + '*.*';
  4637. Clrscr;
  4638. If firstfile(myfiles,filename) then
  4639.     Begin (* found files *)
  4640.     writeln(' directory ',myfiles);
  4641.     write(filename);
  4642.     column := 21 ; row := 2;
  4643.     while nextfile(myfiles,filename) do
  4644.          begin (* list rest of files *)
  4645.          gotoxy(column,row);
  4646.          write (filename);
  4647.          column := column + 20 ;
  4648.          if column > 61 then
  4649.               begin row := row + 1 ; column := 1 ;  end ;
  4650.          end ; (* list rest of files *)
  4651.     End   (* found files *)
  4652.                                 else
  4653.     writeln(' no file found ');
  4654.  writeln(' ');
  4655.  DisplayDiskStatus ;
  4656.  End ; (* DisplayDir Procedure *)
  4657.  
  4658. (* ----------------------------------------------------------------- *)
  4659. (*  EraseFiles - Erases a file or files from the disk.               *)
  4660. (*                                                                   *)
  4661. (* ----------------------------------------------------------------- *)
  4662. Procedure EraseFiles (Myfiles : Comstring) ;
  4663. var
  4664.     tempname : comstring ;
  4665.     tempfile : text ;
  4666.     column,row : integer ;
  4667. Begin (* EraseFile Procedure *)
  4668. While length(myfiles)<1 do
  4669.     Begin (* get file name *)
  4670.     write(' enter name of file to be erased > ');
  4671.     readln(myfiles);
  4672.     End ;
  4673. If firstfile(myfiles,tempname) then
  4674.     Begin (* found files *)
  4675.     Clrscr;
  4676.     writeln(' Erasing file(s) ',myfiles);
  4677.     assign(tempfile,prefixof(myfiles)+tempname);
  4678.     erase(tempfile);
  4679.     write(tempname);
  4680.     column := 21 ; row := 2;
  4681.     while nextfile(myfiles,tempname) do
  4682.          begin (* list rest of files *)
  4683.          gotoxy(column,row);
  4684.          assign(tempfile,prefixof(myfiles)+tempname);
  4685.          erase(tempfile);
  4686.          write (tempname);
  4687.          column := column + 20 ;
  4688.          if column > 61 then
  4689.               begin row := row + 1 ; column := 1 ;  end ;
  4690.          end ; (* list rest of files *)
  4691.     writeln(' ');
  4692.     writeln('The above file(s) have been erased. ');
  4693.     End   (* found files *)
  4694.                                 else
  4695.     writeln(' no file found ');
  4696. End;  (* EraseFile *)
  4697.  
  4698. (* ----------------------------------------------------------------- *)
  4699. (*  RenameFile - Remame a file.                                      *)
  4700. (*                                                                   *)
  4701. (* ----------------------------------------------------------------- *)
  4702. Procedure RenameFile (Var Instring : Comstring) ;
  4703. var
  4704.     oldnames,oldname,newname : comstring ;
  4705.     tempfile : text ;
  4706. label exit ;
  4707. Begin (* RenameFile Procedure *)
  4708. If length(Instring)<1 then
  4709.     Begin (* get file name *)
  4710.     write(' Enter old file name  > ');
  4711.     readln(Instring);
  4712.     End ; (* get file name *)
  4713. If length(Instring)<1 then goto exit ;
  4714. oldnames := uppercase(GetToken(instring));
  4715. newname := uppercase(GetToken(instring));
  4716. If length(newname)<1 then
  4717.     Begin (* get new file name *)
  4718.     write(' Enter new file name  > ');
  4719.     readln(Instring);
  4720.     newname := uppercase(GetToken(instring));
  4721.     End ; (* get new file name *)
  4722. If firstfile(oldnames,oldname) then
  4723.     Begin (* found File *)
  4724.     assign(tempfile,prefixof(oldnames)+oldname);
  4725.     Rename(tempfile,newname);
  4726.     writeln(' ');
  4727.     writeln('File ',oldname, ' renamed to ',newname);
  4728.     End   (* found File *)
  4729.                                 else
  4730.     writeln(' No file  - ',oldname);
  4731. exit:
  4732. End;  (* RenameFile *)
  4733.  
  4734. (* ----------------------------------------------------------------- *)
  4735. (*  DisplayFile - display a file.                                    *)
  4736. (*                                                                   *)
  4737. (* ----------------------------------------------------------------- *)
  4738. Procedure DisplayFile (Myfile : Comstring) ;
  4739. var
  4740.     oldname,newname : comstring ;
  4741.     tempfile : text ;
  4742.     achar : char ;
  4743. label exit ;
  4744. Begin (* DisplayFile Procedure *)
  4745. If length(Myfile)<1 then
  4746.     Begin (* get file name *)
  4747.     write(' Enter  file name  > ');
  4748.     readln(Myfile);
  4749.     End ; (* get file name *)
  4750. If length(Myfile)<1 then goto exit ;
  4751. Assign(tempfile,myfile);
  4752. { $I- } Reset(tempfile); { $I+ }
  4753. If IOResult = 0  then
  4754.     Begin (* found File *)
  4755.     Clrscr ;
  4756.     While not eof(tempfile) do
  4757.        begin (* Display file *)
  4758.        Read(tempfile,achar);
  4759.        Write(achar);
  4760.        end;  (* Display file *)
  4761.     writeln(' ');
  4762.     End   (* found File *)
  4763.                              else
  4764.     writeln(' No file  - ',Myfile);
  4765. exit:
  4766. End;  (* DisplayFile *)
  4767.  
  4768. (* +FILE+ REMOTE.PASMSCPM *)
  4769. (* ----------------------------------------------------------------- *)
  4770. (*  RemoteProc - Remote procedure.                                   *)
  4771. (* ----------------------------------------------------------------- *)
  4772. Procedure RemoteProc (var Instring : Comstring) ;
  4773. Const
  4774.     Gsubtype : String[18] =  'CDEFHIJKLMPQRTUVW' ;
  4775. TYPE
  4776.     RemoteCommandindex = (
  4777.                   rem_zero,
  4778.                   rem_cwd,
  4779.                   rem_directory,
  4780.                   rem_erase,
  4781.                   rem_finish,
  4782.                   rem_help,
  4783.                   rem_login,
  4784.                   rem_journal,
  4785.                   rem_copy,
  4786.                   rem_logout,
  4787.                   rem_message,
  4788.                   rem_program,
  4789.                   rem_query,
  4790.                   rem_rename,
  4791.                   rem_type,
  4792.                   rem_usage,
  4793.                   rem_variable,
  4794.                   rem_who);
  4795. Var
  4796.     ErrorMsg : comstring ;
  4797.     Rem_CommandTable : String[255] ;
  4798.     Rem_Command : comstring ;
  4799.     Index : integer ;
  4800.     Receiving : boolean ;
  4801.     Retries : integer ;
  4802.     j,CharCount,Bit8 : integer ;
  4803. (* ----------------------------------------------------------------------- *)
  4804. Procedure AddParmString ;
  4805.     Begin (* Add parms *)
  4806.     If length(instring) > 0 then
  4807.          Begin (* add parameter *)
  4808.          SendData[OutdataCount+1] := length(instring) + $20 ;
  4809.          For i := 1 to length(instring) do
  4810.               SendData[OutdataCount+1+i] := ord(instring[i]) ;
  4811.          OutdataCount := OutdataCount + length(instring) + 1 ;
  4812.          Instring := '';
  4813.          End ;
  4814.     End ; (* Add parms *)
  4815.  
  4816. (* *********************************************************************** *)
  4817. Begin (* RemoteProc *)
  4818. rem_commandtable  := concat('bad       ',
  4819.                        'CWD       ',
  4820.                        'DIRECTORY ',
  4821.                        'ERASE     ',
  4822.                        'FINISH    ',
  4823.                        'HELP      ',
  4824.                        'LOGIN     ',
  4825.                        'JOURNAL   ',
  4826.                        'COPY      ',
  4827.                        'LOGOUT    ',
  4828.                        'MESSAGE   ',
  4829.                        'PROGRAM   ',
  4830.                        'QUERY     ',
  4831.                        'RENAME    ',
  4832.                        'TYPE      ',
  4833.                        'USAGE     ',
  4834.                        'VARIABLE  ',
  4835.                        'WHO       ') ;
  4836.     rem_command := ' ' + Uppercase(GETTOKEN(instring));
  4837.     if rem_command = ' HOST' then
  4838.          Begin (* Host Command *)
  4839.          End   (* Host Command *)
  4840.                              else
  4841.          Begin (* Generic Kermit Commands *)
  4842.          index := POS(rem_command,rem_commandtable) div 10 ;
  4843.          if index = 0 then
  4844.               Begin (* list commands *)
  4845.               Writeln (rem_command,' - Invalid REMOTE command. ');
  4846.               Writeln('    Valid REMOTE Commands are as follows: ');
  4847.               Writeln('CWD       directory     - Change Working Directory');
  4848.               Writeln('DIRECTORY filespec      - Directory               ');
  4849.               Writeln('ERASE     filespec      - Erase (delete) a file   ');
  4850.               Writeln('FINISH                  - Terminate Kermit server ');
  4851.               Writeln('HELP      keywords      - Help from server        ');
  4852.               Writeln('LOGIN     userid        - Login                   ');
  4853.               Writeln('JOURNAL   command       - Transaction Logging     ');
  4854.               Writeln('COPY      filespec      - Copy file               ');
  4855.               Writeln('LOGOUT                  - Logout the remote host  ');
  4856.               Writeln('MESSAGE   destination   - Message                 ');
  4857.               Writeln('PROGRAM   program-name  - Program execution       ');
  4858.               Writeln('QUERY                   - Query server status     ');
  4859.               Writeln('RENAME    old-filespec  - Rename file             ');
  4860.               Writeln('TYPE      filespec      - Type (list) file        ');
  4861.               Writeln('USAGE     area          - Disk Usage Query        ');
  4862.               Writeln('VARIABLE  command       - Set or Query a Variable ');
  4863.               Writeln('WHO       userid        - Who is logged in        ');
  4864.               End   (* list commands *)
  4865.                       else
  4866.               Begin (* Issue Remote command Request *)
  4867.     (* Send Init Packet *)
  4868.     OutPacketType := Ord('I');
  4869.     PutInitPacket ;
  4870.     SendPacket ;
  4871.     STATE := R ;
  4872.     RECEIVING := TRUE ;
  4873.     BreakState := NoBreak ;
  4874.     RETRIES := 10 ;       (* Up to 10 retries allowed. *)
  4875.  
  4876.     WHILE RECEIVING DO  CASE STATE OF
  4877.  
  4878. (* R ------ Initial receive State ------- *)
  4879. (* Valid types  - Y *)
  4880. R : BEGIN (* Initial Receive State  *)
  4881.     If ( Not RecvPacket) or (InPacketType=Ord('N')) then Resendit(10)
  4882.                                                     else
  4883.          Begin (* Send Request *)
  4884.          If InPacketType=Ord('Y') then GetInitPacket ;
  4885.          If series1 then waitxon := false ;
  4886.          OutPacketType := Ord('G') ;
  4887.          SendData[1] := Ord(GSubtype[index]) ;
  4888.          OutDataCount :=  1 ;
  4889.          OUTSEQ   := OUTSEQ + 1 ;
  4890.          IF OUTSEQ >= 64 THEN OUTSEQ := 0;
  4891.          Case RemoteCommandIndex(index) of
  4892.      rem_zero:   ;
  4893.       rem_cwd:     Begin (* Change Working Directory *)
  4894.                    AddParmString;
  4895.                    Writeln (' Enter Password ') ;
  4896.                    Readln(instring);
  4897.                    AddParmString ;
  4898.                    End ; (* Change Working Directory *)
  4899. rem_directory:     AddParmString;
  4900.     rem_erase:     AddParmString;
  4901.    rem_finish:     AddParmString;
  4902.      rem_help:     AddParmString;
  4903.     rem_login:     Begin (* Login *)
  4904.                    AddParmString;
  4905.                    Writeln (' Enter Password ') ;
  4906.                    Readln(instring);
  4907.                    AddParmString ;
  4908.                    Writeln (' Enter Account Number ') ;
  4909.                    Readln(instring);
  4910.                    AddParmString ;
  4911.                    End ; (* Login *)
  4912.   rem_journal:     Begin (* Journal *)
  4913.                    AddParmString;
  4914.                    Writeln (' Enter Journal Argument ') ;
  4915.                    Readln(instring);
  4916.                    AddParmString ;
  4917.                    End ; (* Jounral *)
  4918.      rem_copy:     Begin (* Copy file *)
  4919.                    AddParmString;
  4920.                    Writeln (' Enter destination ') ;
  4921.                    Readln(instring);
  4922.                    AddParmString ;
  4923.                    End ; (* Copy file *)
  4924.    rem_logout:     AddparmString;
  4925.   rem_message:     Begin (* Message *)
  4926.                    AddParmString;
  4927.                    Writeln (' Enter Message text ') ;
  4928.                    Readln(instring);
  4929.                    AddParmString ;
  4930.                    End ; (* Message *)
  4931.   rem_program:     Begin (* Program *)
  4932.                    AddParmString;
  4933.                    Writeln (' Enter Program commands ') ;
  4934.                    Readln(instring);
  4935.                    AddParmString ;
  4936.                    End ; (* Program *)
  4937.     rem_query:     ;
  4938.    rem_rename:     Begin (* Rename file *)
  4939.                    AddParmString;
  4940.                    Writeln (' Enter New Name ') ;
  4941.                    Readln(instring);
  4942.                    AddParmString ;
  4943.                    End ; (* Rename file *)
  4944.      rem_type:     AddParmString;
  4945.     rem_usage:     AddParmString;
  4946.  rem_variable:     Begin (* Variable *)
  4947.                    AddParmString;
  4948.                    Writeln (' Enter First Argument ') ;
  4949.                    Readln(instring);
  4950.                    AddParmString ;
  4951.                    Writeln (' Enter Second Argument ') ;
  4952.                    Readln(instring);
  4953.                    AddParmString ;
  4954.                    End ; (* Variable *)
  4955.       rem_who:     Begin (* Who  *)
  4956.                    AddParmString;
  4957.                    Writeln (' Enter Options ') ;
  4958.                    Readln(instring);
  4959.                    AddParmString ;
  4960.                    End ; (* Who *)
  4961.          End ; (* Case *)
  4962.  
  4963.          SendPacket ;
  4964.          STATE := RF ;
  4965.          End ; (* Send Request *)
  4966.  
  4967.     END ; (* Initial Receive State  *)
  4968.  
  4969.  
  4970.     (* RF ----- Receive Filename State ------- *)
  4971.     (* Valid received msg type  : S,Z,F,B     *)
  4972.     RF: IF (NOT RECVPACKET) OR (InPacketType=Ord('N')) then  ReSendit(10)
  4973.                                                        else
  4974.         (* Get a packet *)
  4975.         IF (InPacketType = Ord('Y')) or (InPacketType=Ord('E')) then
  4976.               BEGIN (* Got simple reply  *)
  4977.               For i := 1 to InDataCount do
  4978.                    Write(Chr(RecvData[i])) ;
  4979.               Writeln(' ');
  4980.               RECEIVING := false
  4981.               END   (* Got simple reply *)
  4982.                                    else
  4983.         IF InPacketType = Ord('S') then
  4984.               Begin GetInitPacket; PutInitPacket; SendPacket; End else
  4985.         IF (InPacketType = Ord('X')) or (InPacketType = Ord('F')) then
  4986.               BEGIN (* Got file header *)
  4987.               For i := 1 to InDataCount do
  4988.                    Write(Chr(RecvData[i])) ;
  4989.               Writeln(' ');
  4990.               STATE := RD ;
  4991.               SendPacketType('Y');
  4992.               END   (* Got file header *)
  4993.                                    else
  4994.          BEGIN (* Not S,F,B,Z packet *)
  4995.          STATE := A ;   (* ABORT if not a S,F,B,Z type packet *)
  4996.          ABORT := NOT_SFBZ ;
  4997.          END ; (* Not S,F,B,Z packet *)
  4998.  
  4999.  
  5000.     (* RD ----- Receive Data State ------- *)
  5001.     (* Valid received msg type  : D,Z      *)
  5002.     RD: IF (NOT RECVPACKET) OR (InPacketType=Ord('N')) then ReSendit(10)
  5003.                                                        else
  5004.         (* Got a good packet *)
  5005.         IF InPacketType = Ord('D') then
  5006.               BEGIN (* Receive data *)
  5007.         (*    WRITELN ('RECEIVE data ');  *)
  5008.               I := 1 ;
  5009.               WHILE I <= InDataCount DO
  5010.                  BEGIN (* Write Data to file  *)
  5011.                    IF RecvData[I] = RepChar   then
  5012.                         BEGIN (* Repeat char   *)
  5013.                         I := I+1 ;
  5014.                         charcount := RecvData[I] - 32 ;
  5015.                         I := I + 1 ;
  5016.                         For j := 1 to charcount - 1 do
  5017.                              Write(Chr(RecvData[i]));
  5018.                         END ;  (* Repeat char  *)
  5019.                    IF RecvData[I] = Bit8Quote then
  5020.                         BEGIN (* 8TH BIT QUOTING  *)
  5021.                         I := I+1 ;
  5022.                         BIT8 := $80 ;
  5023.                         END   (* 8TH BIT QUOTING  *)
  5024.                                             else
  5025.                         BIT8 := 0 ;
  5026.                    IF RecvData[I] = CntrlQuote then
  5027.                         BEGIN (* CONTROL character *)
  5028.                         I := I+1 ;
  5029.                         IF RecvData[I] = $3F then   (* Make it a del *)
  5030.                                                    RecvData[I] := $7F
  5031.                                              else
  5032.                         IF RecvData[I] >= 64 then   (* Make it a control *)
  5033.                                           RecvData[I] := RecvData[I] - 64 ;
  5034.  
  5035.                        END ; (* CONTROL character *)
  5036.                    RecvData[I] := RecvData[I] + BIT8 ;
  5037.                    Write(Chr(RecvData[i])) ;
  5038.                    I := I + 1 ;
  5039.                  END ; (* Write Data to File *)
  5040.               Case Breakstate of
  5041.                    NoBreak : SendPacketType('Y');
  5042.                    BC : RECEIVING:=false ;
  5043.                    BE : SendPacketType('N') ;
  5044.                    BX : BreakAck('X') ;
  5045.                    BZ : BreakAck('Z') ;
  5046.                End; (* Case BreakState *)
  5047.               END   (* Receive data *)
  5048.                               else
  5049.          IF (InPacketType = Ord('F')) or (InPacketType=Ord('X')) then
  5050.               BEGIN (* repeat *)
  5051.               OutSeq := OutSeq - 1 ;
  5052.               SendPacketType('Y') ;
  5053.               END   (* repeat *)
  5054.                                                                    else
  5055.          IF InPacketType = Ord('Z') then SendPacketType('Y')
  5056.                                     else
  5057.          IF InPacketType = Ord('B') then Receiving := False
  5058.                                     else
  5059.          BEGIN (* Not D,Z packet *)
  5060.          STATE := A;   (* ABORT - Type not  D,Z, *)
  5061.          ABORT := NOT_DZ ;
  5062.          END ; (* Not D,Z packet *)
  5063.  
  5064.  
  5065.     (* C ----- COMPLETED  State ------- *)
  5066.      C:  BEGIN (* COMPLETED Receiving *)
  5067.          SendPacketType('Y');
  5068.          RECEIVING := FALSE ;
  5069.          END ; (* COMPLETED Receiving *)
  5070.  
  5071.     (* A ----- A B O R T  State ------- *)
  5072.      A:  BEGIN (* Abort Sending *)
  5073.          RECEIVING := FALSE ;
  5074.          (* SEND ERROR packet *)
  5075.          OutSeq   := 0 ;
  5076.          ErrorMsg :=' Abort while receiving data' ;
  5077.          OutDataCount := length(ErrorMsg);
  5078.          for i := 1 to length(ErrorMsg) do
  5079.               SendData[i] := Ord(ErrorMsg[i]) ;
  5080.          OutPacketType := Ord('E');
  5081.          SENDPACKET ;
  5082.          END ; (* Abort Sending *)
  5083.  
  5084.          END ; (* CASE of STATE *)
  5085.               End ; (* Issue Remote command Request *)
  5086.          End  ;  (* Generic Kermit Commands *)
  5087. End ; (* RemoteProc *)
  5088.  
  5089. (* +FILE+ MISCCOMM.PASMSCPM *)
  5090. (* ================================================================== *)
  5091. (* LOGIT - creates a Log file to record all incoming data from the    *)
  5092. (*       remote line.                                                 *)
  5093. (*           The file name is specified in the Parameter .            *)
  5094. (*               if no parameter specified logging is turned off.     *)
  5095. (* ================================================================== *)
  5096. Procedure Logit  (filename : comstring);
  5097. Begin (* Logit Procedure *)
  5098. If (length(filename) < 3) or (filename='OFF') then
  5099.     Begin (* Turn off Logging *)
  5100.     Logging := false ;
  5101.     Close (Logfile);
  5102.     Writeln (' Logging is turned off ');
  5103.     End   (* Turn off Logging *)
  5104.                         else
  5105.     Begin (* Turn on Logging *)
  5106.     If Logging then Close (Logfile);
  5107.     Logging := True ;
  5108.     Assign(Logfile,Filename);
  5109.     Rewrite(Logfile);
  5110.     Writeln(' Logging data to file ',filename);
  5111.     LogName := filename ;
  5112.     End ; (* Turn on Logging *)
  5113. End ; (* Logit Procedure)
  5114.  
  5115. (* ================================================================== *)
  5116. (* Takeit - read commands from a file and executes them.              *)
  5117. (*          if no file specified or file is not there if does nothing *)
  5118. (* ================================================================== *)
  5119. Procedure Takeit  (filename : comstring);
  5120. Begin (* Takeit Procedure *)
  5121. If length(filename) > 1 then
  5122.     If Firstfile(filename,dummy) then
  5123.          Begin (* Active file *)
  5124.          Writeln ('Activating Command file ',filename);
  5125.          ActiveCommandfile := true ;
  5126.          Assign(Commandfile,filename);
  5127.          Reset(Commandfile);
  5128.          End  (* Active file *)
  5129.                                 else
  5130.          Writeln('No file ',filename) ;
  5131. End ; (* Takeit Procedure)
  5132.  
  5133. (* ================================================================== *)
  5134. (* QuitExit    - Terminates the KERMIT.                               *)
  5135. (*             the QuitOptions are:                                   *)
  5136. (*                  LOCAL,REMOTE,DISCONnect,ALL                       *)
  5137. (*               if LOCAL or noparms only the local kermit terminates.*)
  5138. (*               if REMOTE then  only the remote kermit terminates.   *)
  5139. (*               if DISCONect then the remote kermit is terminated    *)
  5140. (*                       and the remote is logged off.                *)
  5141. (*               if ALL  then both kermits are terminated and remote  *)
  5142. (*                        is logged off.                              *)
  5143. (*                                                                    *)
  5144. (* ================================================================== *)
  5145. Procedure QuitExit  (QuitOption : comstring);
  5146. Const
  5147.     QuitTable : String[35] = '       LOCAL  REMOTE DISCON ALL    ' ;
  5148. Type QuitType = (zero,local,remote,discon,all);
  5149. Var
  5150.     Qix : integer  ;
  5151. Begin (* QuitExit Procedure *)
  5152. QuitOption := Uppercase(Concat(' ',QuitOption));
  5153. Qix := Pos(QuitOption,QuitTable) div 7 ;
  5154. Case QuitType(Qix) of    (* Quit Type *)
  5155.  zero,
  5156.  local:  Running := false ;
  5157.  remote :
  5158.          Begin (* terminate remote kermit *)
  5159.         (* Send a Finish packet *)
  5160.          OutDataCount := 1 ;
  5161.          OutSeq := OutSeq + 1 ;
  5162.          If OutSeq > 64 then OutSeq := 0 ;
  5163.          OutPacketType := Ord('G');
  5164.          SendData[1] := Ord('F');
  5165.          WaitXon := False ;
  5166.          SendPacket ;
  5167.          If RecvPacket and (InPacketType = Ord('Y')) then
  5168.                Writeln (' Remote Kermit terminated. ')
  5169.                                                      else
  5170.                Writeln(' Unable to terminate Remote Kermit. ');
  5171.          End ; (* terminate remote kermit *)
  5172. discon,
  5173. all:
  5174.          Begin (* logoff Remote  *)
  5175.          (* Send a Logoff packet *)
  5176.          OutDataCount := 1 ;
  5177.          OutSeq := OutSeq + 1 ;
  5178.          If OutSeq > 64 then OutSeq := 0 ;
  5179.          OutPacketType := Ord('G');
  5180.          SendData[1] := Ord('L');
  5181.          WaitXon := false ;
  5182.          SendPacket ;
  5183.          If RecvPacket and (InPacketType = Ord('Y')) then
  5184.               Writeln (' Remote host is logging off ')
  5185.                                                      else
  5186.               Writeln(' Remote host unable to execute a log off ');
  5187.          If (Qix = Ord(all))  then Running := False ;
  5188.          End;  (* Logoff Remote *)
  5189.     End ; (* Case Quit Type *)
  5190. End; (* QuitExit Procedure *)
  5191.  
  5192. (* +FILE+ TYPEDEF.PASDUMMY *)
  5193. (* TYPEDEF.SYS - Dummy  Include file  for non-graphics terminal simulation *)
  5194.  
  5195. (* +FILE+ GRAPHIX.PASDUMMY *)
  5196. (* GRAPHIX.SYS - Dummy  Include file  for non-graphics terminal simulation *)
  5197.  
  5198. (* +FILE+ KERNEL.PASDUMMY *)
  5199. (* KERNEL.SYS - Dummy  Include file  for non-graphics terminal simulation *)
  5200.  
  5201. (* +END-OF-FILES+ *)
  5202.