(* QK KERMIT, Turbo Pascal *) (* This file is the concatenation of the following files. Each begins *) (* with a comment line containing +FILE+ followed by the file name. *) (* KERMIT.PASMSCPM *) (* UTILITY.PASMSCPM *) (* SYSFUNC.PASMS *) (* SYSFUNC.PASCPM *) (* MODEMPRO.PASMS *) (* MODEMPRO.PASAPPLE *) (* MODEMPRO.PASKAYII *) (* DEFWORDS.PASMSCPM *) (* READCHAR.PASMSCPM *) (* PACKET.PASMSCPM *) (* SENDFILE.PASMS *) (* SENDFILE.PASCPM *) (* RECVFILE.PASMSCPM *) (* CONNECT.PASVT52 *) (* CONNECT.PASADM3A *) (* CONNECT.PASVT100 *) (* CONNECT.PASTEK10 *) (* SETSHOW.PASMSCPM *) (* LOCAL.PASMSCPM *) (* REMOTE.PASMSCPM *) (* MISCCOMM.PASMSCPM *) (* TYPEDEF.PASDUMMY *) (* GRAPHIX.PASDUMMY *) (* KERNEL.PASDUMMY *) (* The last line of this file should say +END-OF-FILES+ *) (* +FILE+ KERMIT.PASMSCPM *) {$C-} Program Kermit ; (* ***************************************************************** *) (* *) (* Author - Victor Lee, Queen's University, Kingston, Ontario *) (* Comments and problem can be sent to VIC@QUCDN.BITNET *) (* Phone - 613-547-6115 *) (* Contributions from Jeff Duncan *) (* Date - 1985 January *) (* - 1985 May 1 first official release *) (* - June 28 Add run command , fix logging *) (* - July 5 Fix Asfile bug. *) (* July 10 Fix Binary Transfer bug (no repeatchar) *) (* July 17 change write(ch) to ritechar to fix bug *) (* with keyboard input. *) (* July 23 Add I/O error handling,fix initparm bug, *) (* restrict source to 80 columns. *) (* Aug 7 Use $C- option, Eliminate the use of *) (* ritechar procedure. Add VT100 terminal *) (* simulation code *) (* Sept 9 Minor cleanup of code. Retry for reading *) (* Keytable file. *) (* Sept 18 Set version number. *) (* Sept 30 Check seqnum on recieved data packets. *) (* Nov. 01 Reenable auto remote command. *) (* Dec. 16 Insert Mode ( FatCursor indicator ) *) (* Dec. 20 Sub Directory commands and features *) (* Dec. 23 Audio Toggle . *) (* Date - 1986 Jan. 7 Allow Packet Parameter specifications. *) (* Jan. 14 Apl character set selection. *) (* Jan. 20 8bit quote and repeat char. bug fixed. *) (* Jan. 22 Remove some of the system dependant code *) (* from KERMIT.PAS. *) (* Jan. 29 Break key - to us ALT F10 . *) (* *) (* ***************************************************************** *) (* Utility Procedures *) (* HEX *) (* UpperCase *) (* GETTOKEN *) (* NewAsFile *) (* SysFunc Procedures - These are operating system dependent *) (* KeyChar *) (* CursorPosition *) (* CursorUp,CursorDown,CursorRight,CursorLeft *) (* LocalScreen,RemoteScreen *) (* FirstFile,Nextfile *) (* DefaultDrive *) (* SetDefaultDrive *) (* DisplayDiskStatus *) (* ExecFile *) (* Modem Procedures - These are Machine dependent procedures *) (* InitModem *) (* SetModem *) (* ResetModem *) (* DialModem *) (* RecvChar *) (* SendChar *) (* *) (* Define Word Procedures *) (* AssignDefWord *) (* DisplayDefWords *) (* CheckDefWords *) (* WriteDefWord *) (* DEFINEWORD *) (* LoadDefWords *) (* SaveDefWords *) (* Read Character Procedure *) (* ReadChar *) (* Packet Procedures *) (* SENDPACKET *) (* RECVPACKET *) (* RESENDIT *) (* SENDACK *) (* *) (* ------------------ COMMAND PROCEDURES -------------------- *) (* *) (* SENDFILE - Sends a file to another computer. *) (* RECVFILE - Receive a file from another computer. *) (* CONNECTION- Simulate a dumb terminal. *) (* SetShow Procedures *) (* SHOWIT - Display the options . *) (* SETIT - Set the options. *) (* DisplayCommands - Displays the commands available. *) (* *) (* Local Procedures *) (* DisplayDir - Display directory. *) (* EraseFiles - Erase files. *) (* RenameFiles - Rename files. *) (* DisplayFile - Display file (TYPE file ). *) (* (RunFile - Run a program ( See SYSFUNC procedures ) ) *) (* *) (* REMOTEPRO - Remote request procedures *) (* Misccomm Procedures *) (* Logit - log the session to a file. *) (* Takeit - take commands from a file. *) (* QuitExit - terminate kermits and log out. *) (* *) (* ***************************************************************** *) CONST VERSION = '2.5 ' ; (* <<<<<<<<<<<< V E R S I O N <<<<<<<<<<< *) Date = '1986 January 29 ' ; LocalChar = $1C ; (* control backslash ^\ *) BreakChar = $1D ; (* control right bracket ^] *) SOH = $01 ; (* Start of Header *) EOT = $04 ; (* End of transmission *) BS = $08 ; (* Back Space *) Xon = $11 ; Xoff = $13 ; ESC = $1B ; DEL = $7F ; TYPE layouts = (one,two,three,four,five,six,seven,eight,nine,ten) ; Commandindex = ( zero, connect, send, receive, setparm, status, directory, erase, rename, typefile, runfile, remote, log, take, define, help, mkdir, rmdir, chdir, audio, parms, quit, null ); comstring = string[80] ; Wstring = string[10] ; STATETYPE = (S,SF,SD,SZ,SB,C,A,R,RF,RD) ; ABORTTYPE = (NOSOH,BADSF,NOT_S,NOT_SFBZ,NOT_DZ); BREAKTYPE = (NOBREAK,BX,BZ,BC,BE); PACKET = PACKED ARRAY[1..255] OF BYTE ; ParityType = (OddP,EvenP,MarkP,NoneP); DefPointer = ^DefineRec ; DefineRec = Record Link : DefPointer ; DefWord : Wstring ; DefString : comstring ; End ; VAR STATE : STATETYPE ; ABORT : ABORTTYPE ; BREAKSTATE : BREAKTYPE ; RetryCount : Integer ; (* Packet variables *) (* format *) (* Receive Send *) (* SOH *) InCount, OutCount : BYTE ; (* COUNT *) INSEQ, OUTSEQ : BYTE ; (* SEQNUM *) INPACKETTYPE, OUTPACKETTYPE : BYTE ; (* TYPE *) RecvData, SendData : PACKET ; (* DATA... *) CHECKSUM : INTEGER ; (* CHECKSUM *) CRC : INTEGER ; (* CRC *) InDataCount, OutDataCount : BYTE ; (* dataCOUNT *) (* Initialization packet parameters *) PacketSize,Timeout,NumPad,PadChar,EndChar,StartChar, CntrlQuote,Bit8Quote,Checktype,RepChar : Byte ; (* Operational Options Parameters *) LocalEcho : Boolean ; Series1 : Boolean ; XonXoff : Boolean ; BaudRate : Integer ; Parity : ParityType ; PrimaryPort : Boolean ; AudioFlag,AplFlag,ParmFlag : Boolean ; (* Execution control flags *) WaitXon, Running, Logging, ForPrinter, ActiveCommandFile, GotSOH,DTRcheck : Boolean ; I : INTEGER ; inputstring : comstring ; command : Wstring ; commandtable,parmtable : string[255]; LogName,dummy : comstring ; Logfile,CommandFile : Text ; {$I Utility.Pas } {$I SYSFUNC.PAS } {$I MODEMPRO.PAS } {$I ReadChar.Pas } {$I DefWords.pas } {$I packet.pas } (* ----------------------------------------------------------------- *) (* SENDFILE - Procedure *) (* ----------------------------------------------------------------- *) {$I SENDFILE } (* ----------------------------------------------------------------- *) (* RECVFILE - Procedure *) (* ----------------------------------------------------------------- *) {$I RECVFILE } (* ----------------------------------------------------------------- *) (* Graphics - Procedures . This are only required for graphics. *) (* ----------------------------------------------------------------- *) {$I TYPEDEF } {$I GRAPHIX } {$I KERNEL } {*I POLYGON } {*I HATCH } (* ----------------------------------------------------------------- *) (* CONNECTION - Procedure *) (* ----------------------------------------------------------------- *) {$I CONNECT } (* ----------------------------------------------------------------- *) (* SHOWOPTIONS and SETOPTIONS and DisplayCommand - Procedures *) (* ----------------------------------------------------------------- *) {$I SETSHOW } (* ----------------------------------------------------------------- *) (* Local Procedures - Directory, Erase, Rename, Typefile *) (* ----------------------------------------------------------------- *) {$I LOCAL } (* ----------------------------------------------------------------- *) (* Remote Procedures *) (* ----------------------------------------------------------------- *) {$I REMOTE } (* ----------------------------------------------------------------- *) (* MiscCommands - LOG , Exit - Procedures *) (* ----------------------------------------------------------------- *) {$I MISCCOMM } (* ***************************************************************** *) (* ******** Outter Block of Kermit ****************************** *) (* ***************************************************************** *) BEGIN (* KERMIT *) commandtable := concat('bad ', 'CONNECT ', 'SEND ', 'RECEIVE ', 'SET ', 'STATUS ', 'DIRECTORY ', 'ERASE ', 'RENAME ', 'TYPE ', 'RUN EXEC ', 'REMOTE ', 'LOG ', 'TAKE ', 'DEFINE ', 'HELP ? ', 'MKDIR MD ', 'RMDIR RD ', 'CHDIR CD ', 'AUDIO ', 'PARMS ', 'QUIT ', 'DO LOCAL ') ; (* Default Packet settings *) PacketSize := 94 ; (* PACKET size 94 maximum *) Timeout := 60 ; (* Time out in seconds *) NumPad := 00 ; (* Number of Pad characters *) PadChar := 00 ; (* Padding Character *) EndChar := 13 ; (* End of line char - CR *) StartChar := 01 ; (* Start of Packet char - SOH *) CntrlQuote := 35 ; (* # *) Bit8Quote := 38 ; (* & *) CheckType := 49 ; (* 1 *) RepChar := 00 ; (* ~ *) (* Default Settings *) Baudrate := DefaultBaud ; Parity := EvenP ; XonXoff := False ; Series1 := True ; LocalEcho := False ; PrimaryPort := True ; AudioFlag := False ; AplFlag := False ; ParmFlag := False ; (* Set control flow flags *) connected := false ; logging := false ; ForPrinter := false ; ActiveCommandfile := false ; GotSOH := false ; DTRcheck := true ; Running := true; DefList := Nil ; LoadDefWords ; NewDefs := false ; InitModem ; inputstring := commandline ; (* writeln(commandline); *) ReadKeyTable; Writeln(' * ======================================== * '); Writeln(' * Queen''s University - KERMIT /',termtype,' * '); Writeln(' * * '); Writeln(' * Version ',version,Gversion,' - ',Date,' * '); Writeln(' * Author - Victor Lee * '); Writeln(' * Graphics ',Graphics,' * '); Writeln(' * ======================================== * '); While Running Do Begin (* Command Loop *) if audioflag then Begin sound(1500);delay(50);sound(300);delay(50);nosound; end ; if length(inputstring)<1 then if ActiveCommandFile then Begin (* Get command from file *) Readln(Commandfile,inputstring); ActiveCommandFile := not Eof(commandfile); End else Begin (* ask for input *) Write('QK-Kermit>'); (* PROMPT for input *) readln(inputstring); End ; (* ask for input *) command := Uppercase(GETTOKEN(inputstring)); CheckDefWords(DefList,command,Inputstring); command := ' ' + command ; WaitXon := false ; case commandindex(POS(command,commandtable) div 10 ) of zero : If length(command)>1 then Begin (* bad command *) Writeln(' Invalid Command >>>>> ',Command,' <<<<<'); Writeln('--- Type HELP to see valid Commands.--- '); End ; (* bad command *) connect : Begin If length(inputstring) > 1 then SetOptions(inputstring); CONNECTION ; End; send : SENDFILE (inputstring); receive : RECVFILE (inputstring ); setparm : SetOptions(inputstring); status : ShowOptions ; directory: DisplayDir (GetToken(inputstring)); erase : EraseFiles (GetToken(inputstring)); rename : RenameFile (inputstring); typefile : DisplayFile (GetToken(inputstring)); runfile : EXECFile (inputstring); remote : RemoteProc (inputstring); log : Logit (GetToken(inputstring)); take : Takeit (GetToken(inputstring)); define : DefineWord(inputstring); help : DisplayCommands ; mkdir : MkdirFunc (GetToken(inputstring)) ; rmdir : RmdirFunc (GetToken(inputstring)) ; chdir : ChdirFunc (GetToken(inputstring)) ; audio : AudioFlag := AudioFlag xor True ; parms : ParmFlag := ParmFlag xor True ; quit : QuitExit (UpperCase(GetToken(inputstring))); null : ; end ; (* Case commandindex *) End ; (* Command Loop *) If Logging then Close(Logfile); If NewDefs then SaveDefWords ; If audioflag then begin sound(1500);delay(200);sound(3000);delay(200);end ; If connected then ResetModem; If audioflag then begin sound(2000);delay(200); nosound; end ; ClrScr; Gotoxy(20,10); Write( ' G O O D - B Y E '); END. (* KERMIT *) (* +FILE+ UTILITY.PASMSCPM *) (* ============ Begining of U T I L I T Y Procedures ============ *) Type String2 = String[2]; (* ----------------------------------------------------------------- *) (* GETTOKEN - Function *) (* ----------------------------------------------------------------- *) Function GETTOKEN ( var instring : comstring) : comstring ; Var pt : byte ; Begin (* GETTOKEN *) While (instring[1] = ' ') and (length(instring)>1) do Delete(instring,1,1); (* eliminate leading blanks *) pt := POS(' ',instring); if pt = 0 then pt := length(instring)+1 ; GETTOKEN := copy(instring,1,pt-1); DELETE(instring,1,pt); End ; (* GETTOKEN *) (* ----------------------------------------------------------------- *) (* UpperCase - Function *) (* ----------------------------------------------------------------- *) Function UpperCase ( instring : comstring) : comstring ; Var ix,len : integer ; Begin (* UpperCase *) len := length(instring) ; for ix := 1 to len do instring[ix] := Upcase(instring[ix]); UpperCase := instring ; End ; (* UpperCase *) (* ----------------------------------------------------------------- *) (* CRCheck - Procedure - generates a CCITT CRC using the polynominal *) (* X^16 + X^12 + X^5 + 1 *) (* Side Effects : Updates the global variable CRC which should be *) (* initialized to 0. It is call only once for each *) (* byte to be checked and all 8 bits are included. *) (* No terminating calls are necessary. *) (* ----------------------------------------------------------------- *) Procedure CRCheck ( Abyte : byte ) ; Var j,temp : integer ; Begin (* CRCheck *) For j := 0 to 7 do Begin (* check all 8 bits *) temp := CRC xor Abyte ; CRC := CRC shr 1 ; (* shift right *) If Odd(temp) then CRC := CRC xor $8408 ; abyte := abyte shr 1 ; End ; (* check all 8 bits *) End ; (* CRCheck *) (* ----------------------------------------------------------------- *) (* Prefixof Function - Returns a char string of the dir prefix. *) (* ----------------------------------------------------------------- *) function Prefixof(afilename:comstring) : comstring; var i :integer; label exit ; begin (* Prefixof *) while length(afilename)>0 do If afilename[length(afilename)] in [':','\','/'] then goto exit else delete(afilename,length(afilename),1); exit: Prefixof := afilename ; end; (* Prefixof *) (* ----------------------------------------------------------------- *) (* NewAsFile - returns a new ASFILE name in the parameter AsFile. *) (* MyFiles - is the wild char name. *) (* Filename - is the filename to be renamed . *) (* AsFiles - is the wild char name of new file. *) (* AsFile - is the new file name. *) (* returns TRUE if AsFile correctly assigned. *) (* returns FALSE if AsFile detected an error in assignment *) (* There is a BUG in the MsDoS Call to get next Directory Entry *) (* therefore this function may return FALSE. *) (* *) (* ----------------------------------------------------------------- *) Function NewAsFile (MyFiles,Filename,AsFiles: comstring; var AsFile : comstring ): boolean; var temp : comstring ; si,ix,iy : integer ; star : packed array[1..8] of string[20]; Label Subdir,Exit; Begin (* NewAsFile Function *) for si := 1 to 8 do star[si] := '*'; si := 0 ; MyFiles := Uppercase(Myfiles); FileName := Uppercase(Filename); AsFiles := Uppercase(AsFiles); ix := Pos(':',MyFiles) ; If ix > 1 then delete(MyFiles,1,ix) ; (* Eliminate filemode prefix *) subdir: ix := Pos('\',MyFiles) ; If ix > 1 then delete(MyFiles,1,ix) ; (* Eliminate sub-dir prefixs *) if ix > 1 then goto subdir ; ix := Pos(':',AsFiles) ; If ix > 1 then delete(AsFiles,1,ix) ; (* Eliminate filemode prefix *) While (length(Filename) > 0) and (length(Myfiles)>0) Do Begin (* Scan filename *) If MyFiles[1] = Filename[1] then Begin delete(MyFiles,1,1) ; delete(Filename,1,1); end else Begin (* get star string *) si:=si+1 ; delete(MyFiles,1,1); ix := Pos('*',MyFiles) - 1 ; (* Next wild char *) if ix <= 0 then temp := MyFiles else temp := copy(Myfiles,1,ix); iy := Pos(temp,Filename)-1 ; if iy < 0 then begin NEWASFILE:=FALSE; Asfile:='temp.dat'; Goto exit ; end; if iy = 0 then star[si] := filename else star[si] := copy(filename,1,iy); delete(FileName,1,iy); End ;(* get star string *) End; (* Scan filename *) ix := 1 ; si := 1 ; AsFile := ''; While ix <= length(AsFiles) do Begin (* Create AsFile name *) If AsFiles[ix] in ['*','?'] then Begin (* wild char *) AsFile := Concat(AsFile,star[si]); si := si + 1 ; End else AsFile := Concat(AsFile,Asfiles[ix]); ix := ix + 1 ; End ; (* Create AsFile name *) NewAsFile := True ; Exit: End; (* NewASFile Function *) (* ============ End of U T I L I T Y Procedures =================== *) (* +FILE+ SYSFUNC.PASMS *) (* ================================================================= *) (* MsDos SYSTEM dependent Routines for Kermit . *) (* ================================================================= *) (* Global Declaration *) CONST (* FLAGS in flag register *) Cflag = $0001 ; Pflag = $0004 ; Aflag = $0010 ; Zflag = $0040 ; Tflag = $0100 ; Iflag = $0200 ; Dflag = $0400 ; Oflag = $0800 ; TYPE regtype = record case layouts of one: ( ax,bx,cx,dx,bp,si,di,ds,es,flags : integer ;); two: ( al,ah,bl,bh,cl,ch,dl,dh : byte ; ) ; three : ( Sectors,Clusters,BytesperSec,TotalClusters: integer;) end ; ScreenArray = array [1..4000] of byte ; VAR register : regtype ; MyDTA : array [1..43] of byte ; Remotecursor,LocalCursor : integer ; Commandline : comstring absolute Cseg:$80 ; MonoScreen : ScreenArray absolute $B000:$0000 ; (* Monchrome Video *) ColorScreen : ScreenArray absolute $B800:$0000 ; (* Colour graphics *) OldLocalScreen : ScreenArray ; OldRemoteScreen : ScreenArray ; NumLock,ScrollLock : byte ; (* ------------------------------------------------------------------ *) (* KeyChar - get a character from the Keyboard. *) (* It returns TRUE if character found and the char is *) (* returned in the parameter. *) (* It returns FALSE if no keyboard character. *) (* *) (* ------------------------------------------------------------------ *) Function KeyChar (var Achar,Bchar : byte): boolean ; Begin (* KeyChar *) with register do begin ah := 1; intr($16,register); if (Zflag and flags)=Zflag then (* ------ The following code is required only if we want to us the ----- *) (* ------ NUMLOCK and SCROLLLOCK key as function keys ----------------- *) begin (* check for Numlck and Scroll Lck *) ah := 2; intr($16,register); If (al and $10) <> ScrollLock then Case (al and $0F) of 0: Bchar := $46 ; (* not shifted *) 1,2,3: Bchar := $86 ; (* shifted *) 4,5,6,7: Bchar := $87 ; (* control *) else Bchar := $87 ; (* Alt *) end (* case *) else If (al and $20) <> NumLock then Case (al and $0F) of 0: Bchar := $45 ; (* not shifted *) 1,2,3: Bchar := $85 ; (* shifted *) 4,5,6,7: Bchar := $88 ; (* control *) (* Not Available *) Else Bchar := $88 ; (* Alt *) End (* case *) else Bchar := 0 ; ScrollLock := (al and $10) ; NumLock := (al and $20) ; Achar := 0 ; If Bchar <> 0 then KeyChar := true else KeyChar := false End (* check for Numlck and Scroll Lck *) (*------ If you don't need this code, replace it with ------------------ *) (* -------- KeyChar := False ----------------------------------------- *) else begin ah := 0; intr($16,register); Achar := al ; Bchar := ah ; KeyChar := true; end ; end; End ; (* KeyChar *) (* ------------------------------------------------------------------ *) (* CursorPosition - Returns Cursor Position in Reg DX. *) (* ------------------------------------------------------------------ *) Procedure CursorPosition ; Begin (* CursorPosition *) With register do begin (* Get position *) ah := 3; intr($10,register); end; (* Get position *) End; (* ------------------------------------------------------------------ *) (* CursorUp - *) (* ------------------------------------------------------------------ *) Procedure CursorUp ; Begin (* CursorUp *) With register do begin (* Move up *) ah := 3; (* Function code 3 - Read Cursor Position *) intr($10,register); if dh > 1 then dh := dh - 1 else dh := 24 ; ah := 2 ; (* Function code 2 - Set Cursor Position *) intr($10,register); end; (* Move up *) End; (* CursorUp *) (* ------------------------------------------------------------------ *) (* CursorDown - *) (* ------------------------------------------------------------------ *) Procedure CursorDown ; Begin (* CursorDown *) With register do begin (* Move Down *) ah := 3; (* Function code 3 - Read Cursor Position *) intr($10,register); if dh < 24 then dh := dh + 1 else dh := 1 ; ah := 2 ; (* Function code 2 - Set Cursor Position *) intr($10,register); end; (* Move Down *) End; (* CursorDown *) (* ------------------------------------------------------------------ *) (* CursorRight - *) (* ------------------------------------------------------------------ *) Procedure CursorRight ; Begin (* CursorRight *) With register do begin (* Move Right *) ah := 3; (* Function code 3 - Read Cursor Position *) intr($10,register); if dl < 80 then dl := dl + 1 else dl := 1 ; ah := 2 ; (* Function code 2 - Set Cursor Position *) intr($10,register); end; (* Move Right *) End; (* CursorRight *) (* ------------------------------------------------------------------ *) (* CursorLeft - *) (* ------------------------------------------------------------------ *) Procedure CursorLeft ; Begin (* CursorLeft *) With register do begin (* Move Left *) ah := 3; (* Function code 3 - Read Cursor Position *) intr($10,register); if dl > 0 then dl := dl - 1 else dl := 80 ; ah := 2 ; (* Function code 2 - Set Cursor Position *) intr($10,register); end; (* Move Left *) End; (* CursorLeft *) (* ------------------------------------------------------------------ *) (* FatCursor - *) (* ------------------------------------------------------------------ *) Procedure FatCursor(flag :boolean); Begin (* FatCursor *) Port[$3D4] := $B ; (* Select Cursor end Register *) If flag then Port[$3D5] := 9 else Port[$3D5] := 7 ; End; (* FatCursor *) (* ------------------------------------------------------------------ *) (* RemoteScreen - Procedure *) (* This procedure save the local screen and restores *) (* the remote screen. *) (* Also setup the 25th line to display settings *) (* ------------------------------------------------------------------ *) Procedure RemoteScreen ; Begin (* RemoteScreen *) If (OldRemoteScreen[4000]<>1) or (OldRemoteScreen[3999]<>32) then Begin (* Initialize OldRemoteScreen *) For i := 1 to 4000 do OldRemoteScreen[i] := 32 ; OldRemoteScreen[4000] := 1 ; RemoteCursor := $0000 ; End ; (* Initialize OldRemoteScreen *) With register do begin (* Switch Screens *) bx := 0 ; ah := 15; (* Function code 15 - Return Current video State *) intr($10,register); if al < 7 then Begin (* Color Screen *) OldLocalScreen := ColorScreen ; ColorScreen := OldRemoteScreen ; End (* Color Screen *) else Begin (* MonoChrome Screen *) OldLocalScreen := MonoScreen ; MonoScreen := OldRemoteScreen ; End (* MonoChrome Screen *) end ; (* Switch Screens *) With register do begin (* Save ? Restore Cursor *) bx := 0 ; ah := 3; (* Function code 3 - Read Cursor Position *) intr($10,register); localcursor := dx ; (* ---- set up 25th line with status ------ *) ah := 2; (* Function code 2 - Set Cursor Position *) DX := $1800; (* Set the cursor to Row 25 and column 0 *) Intr($10,Register); Textcolor(Blue); Textbackground(Yellow); Write (' Port '); If PrimaryPort then Write('One : ') else Write('Two : '); Write(Baudrate,' baud, '); Case paritytype(parity) of OddP : write('Odd '); EvenP: write('Even '); MarkP: write('Mark '); NoneP: write('None '); end ; (* parity case *) Write('parity, '); If LocalEcho then Write('Half duplex, ') else Write('Full duplex, '); If XonXoff then write('Xon-Xoff ') else if Series1 then write('Series/1 ') else write('Standard '); Write (' ExitChar=CTL ',chr($40+LocalChar),' ' ) ; Textcolor(LightGreen); Textbackground(0); (* -------------------------------------------- *) dx := remotecursor ; ah := 2 ; (* Function code 2 - Set Cursor Position *) intr($10,register); end; (* Save ? Restore Cursor *) Window(1,1,80,24); End; (* RemoteScreen *) (* ------------------------------------------------------------------ *) (* LocalScreen - Procedure *) (* This procedure save the remote screen and restores *) (* the local screen. *) (* ------------------------------------------------------------------ *) Procedure LocalScreen ; Begin (* LocalScreen *) With register do begin (* Switch Screens *) bx := 0 ; ah := 15; (* Function code 15 - Return Current video State *) intr($10,register); if al < 7 then Begin (* Color Screen *) OldRemoteScreen := ColorScreen ; ColorScreen := OldLocalScreen ; End (* Color Screen *) else Begin (* MonoChrome Screen *) OldRemoteScreen := MonoScreen ; MonoScreen := OldLocalScreen ; End (* MonoChrome Screen *) end ; (* Switch Screens *) With register do begin (* Save and Restore Cursor *) ah := 3; (* Function code 3 - Read Cursor Position *) intr($10,register); Remotecursor := dx ; dx := Localcursor ; ah := 2 ; (* Function code 2 - Set Cursor Position *) intr($10,register); end; (* Save and Restore Cursor *) TextColor(Yellow); TextBackground(Black); Window(1,1,80,25); End; (* LocalScreen *) (* ----------------------------------------------------------------- *) (* FirstFile - Returns True if file found for file mask Myfile *) (* and the first file name is returned in Filename *) (* - Returns False if no file Found. *) (* ----------------------------------------------------------------- *) Function FirstFile(Myfile:Comstring; var Filename:Comstring): Boolean ; Var OldSegment,OldOffset,i : integer ; Begin (* FirstFile Function *) Myfile := concat(myfile,chr(0)); With Register do Begin { Search for File } Ax := $2F00 ; { Get DTA Dos Function } MsDos(Register); OldSegment := Es ; OldOffset := Bx ; (* save old DTA location *) Ds := Seg(MyDTA); Dx := Ofs(MyDTA) ; Ax := $1A00 ; { Set DTA Dos Function } MsDos(Register); (* set my DTA location *) Ax := $4E00 ; {get first directory entry } Ds := Seg(Myfile); { mask location } Dx := Ofs(Myfile)+1; Cx := 2 ; {option} MsDos(Register); if al = 0 then { Got file } Begin (* Got File *) i := 1 ; Repeat Filename[i] := Chr (MyDTA[30 + i]) ; i := i + 1 ; until (not (Filename[i-1] in [' '..'~'])) ; Filename[0] := chr(i - 2); Firstfile := true ; End (* Got file *) else Firstfile := False ; Ds := OldSegment ; Dx := OldOffset ; Ax := $1A00 ; { Set DTA Dos Function } MsDos(Register); (* reset old DTA location *) End; { Search for File } End; { FirstFile Function } (* ----------------------------------------------------------------- *) (* NextFile - Returns True if file found for file mask Myfile *) (* and the first file name is returned in Filename *) (* - Returns False if no file Found. *) (* ----------------------------------------------------------------- *) Function NextFile(Var Myfile, Filename : Comstring): Boolean ; Var OldSegment,OldOffset,i : integer ; Begin (* NextFile Function *) With Register do Begin { Search for File } Ax := $2F00 ; { Get DTA Dos Function } MsDos(Register); OldSegment := Es ; OldOffset := Bx ; (* save old DTA location *) Ds := Seg(MyDTA); Dx := Ofs(MyDTA) ; Ax := $1A00 ; { Set DTA Dos Function } MsDos(Register); (* set my DTA location *) Ax := $4F00 ; { get next directory entry } MsDos(Register); if al = 0 then { Got file } Begin (* Got File *) i := 1 ; Repeat Filename[i] := chr (MyDTA[30 + i]) ; i := i + 1 ; until (not (Filename[i-1] in [' '..'~'])) ; Filename[0] := chr(i - 2); Nextfile := true ; End (* Got file *) else Nextfile := False ; Ds := OldSegment ; Dx := OldOffset ; Ax := $1A00 ; { Set DTA Dos Function } MsDos(Register); (* reset old DTA location *) End; { Search for File } End; { NextFile Function } (* ------------------------------------------------------------------ *) (* SetDefaultDrive - *) (* ------------------------------------------------------------------ *) Procedure SetDefaultDrive (Drive : Byte); Begin (* SetDefaultDrive *) With register do begin (* Select disk *) DL := Drive ; Ax := $0E00 ; { Select default drive } MsDos(Register); end; (* Select disk *) End; (* SetDefaultDrive *) (* ------------------------------------------------------------------ *) (* DefaultDrive - returns the value of the default drive *) (* A=0,B=1,C=2 etc. *) (* ------------------------------------------------------------------ *) Function DefaultDrive : Byte ; Begin (* DefaultDrive *) With register do begin (* Current disk *) Ax := $1900 ; { Find default drive } MsDos(Register); DefaultDrive := al ; end; (* Current disk *) End; (* DefaultDrive *) (* ----------------------------------------------------------------- *) (* DisplayDiskStatus - Display the disk status for the default disk.*) (* *) (* ----------------------------------------------------------------- *) Procedure DisplayDiskStatus ; Var Freebytes : real ; Begin (* DisplayDiskStatus *) With Register do Begin { Get disk status } dl := DefaultDrive + 1 ; (* use default drive *) Write (' Disk Drive ',chr(DX+$40),': '); Ax := $3600 ; { Get diskstatus Function } MsDos(Register); Writeln('Bytes/sector = ',BytesperSec,' Sector/cluster = ',Sectors); Writeln('Total Clusters = ',TotalClusters); FreeBytes := BytesperSec*Sectors; (* two steps required due to *) FreeBytes := FreeBytes*Clusters ; (* integer overflow *) Writeln('Free Clusters = ',Clusters,' i.e. ',Freebytes:7:0,' bytes free'); End; (* Get disk status *) End; (* DisplayDiskStatus *) (* ----------------------------------------------------------------- *) (* MkDir - Make Directory. *) (* ----------------------------------------------------------------- *) Procedure MkDirFunc(DirName:Comstring) ; Begin (* MkDir *) DirName := DirName + chr(0) ; With Register do Begin { MD } Ds := Seg(DirName); Dx := Ofs(DirName)+1 ; Ax := $3900 ; { MkDir Function } MsDos(Register); While Mem[Ds:Dx] <> 0 Do Begin Write(Chr(Mem[Ds:Dx])); Dx := Dx + 1 ; End ; Case Al of 0: writeln(' - New Directory Made '); 3: writeln(' - Path not found'); 5: writeln(' - Acess denied'); else writeln(' - Return code =',al); end; (* case of Ax *) End ; { MD } End ; (* MkDir *) (* ----------------------------------------------------------------- *) (* RmDir - Remove Directory. *) (* ----------------------------------------------------------------- *) Procedure RmDirFunc(DirName:Comstring) ; Begin (* RmDir *) DirName := DirName + chr(0) ; With Register do Begin { Remove Directory } Ds := Seg(DirName); Dx := Ofs(DirName)+1 ; Ax := $3A00 ; { RmDir Function } MsDos(Register); While Mem[Ds:Dx] <> 0 Do Begin Write(Chr(Mem[Ds:Dx])); Dx := Dx + 1 ; End ; Case Al of 0: writeln(' - Directory Removed '); 3: writeln(' - Path not found'); 5: writeln(' - Acess denied'); else writeln(' - Return code =',al); end; (* case of Ax *) End ; { Remove Directory } End ; (* RmDir *) (* ----------------------------------------------------------------- *) (* ChDir - Change Directory. *) (* ----------------------------------------------------------------- *) Procedure ChDirFunc(DirName:Comstring) ; Begin (* ChDir *) DirName := DirName + chr(0) ; With Register do Begin { CD } Ds := Seg(DirName); Dx := Ofs(DirName)+1 ; Ax := $3B00 ; { ChDir Function } MsDos(Register); While Mem[Ds:Dx] <> 0 Do Begin Write(Chr(Mem[Ds:Dx])); Dx := Dx + 1 ; End ; Case Al of 0: writeln(' - Current Directory '); 3: writeln(' - Path not found'); 5: writeln(' - Acess denied'); else writeln(' - Return code =',al); end; (* case of Ax *) End ; { CD } End ; (* ChDir *) (* ----------------------------------------------------------------- *) (* EXECFile - Exec a file. *) (* *) (* ----------------------------------------------------------------- *) Procedure EXECFile (Var RunString : comstring) ; Type FCB = record Drive : char ; filename : array [1..8] of char ; filetype : array [1..3] of char ; Curblock : integer ; Recsize : integer ; DosUse : array [1..16] of char ; CurRec : byte ; Randlow : integer ; Randhigh : integer ; end ; PPBrecord = record SegAddr : integer ; ComlinePt : ^Comstring ; FCB1pt,FCB2pt : ^FCB ; end; Var PPB : PPBrecord ; Myfile : comstring ; FCB1,FCB2 : FCB ; Begin (* RunFile *) Myfile := Gettoken(Runstring); If Pos('.',Myfile) = 0 then Myfile := Myfile + '.COM' ; With Register do Begin (* SetBlock - Modify allocated Memory Blocks *) Ax := $4A00 ; (* Set Block - Free up unused memory *) Es := CSeg ; (* Point to begining of block *) Bx := SSeg ; (* Amount of memory in use *) MsDos(Register); Writeln(Register.BX,' paragraphs of memory in use .'); End ; (* SetBlock - Modify allocated Memory Blocks *) Writeln(' Exec program ',Myfile); Myfile := Myfile + chr($00) ; With Register do Begin (* Set up Run *) Ax := $4B00 ; (* Load and EXEC Function *) (* Ax := $4B03 ; *) (* Load Overlay Function *) DS := Seg(Myfile); DX := Ofs(Myfile)+1 ; (* Point to Program name *) ES := Seg(PPB) ; BX := Ofs(PPB); (* Point to Program Parm block *) With PPB do BEGIN (* set up Program Parameter Block *) SegAddr := Memw[CSEG :$2C] ; Comlinept := Addr(RunString); FCB1pt := Addr(FCB1); FCB2pt := Addr(FCB2); End ; (* set up Program Parameter Block *) (* MsDos(Register); *) (* The following in line code does the same thing as the MsDos call *) (* with the exception that it also save and restores the SS and SP reg. *) Inline ( $BF/Register/ (* MOV DI,Register *) $1E/ (* PUSH DS *) $07/ (* POP ES *) $1E/ (* PUSH DS *) $06/ (* PUSH ES *) $57/ (* PUSH DI *) $55/ (* PUSH BP *) $53/ (* PUSH BX *) $B9/$09/$00/ (* MOV CX,0009 *) $26/ (* ES: *) $FF/$35/ (* PUSH [DI] *) $47/ (* INC DI *) $47/ (* INC DI *) $E2/$F9/ (* LOOP back to PUSH [DI] *) $07/ (* POP ES *) $1F/ (* POP DS *) $5F/ (* POP DI *) $5E/ (* POP SI *) $5D/ (* POP BP *) $5A/ (* POP DX *) $59/ (* POP CX *) $5B/ (* POP BX *) $58/ (* POP AX *) (* Now save SS and SP in location 104 of Code Segment *) $57/ (* PUSH DI *) $BF/$0104/ (* MOV DI,0104 *) $2E/ (* CS: *) $8C/$15/ (* MOV [DI],SS *) $47/ (* INC DI *) $47/ (* INC DI *) $2E/ (* CS: *) $89/$25/ (* MOV [DI],SP *) $5F/ (* POP DI *) (* This dumb msdos call destroys all the register including SS and SP *) $CD/$21/ (* ******** MsDos Call ******** *) (* Restore the SS and SP register from location 104 of Code Segment *) $BF/$0104/ (* MOV DI,0104 *) $2E/ (* CS: *) $8E/$15/ (* MOV SS,[DI] *) $47/ (* INC DI *) $47/ (* INC DI *) $2E/ (* CS: *) $8B/$25/ (* MOV SP,[DI] *) $5F/ (* POP DI *) (* Now restore the rest of the registers from the stack *) $9C/ (* PUSH F *) $06/ (* PUSH ES *) $1E/ (* PUSH DS *) $57/ (* PUSH DI *) $56/ (* PUSH SI *) $55/ (* PUSH BP *) $52/ (* PUSH DX *) $51/ (* PUSH CX *) $53/ (* PUSH BX *) $50/ (* PUSH AX *) $8B/$EC/ (* MOV BP,SP *) $8B/$7E/$18/ (* MOV DI,[BP+18] *) $8E/$46/$1A/ (* MOV ES,[BP+1A] *) $B9/$0A/$00/ (* MOV CX,000A *) $26/ (* ES: *) $8F/$05/ (* POP [DI] *) $47/ (* INC DI *) $47/ (* INC DI *) $E2/$F9/ (* LOOP back to POP [DI] *) $5B/ (* POP BX *) $5D/ (* POP BP *) $5F/ (* POP DI *) $07/ (* POP ES *) $1F); (* POP DS *) Case Ax of 2: writeln('File >>> ',Myfile, ' <<< not found'); 5: writeln('Acess denied'); 8: writeln('Insufficient Memory to load program'); 10: writeln('Invalid Environment'); end; (* case of Ax *) End; (* Set up Run *) Writeln(' Return from Execution of ',Myfile); End; (* RunFile *) (* +FILE+ SYSFUNC.PASCPM *) (* ================================================================= *) (* CP/M SYSTEM dependent Routines for Kermit *) (* ================================================================= *) (* Global Declaration *) TYPE FCBrecord = record Drive : byte ; Fname : array [1..8] of char ; Ftype : array [1..3] of char ; Extent: byte ; Sbite1: byte ; Sbite2: byte ; RCount: byte ; (* record count *) CBdata: array [1..16] of char ; CurRec: byte ; r0r1 : integer ; r2 : byte ; end ; listpointer = ^Filenamerec; Filenamerec = record Link : listpointer ; nextname : string[12] ; end ; VAR Commandline : string[80] absolute $80 ; FCB : FCBrecord absolute $005C ; DMA : array[0..255] of char ; FNHead : listpointer ; Marker : listpointer ; (* ------------------------------------------------------------------ *) (* Sound - Dummy sound routine for CPM system. *) (* ------------------------------------------------------------------ *) Procedure Sound (dummy : integer ); Begin (* Sound *) write(chr(7)); End ; (* Sound *) Procedure Nosound ; begin end; (* ------------------------------------------------------------------ *) (* KeyChar - get a character from the Keyboard. *) (* It returns TRUE if character found and the char is *) (* returned in the parameter. *) (* It returns FALSE if no keyboard character. *) (* *) (* ------------------------------------------------------------------ *) Function KeyChar (var Achar,Bchar : byte): boolean ; var mychar : char ; Begin (* KeyChar *) If keypressed then Begin (* got a key *) Read(KBD,mychar); Achar := Ord(mychar); Bchar := 0; KeyChar := true ; End else Keychar := false ; End ; (* KeyChar *) (* ------------------------------------------------------------------ *) (* RemoteScreen - Save the local screen and restores the Remotescreen *) (* ------------------------------------------------------------------ *) Procedure RemoteScreen ; Begin (* RemoteScreen *) Clrscr ; End; (* ------------------------------------------------------------------ *) (* LocalScreen - Save the local screen and restores the Remotescreen *) (* ------------------------------------------------------------------ *) Procedure LocalScreen ; Begin (* LocalScreen *) Clrscr ; End; (* ------------------------------------------------------------------ *) (* CursorPosition - Returns Cursor Position in Reg DX. *) (* ------------------------------------------------------------------ *) Procedure CursorPosition ; Begin (* CursorPosition *) End; (* ------------------------------------------------------------------ *) (* CursorUp - *) (* ------------------------------------------------------------------ *) Procedure CursorUp ; Begin (* CursorUp *) write(Chr($0B)); (* Vertical Tab *) End; (* CursorUp *) (* ------------------------------------------------------------------ *) (* CursorDown - *) (* ------------------------------------------------------------------ *) Procedure CursorDown ; Begin (* CursorDown *) write(Chr($0A)); (* LineFeed *) End; (* CursorDown *) (* ------------------------------------------------------------------ *) (* CursorRight - *) (* ------------------------------------------------------------------ *) Procedure CursorRight ; Begin (* CursorRight *) write(Chr($0C)); (* Form Feed *) End; (* CursorRight *) (* ------------------------------------------------------------------ *) (* CursorLeft - *) (* ------------------------------------------------------------------ *) Procedure CursorLeft ; Begin (* CursorLeft *) write(Chr($08)); (* BackSpace *) End; (* CursorLeft *) (* ------------------------------------------------------------------ *) (* SetDefaultDrive - *) (* ------------------------------------------------------------------ *) Procedure SetDefaultDrive (Drive : Byte); Var dummy : byte ; Begin (* SetDefaultDrive *) Dummy := Bdos(14,Drive); (* Select Drive *) End; (* SetDefaultDrive *) (* ------------------------------------------------------------------ *) (* DefaultDrive - returns the value of the default drive *) (* A=0,B=1,C=2 etc. *) (* ------------------------------------------------------------------ *) Function DefaultDrive : Byte ; Begin (* DefaultDrive *) DefaultDrive := Bdos(25) ; (* Current Disk *) End; (* DefaultDrive *) (* ----------------------------------------------------------------- *) (* ----------------- Build Next List Procedure --------------------- *) Procedure BuildNextList(var Pt : listpointer); Var dot,i,results : byte ; Newpt: listpointer ; Begin (* BuildNextList *) I := Bdos(26,addr(DMA)); Results := Bdos(18); If Results < 4 then Begin (* found file *) New(Newpt); Pt := Newpt; With Newpt^ do Begin (* Get file name in list *) Link := nil ; nextname[0] := chr(12) ; results := results * 32 ; for i := 1 to 8 do nextname[i] := DMA[results+i] ; nextname[9] := ' ' ; dot := pos(' ',nextname) ; nextname[dot] := '.' ; for i := 1 to 3 do nextname[dot+i] := DMA[results+8+i] ; nextname[0] := Chr(dot+3) ; end ; (* Get file name in list *) BuildNextList(Newpt^.link) End ; (* Found file *) (* else do nothing *) ; End ; { BuildNextlist } (* ----------------- Get Next Procedure ----------------------------------- *) Function GetNext ( Var FN : comstring ): boolean ; Var Pt : listpointer ; Begin (* GetNext *) If FNhead = Nil then Begin (* end of List *) GetNext := false ; Release(Marker); End (* end of list *) else Begin (* get name *) FN := FNhead^.nextname; pt := Fnhead ; FNhead := Fnhead^.link ; GetNext := true ; End ; (* get name *) End ; (* GetNext *) (* ----------------------------------------------------------------- *) (* ----------------------------------------------------------------- *) (* FirstFile - Returns True if file found for file mask Myfile *) (* and the first file name is returned in Filename *) (* - Returns False if no file Found. *) (* note: because the CPM call FIND NEXT can not be issued after *) (* an open or close operation, the find next must be done here *) (* for the the NEXTFILE function. We will use a link list of *) (* file names. *) (* ----------------------------------------------------------------- *) Function FirstFile(Myfile:Comstring; var Filename:Comstring): Boolean ; Var colon,Dot,asterisk,I,results : byte ; temp : string[20] ; Begin (* FirstFile Function *) Myfile := uppercase(Myfile) ; With FCB do Begin (* set up FCB *) Drive := 0 ; colon := pos(':',Myfile) ; if colon <> 0 then begin (* disk drive specified *) drive := Ord(myfile[1])-$40 ; delete(Myfile,1,colon); end ; (* disk drive specified *) dot := pos('.',Myfile); if dot=0 then dot := 8 ; temp := myfile ; delete(temp,dot,12); asterisk := pos('*',temp); if asterisk <> 0 then begin (* wild char *) temp[asterisk] := '?' ; while length(temp)< 8 do insert('?',temp,asterisk); end ; (* wild char *) temp := temp + ' ' ; for i := 1 to 8 do FName[i] := temp[i] ; temp := myfile ; delete(temp,1,dot); asterisk := pos('*',temp); if asterisk <> 0 then begin (* wild char *) temp[asterisk] := '?' ; while length(temp)< 3 do insert('?',temp,asterisk); end ; (* wild char *) temp := temp + ' ' ; for i := 1 to 3 do FType[i] := temp[i] ; End ; (* set up FCB *) I := Bdos(26,addr(DMA)) ; Results := Bdos(17,addr(FCB)) ; If Results < 4 then Begin (* found file *) filename[0] := chr(12) ; results := results * 32 ; for i := 1 to 8 do filename[i] := DMA[results+i] ; filename[9] := ' ' ; dot := pos(' ',filename) ; filename[dot] := '.' ; for i := 1 to 3 do filename[dot+i] := DMA[results+8+i] ; filename[0] := Chr(dot+3); FirstFile := true ; New(Marker); Mark(marker); Buildnextlist(FNhead); End (* Found file *) else FirstFile := false ; End; { FirstFile Function } (* ----------------------------------------------------------------- *) (* NextFile - Returns True if file found for file mask Myfile *) (* and the first file name is returned in Filename *) (* - Returns False if no file Found. *) (* ----------------------------------------------------------------- *) Function NextFile(Var Myfile, Filename : Comstring): Boolean ; Begin (* NextFile *) NextFile := Getnext(Filename) ; End ; (* NextFile *) (* ----------------------------------------------------------------- *) (* DisplayDiskStatus - Display the disk status for the default disk.*) (* *) (* ----------------------------------------------------------------- *) Procedure DisplayDiskStatus ; Type DPBrec = record SPT : integer ; (* sectors per track *) BSH : byte ; (* data alloc. block shift factor *) BLM : byte ; EXM : byte ; (* Blocks : integer ; *) (* total storage capacity *) Blocklo : byte ; BLockhi : byte ; DRM : integer ; (* number of directory entries *) AL0,AL1 : byte ; CKS : integer ; OFF : integer ; end ; DKspace = record diskspace : array[0..100] of byte ; end ; Var DPB : ^DPBrec ; DK : ^DKspace ; Diskspaceindex, Blocks : integer ; i,j,freeblock : integer ; DefDrive : byte ; Begin (* DisplayDiskStatus *) DefDrive := DefaultDrive ; (* save def drive *) i := BDos(13) ; (* reset drive to r/w *) SetDefaultDrive(DefDrive) ; (* restore def drive *) writeln(' '); Write('Disk Drive ',Chr(DefaultDrive+$41),': '); DPB := Ptr(BdosHL(31)) ; (* get disk parameters *) with DPB^ do Begin (* display disk data *) Blocks := (Blockhi*256 + Blocklo); Write (' Total User Space =',(Blocks+1)*(BLM+1) DIV 8,' Kbytes, '); End ; (* display disk data *) DK := Ptr(BdosHL(27)) ; (* get disk space vector *) freeblock := 0; with DK^ do for i := 0 to blocks do if (Diskspace[ (i div 8)] shl (i mod 8)) and $80 = 0 then freeblock := freeblock + 1 ; writeln (' Available Space =',freeblock*(DPB^.BLM+1) DIV 8,' Kbytes '); End; (* DisplayDiskStatus *) (* ----------------------------------------------------------------- *) (* EXECfile - Execute a file . *) (* *) (* ----------------------------------------------------------------- *) Procedure EXECfile( myfile: comstring); Begin (* EXECfile *) Writeln(' RUN function is not available in CP/M version '); End; (* EXECfile *) (* +FILE+ MODEMPRO.PASMS *) (* ================================================================= *) (* MODEM - Routines and Global variables for IBMPC compatiables *) (* ================================================================= *) CONST (* Modem Registers *) LowOrderDiv = 0 ; HiOrderDiv = 1 ; InterruptEnable = 1 ; InterruptIdReg = 2 ; LineControlReg = 3 ; ModemControlReg = 4 ; LineStatusReg = 5 ; ModemStatusReg = 6 ; ClockRate = 18430 ; (* CentiHertz. - use 17895 for PCjr *) (* 8259 Interrupt Controller addresses *) (* IC8259Reg1 = $20 ; IC8259Reg2 = $21 ; *) MaxBuffsize = 20000 ; DefaultBaud = 9600 ; VAR connected : boolean ; Modem : Integer ; EnableMask,ResetMask : byte ; IntVector, Saveoffset,SaveSeg : integer ; Buffer : Packed array [1..MaxBuffsize] of byte ; Iout,Iin : integer ; (* ------------------------------------------------------------------ *) (* IntHandler - Interrupt handler *) (* This procedure handles the modem interrupts , *) (* which occur for incomming data only. *) (* 1. Offset 16 into this procedure must be initialize *) (* with the correct value of the DS register before *) (* using this routine. *) (* 2. The routine is to start at offset 7, i.e. it *) (* bypasses the normal pascal entry code. *) (* (See InitModem Routine) *) (* *) (* ------------------------------------------------------------------ *) Procedure IntHandler ; (* Interrupt code starts at Inline code $50 *) (* which is offset 7 bytes from beginning of IntHandler *) Begin (* IntHandler *) (* Save Registers and set up the proper DS register *) Inline($50/$53/$51/$52/$57/$56/$06/$1E/ (* PUSH ax,bx,cx,dx,di,si,es,ds *) $B8/$00/$00/ (* MOV ax,immediatevalue *) $50/ (* PUSH ax *) $1F/ (* POP ds - set ds *) $FB) ; (* STI set interrupt enable *) If (Port[Modem+LineStatusReg] and $01) = $01 then begin (* put char in buffer *) buffer[Iin] := Port[Modem]; Iin := Iin + 1 ; if Iin = MaxBuffsize then Iin := 1 ; end ; (* put char in buffer *) Port[$20] := ResetMask ; (* Restore the registers and Return *) Inline ($1F/$07/$5E/$5F/$5A/$59/$5B/$58/ (* POP ds,es,si,di,dx,cx,bx,ax *) $CF); (* IRET *) End ; (* IntHandler *) (* ------------------------------------------------------------------ *) (* InitModem - Initialize the modem and setup interrupt procedure. *) (* The interrupt procedure is at IntHandler+7, and *) (* the DS register must be stored in IntHandler+16. *) (* *) (* ------------------------------------------------------------------ *) Procedure Initmodem ; Var rate : integer ; Begin (* Init modem *) If PrimaryPort then Begin (* Primary port *) Modem := $3F8 ; EnableMask := $EF ; ResetMask := $64 ; (* end of interrupt for IRQ4 *) IntVector := $0030 ; End (* Primary Port *) else Begin (* Secondary Port *) Modem := $2F8 ; EnableMask := $F7 ; ResetMask := $63 ; (* end of interrupt for IRQ3 *) IntVector := $002C ; End ; (* Secondary Port *) Iin := 1 ; Iout := 1 ; (* Initialize the Interrupt Procedure *) Saveoffset := MemW[$0000:IntVector] ; (* save the Old interrupt *) SaveSeg := MemW[$0000:IntVector+2] ; (* address of serial interrupt *) MemW[$0000:IntVector] := Ofs(IntHandler) + 7 ; (* Use our own interrupt *) MemW[$0000:IntVector+2] := Cseg ; (* hanlder *) MemW[Cseg:Ofs(IntHandler)+16] := Dseg ; (* set in for handler *) Port[$21] := Port[$21] and EnableMask ; (* Enable serial port interrupt *) Port[$20] := ResetMask ; (* Initialize baud rates and bits and parity *) Rate := round( (Clockrate/16) / (Baudrate/100)) ; Port[Modem+LineControlReg] := $80 ; (* Enable baud rate setting *) Port[Modem+LowOrderDiv] := (rate and $00FF) ; Port[Modem+HiOrderDiv] := rate div $100 ; Port[Modem+LineControlReg] := (ord(Parity) shl 4) OR $0A ; (* parity, 7 bits,1 stop *) Port[Modem+ModemControlReg] := $0B ; (* DTR and RTS *) Port[Modem+InterruptEnable] := $01 ; (* Data Avail. Interrupt set *) End ; (* Init modem *) (* ------------------------------------------------------------------ *) (* ResetModem - Reset the Interrupt back to the original. *) (* Global variables - Saveoffset,SaveSeq *) (* ------------------------------------------------------------------ *) Procedure ResetModem; Begin (* Reset Modem Interrupt *) MemW[$0000:IntVector] := Saveoffset ; (* restore the Old interrupt *) MemW[$0000:IntVector+2] := SaveSeg ; (* address of serial interrupt *) End; (* Reset Modem Interrupt *) (* ------------------------------------------------------------------ *) (* SetModem - Set the baud rate and parity for modem. *) (* Global variables - Modem,Clockrate,Baudrate,Parity *) (* ------------------------------------------------------------------ *) Procedure SetModem ; Var rate : integer ; Begin (* SetModem *) If PrimaryPort then Begin (* Primary port *) Modem := $3F8 ; EnableMask := $EF ; ResetMask := $64 ; (* end of interrupt for IRQ4 *) End (* Primary Port *) else Begin (* Secondary Port *) Modem := $2F8 ; EnableMask := $F7 ; ResetMask := $63 ; (* end of interrupt for IRQ3 *) End ; (* Secondary Port *) Rate := round( (Clockrate/16) / (Baudrate/100)) ; Port[Modem+LineControlReg] := $80 ; (* Enable baud rate setting *) Port[Modem+LowOrderDiv] := (rate and $00FF) ; Port[Modem+HiOrderDiv] := rate div $100 ; Port[Modem+LineControlReg] := (ord(Parity) shl 4) OR $0A ; (* parity, 7 bits,1 stop *) End ; (* SetModem *) (* ------------------------------------------------------------------ *) (* DialModem - Check and waits for modem to be connected. *) (* It waits for DTR and CTS signals to be detected. *) (* Side Effect - global variable 'connected' is set true. *) (* ------------------------------------------------------------------ *) Procedure DialModem ; var abyte,bbyte : byte ; Begin (* Dial Modem *) While ((Port[Modem+ModemStatusReg] and $30) <> $30) and DTRcheck Do Begin (* Connect modem please *) If audioFlag then Begin Sound(600);delay(100);Sound(2000);delay(200); nosound;end; writeln(' Please connect your modem '); delay (1000); DTRcheck := not (keychar(abyte,bbyte) and (abyte=$20)) ; End ; (* Connect modem please *) connected := true ; If audioflag then for i:=1 to 50 do begin sound(100*i);delay(5);end; nosound; Writeln(' Connection completed '); End ; (* Dial Modem *) (* ------------------------------------------------------------------ *) (* RecvChar - Receive a Character from the modem port. *) (* TRUE - if there is a character from the modem and *) (* the character is returned in the parmeter. *) (* FALSE - if no character found . *) (* *) (* ------------------------------------------------------------------ *) Function RecvChar (var mchar : byte) : boolean ; Begin (* RecvChar *) if Iin <> Iout then begin (* get char from buffer *) mchar := buffer[Iout] and $7F ; Iout := Iout + 1 ; If Iout = MaxBuffsize then Iout := 1 ; RecvChar := true ; if logging then Begin {$I-} write(Logfile,chr(mchar)); If IOresult <> 0 then Begin (* IO error *) Writeln(' Disk is Full - logging teminated'); logging := false ; Close(Logfile); End ; (* IO error *) End ; {$I+} end (* get char from buffer *) else RecvChar := false ; End ; (* RecvChar *) (* ------------------------------------------------------------------ *) (* SendChar - Send a character thru the modem port. *) (* It waits for the previous character to be sent before *) (* sending the current character. *) (* ------------------------------------------------------------------ *) Procedure SendChar(char : byte ) ; Begin (* Send Char *) While (Port[Modem+LineStatusReg] and $20) <> $20 do delay(1); Port[modem] := char ; End ; (* Send Char *) (* ------------------------------------------------------------------ *) (* SendBreak- Send a break via the modem port . *) (* ------------------------------------------------------------------ *) Procedure SendBreak ; Var Tbyte : byte ; Begin (* Send Break *) Tbyte := Port[Modem+LineControlReg] ; (* save setting *) Port[Modem+LineControlReg] := $40 ; (* break for 200 millsec *) Writeln(' *** BREAK *** '); Delay(200) ; Port[Modem+LineControlReg] := Tbyte ; (* restore setting *) End ; (* Send Break *) (* ================================================================= *) (* End of MODEM routines for IBMPC compatiables. *) (* ================================================================= *) (* +FILE+ MODEMPRO.PASAPPLE *) (* ================================================================= *) (* MODEM - Routines and Global variables for Apple II - PDA232. *) (* ================================================================= *) CONST (* Modem Registers - Port assignment *) Modem = $E0A8 ; LowOrderDiv = 0 ; HiOrderDiv = 1 ; InterruptEnable = 1 ; InterruptIdReg = 2 ; LineControlReg = 3 ; ModemControlReg = 4 ; LineStatusReg = 5 ; ModemStatusReg = 6 ; ClockRate = 18430 ; (* CentiHertz. - use 17895 for PCjr *) VAR connected : boolean ; (* ------------------------------------------------------------------ *) (* InitModem - Initialize the modem. *) (* *) (* ------------------------------------------------------------------ *) Procedure Initmodem ; Var Rate : integer ; Begin (* Init modem *) (* Initialize baud rates and bits and parity *) Rate := round( (Clockrate/16) / (Baudrate/100)) ; Mem[Modem+LineControlReg] := $80 ; (* Enable baud rate setting *) Mem[Modem+LowOrderDiv] := (rate and $00FF) ; Mem[Modem+HiOrderDiv] := rate div $100 ; Mem[Modem+LineControlReg] := (ord(Parity) shl 4) OR $0A ; (* parity, 7 bits,1 stop *) Mem[Modem+ModemControlReg] := $0B ; (* DTR and RTS *) Mem[Modem+InterruptEnable] := $00 ; (* No Interrupt set *) End ; (* Init modem *) (* ------------------------------------------------------------------ *) (* ResetModem - Reset the Interrupt back to the original. *) (* *) (* ------------------------------------------------------------------ *) Procedure ResetModem; Begin (* Reset Modem Interrupt *) End; (* Reset Modem Interrupt *) (* ------------------------------------------------------------------ *) (* SetModem - Set the baud rate and parity for modem. *) (* Global variables - Modem,Clockrate,Baudrate,Parity *) (* ------------------------------------------------------------------ *) Procedure SetModem ; Var rate : Integer ; Begin (* SetModem *) Rate := round( (Clockrate/16) / (Baudrate/100)) ; Mem[Modem+LineControlReg] := $80 ; (* Enable baud rate setting *) Mem[Modem+LowOrderDiv] := (rate and $00FF) ; Mem[Modem+HiOrderDiv] := rate div $100 ; Mem[Modem+LineControlReg] := (ord(Parity) shl 4) OR $0A ; (* parity, 7 bits,1 stop *) End ; (* SetModem *) (* ------------------------------------------------------------------ *) (* DialModem - Check and waits for modem to be connected. *) (* It waits for DTR and CTS signals to be detected. *) (* Side Effect - global variable 'connected' is set true. *) (* ------------------------------------------------------------------ *) Procedure DialModem ; Var abyte,bbyte : byte ; Begin (* Dial Modem *) While ((Mem[Modem+ModemStatusReg] and $30) <> $30) and DTRcheck Do Begin (* Connect modem please *) (* Sound(600);delay(100);Sound(2000);delay(200); nosound;*) writeln(' Please connect your modem '); delay (1000); DTRcheck := Not (keychar(abyte,bbyte) and (abyte = $20)) ; End ; (* Connect modem please *) connected := true ; (* for i:=1 to 100 do begin sound(100*i);delay(10);end; nosound; *) Writeln(' Connection completed '); End ; (* Dial Modem *) (* ------------------------------------------------------------------ *) (* RecvChar - Receive a Character from the modem port. *) (* TRUE - if there is a character from the modem and *) (* the character is returned in the parmeter. *) (* FALSE - if no character found . *) (* *) (* ------------------------------------------------------------------ *) Function RecvChar (var mchar : byte) : boolean ; Begin (* RecvChar *) If (Mem[Modem+LineStatusReg] and $01) = $01 then begin (* get char from buffer *) mchar := Mem[Modem] and $7F ; RecvChar := true ; if logging then Begin {$I-} write(Logfile,chr(mchar)); If IOresult <> 0 then Begin (* IO error *) Writeln(' Disk is Full - logging teminated'); logging := false ; Close(Logfile); End ; (* IO error *) End ; {$I+} end (* get char from buffer *) else RecvChar := false ; End ; (* RecvChar *) (* ------------------------------------------------------------------ *) (* SendChar - Send a character thru the modem port. *) (* It waits for the previous character to be sent before *) (* sending the current character. *) (* ------------------------------------------------------------------ *) Procedure SendChar(char : byte ) ; Begin (* Send Char *) While (Mem[Modem+LineStatusReg] and $20) <> $20 do delay(1); Mem[Modem] := char ; End ; (* Send Char *) (* ------------------------------------------------------------------ *) (* SendBreak- Send a break via the modem port . *) (* ------------------------------------------------------------------ *) Procedure SendBreak ; Var Tbyte : byte ; Begin (* Send Break *) Tbyte := Mem[Modem+LineControlReg] ; (* save setting *) Mem[Modem+LineControlReg] := $40 ; (* break for 200 millsec *) Writeln(' *** BREAK *** '); Delay(200) ; Mem[Modem+LineControlReg] := Tbyte ; (* restore setting *) End ; (* Send Break *) (* ================================================================= *) (* End of MODEM routines for Apple II computers with PDA232. *) (* ================================================================= *) (* +FILE+ MODEMPRO.PASKAYII *) (* ================================================================= *) (* MODEM - Routines and Global variables for Kaypro II. *) (* ================================================================= *) CONST (* Modem Registers - Port assignment *) BaudrateReg = $00 ; ModemData = $04 ; ModemStatus = $06 ; Ptable : array [0..3] of byte = (1,3,2,0) ; (* Flag in the Modem status register *) RxChar = $01 ; (* received char in modem data reg *) TxChar = $04 ; (* transmit buffer empty *) CTS = $20 ; (* Clear to Send signal *) DCD = $08 ; (* Data Carrier Detect *) VAR connected : boolean ; (* ------------------------------------------------------------------ *) (* InitModem - Initialize the modem. *) (* *) (* ------------------------------------------------------------------ *) Procedure Initmodem ; Var rate : string[5] ; Begin (* Init modem *) Port[ModemStatus] := $03 ; (* Select Write Reg 3 - Receive Option *) Port[ModemStatus] := $81 ; (* 7 databit(80), Rx Enable(01) *) Port[ModemStatus] := $04 ; (* Select Write Reg 4 - Modem Options *) Port[ModemStatus] := $44 + (* x16clock(40),1 stopbit(04) *) PTable[Ord(Parity)]; (* Parity *) Port[ModemStatus] := $05 ; (* Select Write Reg 5 - Xmit Options *) Port[ModemStatus] := $AA ; (* DTR(80),7-bits(20),Tx Enable(08) *) (* RTS(20) *) Str(Baudrate,rate); Port[BaudRateReg] := Pos(rate,' 50 75 110 135 150 300 600' + ' 1200 1800 2000 2400 3600 4800 7200 9600 19200') div 5 ; End ; (* Init modem *) (* ------------------------------------------------------------------ *) (* ResetModem - Reset the Interrupt back to the original. *) (* *) (* ------------------------------------------------------------------ *) Procedure ResetModem; Begin (* Reset Modem Interrupt *) End; (* Reset Modem Interrupt *) (* ------------------------------------------------------------------ *) (* SetModem - Set the baud rate and parity for modem. *) (* Global variables - Modem,Clockrate,Baudrate,Parity *) (* ------------------------------------------------------------------ *) Procedure SetModem ; Var rate : string[5] ; Begin (* SetModem *) Port[ModemStatus] := $04 ; (* Select Write Reg 4 - Modem Options *) Port[ModemStatus] := $44 + (* x16clock(40),1 stopbit(04) *) PTable[Ord(Parity)]; (* Parity *) Str(Baudrate,rate); Port[BaudRateReg] := Pos(rate,' 50 75 110 135 150 300 600' + ' 1200 1800 2000 2400 3600 4800 7200 9600 19200') div 5 ; End ; (* SetModem *) (* ------------------------------------------------------------------ *) (* DialModem - Check and waits for modem to be connected. *) (* It waits for DTR and CTS signals to be detected. *) (* Side Effect - global variable 'connected' is set true. *) (* ------------------------------------------------------------------ *) Procedure DialModem ; Var abyte,bbyte : byte ; Begin (* Dial Modem *) While ((Port[ModemStatus] and DCD) <> DCD) and DTRcheck Do Begin (* Connect modem please *) writeln(' Please connect your modem. Status= ',Port[ModemStatus]); delay (1000); DTRcheck := Not (keychar(abyte,bbyte) and (abyte=$20)) ; End ; (* Connect modem please *) connected := true ; (* Writeln(' Assume Connection completed '); *) End ; (* Dial Modem *) (* ------------------------------------------------------------------ *) (* RecvChar - Receive a Character from the modem port. *) (* TRUE - if there is a character from the modem and *) (* the character is returned in the parmeter. *) (* FALSE - if no character found . *) (* *) (* ------------------------------------------------------------------ *) Function RecvChar (var mchar : byte) : boolean ; Begin (* RecvChar *) if (Port[ModemStatus] and RxChar) = RxChar then begin (* get char from buffer *) mchar := Port[ModemData] and $7F ; RecvChar := true ; if logging then write(Logfile,chr(mchar)); end (* get char from buffer *) else RecvChar := false ; End ; (* RecvChar *) (* ------------------------------------------------------------------ *) (* SendChar - Send a character thru the modem port. *) (* It waits for the previous character to be sent before *) (* sending the current character. *) (* ------------------------------------------------------------------ *) Procedure SendChar(char : byte ) ; Begin (* Send Char *) While (Port[ModemStatus] and TxChar) <> TxChar do delay(1); Port[ModemData] := char ; End ; (* Send Char *) (* ------------------------------------------------------------------ *) (* SendBreak- Send a break via the modem port . *) (* ------------------------------------------------------------------ *) Procedure SendBreak ; Var Tbyte : byte ; Begin (* Send Break *) Port[ModemStatus] := $05 ; (* Select Write Reg 5 - Xmit Options *) Port[ModemStatus] := $10 ; (* Send BREAK *) Writeln(' *** BREAK *** '); Delay(200) ; Port[ModemStatus] := $05 ; (* Select Write Reg 5 - Xmit Options *) Port[ModemStatus] := $AA ; (* DTR(80),7-bits(20),Tx Enable(08) *) (* RTS(20) *) End ; (* Send Break *) (* ================================================================= *) (* End of MODEM routines for Kaypro II computers *) (* ================================================================= *) (* +FILE+ DEFWORDS.PASMSCPM *) (* Global DefWord variables *) Var DefFile : text ; NewDefs : boolean ; DefList : DefPointer ; (* ================================================================== *) (* AssignDefWord - Assigns the Defined Word into the DefList. *) (* This is a recursive procedure. *) (* Side Affects : The boolean variable NewDefs is set true *) (* ================================================================== *) Procedure AssignDefWord (var PT : DefPointer; DWord:Wstring ; Dstring: comstring); Var TempPt : DefPointer ; Begin (* AssignDefWord Procedure *) NewDefs := true ; TempPt := PT; If PT <> nil then With PT^ do If DefWord = Dword then (* Found existing Word *) If length(Dstring) > 0 then DefString := Dstring else Begin (* Drop DefWord *) PT := Link ; (* Drop entry *) Dispose(tempPT); End (* Drop DefWord *) else (* Look down the list *) AssignDefWord(Link,DWord,Dstring) else If length(Dstring) > 0 then Begin (* Add new entry *) New(PT); With PT^ do Begin (* Add DefWord to list *) Link := Nil ; DefWord := DWord ; DefString := Dstring ; End; End ; (* Add new entry *) End ; (* AssignDefWord Procedure *) (* ================================================================== *) (* DisplayDefWords - display the Defined Words in the DefList. *) (* This is a recursive procedure. *) (* *) (* ================================================================== *) Procedure DisplayDefWords (PT : DefPointer); Begin (* DisplayDefWords Procedure *) If PT <> nil then With PT^ do Begin (* Display Word and definition *) Writeln(DefWord,' := ',DefString); DisplayDefWords(Link); End ; End ; (* DisplayDefWords Procedure *) (* ================================================================== *) (* CheckDefWords - Checks for Defined Words in the DefList. *) (* If it is found it concationates the DefString *) (* to the Instring and reset the first token *) (* This is a recursive procedure. *) (* *) (* ================================================================== *) Procedure CheckDefWords (PT : DefPointer; var Dword : Wstring ; var Instring: comstring); Begin (* CheckDefWords Procedure *) If PT <> nil then With PT^ do If Dword = DefWord then Begin (* Update string *) Instring := DefString + ' ' + Instring ; Dword := uppercase(GetToken(Instring)); End else CheckDefWords(Link,Dword,Instring) End ; (* CheckDefWords Procedure *) (* ================================================================== *) (* WriteDefWord - writes the Defined Words in the DefList to the *) (* DefFile. *) (* *) (* ================================================================== *) Procedure WriteDefWord (PT : DefPointer); Begin (* WriteDefWord Procedure *) If PT <> nil then With PT^ do Begin (* Write word and definition *) Writeln(DefFile,DefWord,' ',DefString); WriteDefWord(Link); End ; End ; (* WriteDefWord Procedure *) (* ================================================================== *) (* DEFINEWORD - This procedure processes the DEFINE command. *) (* It searches the DefList for the WORD specified *) (* If it is found it replaces the definition string *) (* with the new definition. Otherwise it creates an *) (* new entry in the DefList. *) (* ================================================================== *) Procedure DEFINEWORD (Var Instring: comstring); Var DWord : string[10] ; Begin (* DefineWord Procedure *) If length(Instring) < 1 then If DefList = Nil then Writeln(' No Defined Words ') else DisplayDefWords (DefList) else Begin (* Assign Defined Word *) DWord := Uppercase(GetToken(Instring)); While (instring[1] = ' ') and (length(instring)>0) do Delete(instring,1,1); (* eliminate leading blanks *) AssignDefWord(DefList,DWord,Instring); Instring := ''; End ; (* Assign Define Word *) End; (* DefineWord Procedure *) (* ================================================================== *) (* LoadDefWords - Loads the Defined Words into the DefList from *) (* the file KERMIT.DEF. *) (* *) (* ================================================================== *) Procedure LoadDefWords ; Var Instring,dummy : comstring ; Begin (* LoadDefWord Procedure *) If FirstFile('KERMIT.DEF',DUMMY) then Begin (* Read file *) Assign(DefFile,'KERMIT.DEF'); Reset(DefFile); While not Eof(DefFile) do Begin (* load DefList *) Readln(DefFile,Instring); DefineWord(Instring); End ; (* load DefList *) End ; (* Read file *) End ; (* LoadDefWord Procedure *) (* ================================================================== *) (* SaveDefWords - Saves the Defined Words from the DefList into *) (* the file KERMIT.DEF. *) (* *) (* ================================================================== *) Procedure SaveDefWords ; Var Instring : comstring ; Begin (* SaveDefWord Procedure *) Writeln('Saving DEFINE words in file KERMIT.DEF'); Assign(DefFile,'KERMIT.DEF'); Rewrite(DefFile); WriteDefWord(DefList); Close(DefFile); End ; (* SaveDefWord Procedure *) (* +FILE+ READCHAR.PASMSCPM *) (* ------------------------------------------------------------------ *) (* ReadChar - Read a character from the modem. *) (* Waits for a character to appear on the modem. *) (* It returns TRUE when the character is received and *) (* the value of the char is return in the parameter. *) (* It returns FALSE if the keyboard char is detected before *) (* a character is received or it times out. *) (* Side Effects : if the keys ^Z ^X ^C or ^E are pressed then *) (* BREAKSTATE is set to BZ, BX, BC, or BE respectively. *) (* Note : The ticker value may need to change if code is added to *) (* to this procedure or RecvChar or KeyChar. It is also *) (* machine dependent. *) (* ------------------------------------------------------------------ *) Function ReadChar(var char : byte): boolean; var waiting : boolean ; dummy : byte ; Ticker,Timer : integer ; Begin (* Read Char *) waiting := true ; timer := 0 ; ticker := 0 ; While waiting Do Begin (* Wait for a Character *) If RecvChar(char) then Begin (* got char *) ReadChar := true ; waiting := false ; End (* got char *) else If KeyChar(char,dummy) then Begin (* key char *) ReadChar := false ; waiting := false ; if char = $03 then BREAKSTATE := BC ; if char = $05 then BREAKSTATE := BE ; if char = $18 then BREAKSTATE := BX ; if char = $1A then BREAKSTATE := BZ ; End (* key char *) else Begin (* Check for timeout *) if Timer < Timeout then (* increment timer *) If ticker = 1072 then Begin ticker := 0 ; Timer := Timer + 1; end else ticker := ticker + 1 else (* times up *) Begin Waiting := false; ReadChar := False; End; End; (* Check for timeout *) End ; (* Wait for a Character *) End; (* Read Char *) (* +FILE+ PACKET.PASMSCPM *) (* =============================================================== *) (* SENDPACKET -This procedure sends the SendData packet . *) (* 1. The COUNT sent includes SEQ,PACKETTYPE,and CHECKSUM *) (* i.e. it is 3 larger than the OutCount or *) (* if CheckType = 2 or 3 then COUNT is 4 or 5 larger. *) (* 2. The COUNT and SEQ and CHECKSUM values are offset by *) (* 32 decimal (20hex) to make it a printable ASCII char.*) (* 3. The CHECKSUM are calculated on the ASCII value of *) (* the printable characters. *) (* *) (* Assumptions: *) (* The following Global variables must be correctly set *) (* before calling this procedure . *) (* 1. OutDataCount - an integer-byte count of data characters.*) (* 2. OUTSEQ - an integer-byte count of sequence number. *) (* 3. OUTPACKETTYPE - an character of type . *) (* 4. SendData - a character array of data to be sent. *) (* =============================================================== *) PROCEDURE SENDPACKET ; VAR I,SUM,Checkbytes : INTEGER ; achar : byte ; SOHecho : boolean ; BEGIN (* SENDPACKET procedure *) (* SOHecho := Not (LocalEcho or (Series1 and WaitXon)) ; *) SOHecho := Not (LocalEcho or Series1) ; achar := 0 ; If WaitXon then While achar <> XON do if Readchar(achar) then else achar := xon ; WaitXon := XonXoff ; While RecvChar(achar) do ; (* throw away all previous incoming data *) Delay(50); SUM := 0 ; CRC := 0 ; Checkbytes := 1 ; If (OutPacketType = ord('S')) or (OutPacketType = ord('I')) or (InpacketType = ord('S')) or (InpacketType = ord('I')) or (InpacketType = ord('R')) then (* leave Checkbytes := 1 *) else If Checktype = ord('2') then Checkbytes := 2 else If Checktype = ord('3') then Checkbytes := 3 ; SendChar(StartChar) ; (* SOH *) If SOHecho then (* wait for SOH to be echoed back *) While achar <> StartChar do if Not Readchar(achar) then achar:=StartChar ; OutCount := OutDataCount + 2 + Checkbytes ; SendChar(OutCount + $20) ; (* COUNT *) SUM := SUM + OutCount + $20 ; CRCheck(OutCount+$20) ; SendChar(OUTSEQ+$20) ; (* SEQ *) SUM := SUM + OUTSEQ + $20; CRCheck(OUTSEQ+$20); SendChar(OUTPACKETTYPE) ; (* TYPE *) SUM := SUM + ORD(OUTPACKETTYPE) ; CRCheck(Ord(OutpacketType)); IF OutDataCount > 0 THEN FOR I := 1 TO OutDataCount DO BEGIN (* Send Data *) SendChar(SendData[I]) ; (* DATA *) SUM := SUM + SendData[I] ; CRCheck(SendData[I]); END ; (* Send Data *) If Checkbytes = 1 then Begin (* one Checksum *) CHECKSUM := (SUM + (SUM AND $C0) DIV $40 ) AND $3F ; SendChar(CHECKSUM+$20); (* CHECKSUM *) End (* one Checksum *) else If Checkbytes = 2 then Begin (* two Checksum *) Checksum := (Sum div $40) and $3F ; (* Bit 11 - 6 *) SendChar(Checksum+$20) ; Checksum := Sum and $3F ; (* Bit 5 - 0 *) SendChar(Checksum+$20) ; End (* two Checksum *) else If Checkbytes = 3 then Begin (* CRC *) SendChar((CRC shr 12 ) and $0F + $20) ; SendChar((CRC shr 6 ) and $3F + $20) ; SendChar((CRC ) and $3F + $20) ; End ; (* CRC *) SendChar(EndChar); (* Cr *) If NumPad > 0 then For I := 1 to NumPad do SendChar(PadChar); (* Padding *) END ; (* SENDPACKET procedure *) (* =============================================================== *) (* RECVPACKET -This Function returns TRUE if it successfully *) (* recieved a packet and FALSE if it had an error. *) (* Side Effects: *) (* The following global variables will be set. *) (* 1. InDataCount - an integer value of the msg char count. *) (* 2. INSEQ - an integer value of the sequence count. *) (* 3. TYPE - a character of message type (Y,N,D,F,etc) *) (* 4. RecvData - an array of data bytes to be sent. *) (* *) (* =============================================================== *) FUNCTION RECVPACKET : BOOLEAN ; VAR I,SUM,RESENDS : INTEGER ; INCHAR,Checkbytes : Byte ; dummy : Boolean ; LABEL EXIT ; BEGIN (* RECVPACKET procedure *) RECVPACKET := false ; (* assume false until proven otherwise *) If GotSOH then begin Inchar := StartChar; GotSOH := false; end else Inchar := $20 ; While Inchar <> StartChar Do If Readchar(Inchar) then (* SOH *) else goto exit ; SUM := 0 ; CRC := 0 ; If not ReadChar (InCount) then goto exit ; (* COUNT *) SUM := SUM + InCount ; CRCheck(InCount) ; InCount := InCount - $20 ; (* To absolute value *) if not ReadChar (INSEQ) then goto exit ; (* SEQ *) SUM := SUM + INSEQ ; CRCheck(INSEQ) ; INSEQ := INSEQ - $20 ; If not ReadChar (INPACKETTYPE ) then goto exit ; (* TYPE *) SUM := SUM + INPACKETTYPE ; CRCheck(InPacketType); Checkbytes := 1 ; If (OutPacketType = ord('S')) or (InpacketType = ord('S')) or (InpacketType = ord('R')) then (* leave Checkbytes := 1 *) else If Checktype = ord('2') then Checkbytes := 2 else If Checktype = ord('3') then Checkbytes := 3 ; InDataCount := InCount - 2 - Checkbytes ; IF InDataCount > 0 THEN FOR I := 1 TO InDataCount DO BEGIN (* Recv Data *) If ReadChar (RecvData[I]) then (* DATA *) Begin (* checksum and CRC *) SUM := SUM + RecvData[I] ; CRCheck(RecvData[I]); End (* checksum and CRC *) else goto exit ; END ; (* Revc Data *) RECVPACKET := True ; (* Assume Ok until check fails *) If Checkbytes = 1 then Begin (* one char Checksum *) CHECKSUM := (SUM + (SUM AND $C0) DIV $40 ) AND $3F ; If ReadChar (INCHAR) then IF INCHAR <> CHECKSUM+$20 THEN RECVPACKET := FALSE ; End (* one char Checksum *) else If Checkbytes = 2 then Begin (* two char Checksum *) Checksum := (Sum div $40) and $3F ; If ReadChar(Inchar) then If Inchar <> Checksum+$20 then RECVPACKET := false ; Checksum := Sum and $3F ; If ReadChar(Inchar) then If Inchar <> Checksum+$20 then RECVPACKET := false ; End (* two char Checksum *) else If Checkbytes = 3 then Begin (* CRC char Checksum *) Checksum := (CRC shr 12) and $0F ; If ReadChar(Inchar) then (* If Inchar <> Checksum+$20 then Writeln('CRC1 ',Inchar,' ',checksum+$20); *) If Inchar <> Checksum+$20 then RECVPACKET := false ; Checksum := (CRC shr 6 ) and $3F ; If ReadChar(Inchar) then (* If Inchar <> Checksum+$20 then Writeln('CRC2 ',Inchar,' ',checksum+$20); *) If Inchar <> Checksum+$20 then RECVPACKET := false ; Checksum := (CRC ) and $3F ; If ReadChar(Inchar) then (* If Inchar <> Checksum+$20 then Writeln('CRC3 ',Inchar,' ',checksum+$20); *) If Inchar <> Checksum+$20 then RECVPACKET := false ; End; (* CRC char Checksum *) Exit: END ; (* RECVPACKET procedure *) (* =============================================================== *) (* RESENDIT - This procedure RESENDS the packet if it gets a nak *) (* It calls itself recursively upto the number of times *) (* specified in the intial parameter list. *) (* Side Effects - If it fails then the STATE in the message is set *) (* to 'A' which means ABORT . *) (* - Global variable RetryCount is incremented *) (* =============================================================== *) PROCEDURE RESENDIT ( RETRIES : INTEGER ) ; BEGIN (* RESENDIT procedure *) RetryCount := RetryCount + 1 ; IF RETRIES > 0 THEN BEGIN (* Try again *) SENDPACKET ; IF RECVPACKET THEN IF INPACKETTYPE = ord('Y') THEN ELSE IF INPACKETTYPE = ord('N') THEN RESENDIT(RETRIES-1) ELSE STATE := A ELSE STATE := A ; END (* Try again *) ELSE STATE := A ; (* Retries failed - ABORT *) END ; (* RESENDIT procedure *) (* ------------------------------------------------------------ *) (* SendPacketType - Procedure will send a packet of the *) (* type specified in the Character parameter. *) (* i.e. SendPacketType('Y') an ACK packet *) (* SendPacketType('N') an NAK packet *) (* ------------------------------------------------------------ *) PROCEDURE SendPacketType (PacketType : char); BEGIN (* SEND ACK or NAK or B or Z *) OutDataCount := 0 ; IF PacketType <> 'N' THEN OUTSEQ := OUTSEQ + 1 ; IF OUTSEQ >= 64 THEN OUTSEQ := 0; OUTPACKETTYPE := Ord(PacketType) ; SENDPACKET ; END ; (* SEND ACK or NAK or B or Z *) (* ------------------------------------------------------------ *) PROCEDURE PutInitPacket ; Begin (* Put Parameters into Init Packet *) OutDataCount := 9 ; OUTSEQ := 0 ; (* The values are tranformed by adding hex 20 to *) (* the true value, making the value a printable char *) SendData[1] := PacketSize+ $20 ; (* Buffsize *) SendData[2] := Timeout + $20 ; (* Time out sec *) SendData[3] := NumPad + $20 ; (* Num padchars *) SendData[4] := PadChar + $20 ; (* Pad char *) SendData[5] := EndChar + $20 ; (* EOL char *) SendData[6] := CntrlQuote ; (* Quote character *) SendData[7] := Bit8Quote ; (* Quote character *) SendData[8] := CheckType ; (* Check Type *) SendData[9] := RepChar ; (* Repeat Character *) IF Bit8Quote = $00 then OutDataCount := 6 (* Don't send bit8_quote *) else If CheckType = $00 then OutDataCount := 7 else If RepChar = $00 then OutDataCount := 8 ; End ; (* Put Parameters into Init Packet *) (* ------------------------------------------------------------ *) PROCEDURE GetInitPacket ; Begin (* Get init parameters *) IF InDataCount >= 1 then PacketSize := RecvData[1]-$20 ; IF InDataCount >= 2 then TimeOut := RecvData[2]-$20 ; IF InDataCount >= 3 then NumPad := RecvData[3]-$20 ; IF InDataCount >= 4 then PadChar := RecvData[4]-$20 ; IF InDataCount >= 5 then EndChar := RecvData[5]-$20 ; IF InDataCount >= 6 then CntrlQuote := RecvData[6] ; IF InDataCount >= 7 then Begin (* Validate bit8Quote *) Bit8Quote := RecvData[7] ; If RecvData[7] = ord('Y') then Bit8Quote := ord('&') ; If Not (chr(Bit8Quote) in ['!'..'?','`'..'~']) then Bit8Quote := 0 ; End (* Validate bit8Quote *) else Bit8Quote := $00 ; IF (InDataCount >= 8) and (chr(RecvData[8]) in ['1','2','3'] ) then CheckType := RecvData[8] else CheckType := ord('1') ; IF InDataCount >= 9 then If chr(RecvData[9]) in ['!'..'?','`'..'~'] then RepChar := RecvData[9] else RepChar := $00 else RepChar := $00 ; End ; (* Get init parameters *) (* ------------------------------------------------------------ *) (* +FILE+ SENDFILE.PASMS *) (* **************************************************************** *) (* SENDFILE - This routine handles the sending of a file from * *) (* the micro computer. * *) (* * *) (* **************************************************************** *) PROCEDURE SENDFILE (var InParms : ComString); VAR MyFiles,FileName,AsFileNames,AsFileName,Atoken : Comstring ; SENDING, GETREPLY, LastFile, rawfile : Boolean ; abyte, Kchar,Kbchar : byte ; ErrorMsg : String[80]; PacketCount,i,ix : Integer ; FILETOSEND : File of byte ; Label Subdir,GetAsName,GetNextFile,Exit ; (* --------------------------------------------------- *) (* SENDRAW - This routine send the file in unpacket *) (* mode, Simply read and send. *) (* --------------------------------------------------- *) Procedure SENDRAW ; Begin (* SendRaw Procedure *) Sending := true ; While Sending Do Begin (* Send a file *) ClrScr; Writeln(' Sending File >>>>>>> ',Filename,' <<<<<<< '); Assign(FileToSend,Prefixof(Myfiles)+FileName); RESET(FileToSend); While not EOF(FileToSend) do Begin (* Send data *) Read(FileToSend,abyte); SendChar(abyte); If LocalEcho then Write(chr(abyte)) else If Readchar(abyte) then Write(chr(abyte)); If XonXoff and (abyte = $0D) then (* wait for Xon *) While abyte<>XON do If Readchar(abyte) then else abyte := xon ; End ; (* Send data *) CLOSE(FileToSend); Sending := Nextfile(Myfiles,Filename); End ; (* Send a file *) Writeln(' '); End ; (* SendRaw Procedure *) (* **************************************************************** *) BEGIN (* SENDFILE procedure *) rawfile := false ; RetryCount := 0 ; (* Check the file to be sent here *) If length(InParms) < 1 then Begin (* Get name of file to send *) Write (' Enter name of file to be sent >'); Readln(InParms); End; MyFiles := ' '; MyFiles := UpperCase(GetToken(InParms)); AsFileNames := MyFiles ; Atoken := UpperCase(GetToken(InParms)); If Atoken = 'AS' then If length(InParms)<1 then AsFileNames := MyFiles else AsFileNames := UpperCase(GetToken(InParms)) else If Atoken = 'RAW' then rawfile := true else InParms := Atoken + InParms ; subdir: ix := Pos('\',AsFilenames) ; If ix > 1 then delete(AsFilenames,1,ix) ; (* Eliminate sub-dir prefixs *) if ix > 1 then goto subdir ; If FirstFile(Myfiles,Filename) then else begin (* No file found *) Writeln (' File "',MyFiles,'" not found.'); Goto Exit ; end ; (* No file found *) AsFilename := 'Blank' ; If rawfile then begin SendRaw ; goto exit ; end ; GetAsName: writeln('Filename is =',Filename); If NewAsFile(Myfiles,Filename,AsFileNames,AsFileName) then else If NextFile(Myfiles,Filename) then goto GetAsName else begin (* No file found *) Writeln (' File "',MyFiles,'" not found on disk.'); Goto Exit ; end ; (* No file found *) STATE := S ; BreakState := NoBreak ; GETREPLY := FALSE ; LastFile := false ; SENDING := TRUE ; ClrScr; GotoXY(10,4); Write(' Number of Packets Sent = '); GotoXY(10,5); Write(' Number of Retries = '); PacketCount := 0 ; WHILE SENDING DO BEGIN (* Send files *) IF GETREPLY THEN IF RECVPACKET THEN IF InPacketType = Ord('Y') THEN ELSE IF InPacketType = Ord('N') THEN RESENDIT(10) ELSE IF InPacketType = Ord('R') THEN STATE := S ELSE STATE := A ELSE RESENDIT(10) ; GotoXY(36,5); Write (RetryCount); GETREPLY := TRUE ; If (InPacketType = Ord('Y')) and (InDataCount > 1) then If RecvData[1] = Ord('X') then STATE := SZ else If RecvData[1] = Ord('Z') then Begin STATE := SZ ; LastFile := true ; End ; If STATE = SD then Case Breakstate of NoBreak : ; BC : Sending := False ; BE : STATE := A ; BX : STATE := SZ ; BZ : Begin STATE := SZ ; LastFile := true ; End ; End ; (* Case Breakstate *) CASE STATE OF S : BEGIN (* Send INIT packit *) OutPacketType := Ord('S') ; PutInitPacket ; SENDPACKET ; STATE := SF ; END ; (* Send INIT packit *) SF: BEGIN (* Send file header *) (* If InDataCount = 0 then Begin Not a Init packet, Resend our Init Packet GetReply := False; State := S ; End Else *) Begin (* Got Init packet, Get init parameters *) If InDataCount > 1 then GetInitPacket ; OUTSEQ := OUTSEQ + 1 ; IF OUTSEQ >= 64 THEN OUTSEQ := 0 ; OutPacketType := Ord('F') ; OutDataCount := LENGTH(AsFileName); For i := 1 to OutDataCount do SendData[i] := Ord(AsFilename[i]) ; GotoXY(10,2); Write(' Sending file ',Filename,' as ',AsFileName, ' '); Assign(FileToSend,Prefixof(MyFiles)+FileName); RESET(FILETOSEND); STATE := SD ; SENDPACKET ; End (* Got Init packet, Get init parameters *) END ; (* Send file header *) SD: BEGIN (* Send data *) OutDataCount := 0 ; OUTSEQ := OUTSEQ + 1 ; IF OUTSEQ >= 64 THEN OUTSEQ := 0 ; OutPacketType := Ord('D') ; WHILE (OutDataCount= $80 THEN IF Bit8Quote = $00 THEN (* No bit8 quoting *) (* Just drop the 8th bit *) SendData[OutDataCount] := SendData[OutDataCount]-$80 ELSE BEGIN (* BIT8 QUOTING *) SendData[OutDataCount+1] := SendData[OutDataCount]-$80; SendData[OutDataCount] := Bit8Quote ; OutDataCount := OutDataCount + 1 ; END ; (* BIT8 QUOTING *) IF SendData[OutDataCount] < $20 THEN BEGIN (* CONTROL QUOTING *) SendData[OutDataCount+1] := SendData[OutDataCount] + $40 ; SendData[OutDataCount] := CntrlQuote ; OutDataCount := OutDataCount + 1 ; END ; (* CONTROL QUOTING *) IF SendData[OutDataCount] = $7F THEN BEGIN (* DEL QUOTING *) SendData[OutDataCount+1] := $3F ; SendData[OutDataCount] := CntrlQuote ; OutDataCount := OutDataCount + 1 ; END ; (* DEL QUOTING *) IF (SendData[OutDataCount] = CntrlQuote) OR (SendData[OutDataCount] = Bit8Quote) THEN BEGIN (* Quote the quote *) SendData[OutDataCount+1] := SendData[OutDataCount] ; SendData[OutDataCount] := CntrlQuote ; OutDataCount := OutDataCount + 1 ; END ; (* Quote the quote *) END ; (* Read a char *) PacketCount := PacketCount + 1 ; GotoXY(36,4) ; WRITE (PacketCount); IF EOF(FILETOSEND) THEN STATE := SZ ; SENDPACKET ; END ; (* Send data *) SZ: BEGIN (* End of File *) (* WRITELN ('end of file'); *) Close(FILETOSEND); GotoXY(10,6) ; If BreakState = NoBreak then WRITELN ('File ',Filename,' has been sent as ',AsFileName, ' ') else Writeln('File ',Filename,' Partially sent as ',AsFileName, ' '); If Lastfile then STATE := SB else GetNextFile: (* Get next file *) If Nextfile(Myfiles,Filename) then If NewAsFile(Myfiles,Filename,AsFilenames,AsFilename) then STATE := SF else goto GetNextFile else STATE := SB ; If Breakstate = BX then Breakstate := NoBreak ; SendPacketType('Z') ; END ; (* End of File *) SB: BEGIN (* Last file sent *) (* WRITELN ('SENT last file completed'); *) SendPacketType('B') ; STATE := C ; END ; (* Last file sent *) C: BEGIN (* Completed Sending *) GotoXY(10,7) ; If BreakState = NoBreak then WRITELN ('Sending FILEs completed OK ') else WRITELN ('Sending FILEs terminated due to manual Interruption '); SENDING := FALSE ; END ; (* Completed Sending *) A: BEGIN (* Abort Sending *) Close(FILETOSEND); GotoXY(10,7) ; WRITELN ('SENDing files ABORTED'); ABORT := BADSF ; SENDING := FALSE ; (* SEND ERROR packet *) OutDataCount := 15 ; OUTSEQ := 0 ; ErrorMsg := 'Send file abort' ; for i := 1 to OutDataCount do SendData[i] := Ord(ErrorMsg[i]) ; OutPacketType := Ord('E'); SENDPACKET ; END ; (* Abort Sending *) END ; (* CASE of STATE *) END ; (* Send files *) Exit: END ; (* SENDFILE procedure *) (* +FILE+ SENDFILE.PASCPM *) (* **************************************************************** *) (* SENDFILE - This routine handles the sending of a file from * *) (* the micro computer. * *) (* * *) (* **************************************************************** *) const MaxBlocks = 10 ; MaxBuffer = 2560 ; var FileToSend : file; NumRec,Records,Bufferindex,lastchar : integer ; Buffer : Array [1..MaxBuffer] of byte ; Endfile,Truncate : boolean ; abyte : byte ; Procedure ResetFileToSend ; Begin (* ResetFile Procedure *) Reset (FiletoSend); Records := Filesize(FileToSend); EndFile := false ; BufferIndex := 0 ; lastchar := 0 ; End ; (* ResetFile Procedure *) Procedure ReadFileToSend (var abyte : byte ); var i : integer ; Begin (* ReadFile Procedure *) Bufferindex := Bufferindex + 1 ; If Bufferindex > Lastchar then If Records > 0 then Begin (* get next block *) If Records > MaxBlocks then NumRec := MaxBlocks else NumRec := Records ; BlockRead(FiletoSend,Buffer,Numrec); Records := Records - NumRec ; Bufferindex := 1 ; Lastchar := NumRec * 128 ; abyte := Buffer[Bufferindex] ; End (* get next block *) else EndFile := true else abyte := Buffer[Bufferindex] ; If (abyte=$1A) and (Records=0) and ((lastchar-bufferindex<128)) then Begin (* probable eof *) EndFile := true ; For i := bufferindex +1 to lastchar-1 do if Buffer[i] <> Buffer[i+1] then EndFile := false ; if truncate then EndFile := true ; End ; (* probable eof *) End ; (* ReadFile Procedure *) PROCEDURE SENDFILE (var InParms : ComString); VAR MyFiles,FileName,AsFileNames,AsFileName,Atoken : Comstring ; SENDING, GETREPLY, LastFile, rawfile : Boolean ; abyte, Kchar,Kbchar : byte ; achar : char ; ErrorMsg : String[80]; PacketCount,i : Integer ; Label GetAsName,GetNextFile,Exit ; (* --------------------------------------------------- *) (* SENDRAW - This routine send the file in unpacket *) (* mode, Simply read and send. *) (* --------------------------------------------------- *) Procedure SENDRAW ; Begin (* SendRaw Procedure *) Sending := true ; While Sending Do Begin (* Send a file *) ClrScr; Writeln(' Sending File >>>>>>> ',Filename,' <<<<<<< '); Assign(FileToSend,FileName); RESETFileToSend; While not EndFile do Begin (* Send data *) ReadFileToSend(Abyte); SendChar(abyte); If LocalEcho then Write(chr(abyte)) else If Readchar(abyte) then Write(chr(abyte)); If XonXoff and (abyte = $0D) then (* wait for Xon *) While abyte<>XON do If Readchar(abyte) then else abyte := xon ; End ; (* Send data *) CLOSE(FileToSend); Sending := Nextfile(Myfiles,Filename); End ; (* Send a file *) Writeln(' '); End ; (* SendRaw Procedure *) (* **************************************************************** *) BEGIN (* SENDFILE procedure *) rawfile := false ; RetryCount := 0 ; (* Check the file to be sent here *) If length(InParms) < 1 then Begin (* Get name of file to send *) Write (' Enter name of file to be sent >'); Readln(InParms); End; MyFiles := ' '; MyFiles := UpperCase(GetToken(InParms)); AsFileNames := MyFiles ; Atoken := UpperCase(GetToken(InParms)); If Atoken = 'AS' then If length(InParms)<1 then AsFileNames := MyFiles else AsFileNames := UpperCase(GetToken(InParms)) else If Atoken = 'RAW' then rawfile := true else InParms := Atoken + InParms ; If FirstFile(Myfiles,Filename) then else begin (* No file found *) Writeln (' File "',MyFiles,'" not found.'); Goto Exit ; end ; (* No file found *) AsFilename := 'Blank' ; If rawfile then begin SendRaw ; goto exit ; end ; GetAsName: If NewAsFile(Myfiles,Filename,AsFileNames,AsFileName) then else If NextFile(Myfiles,Filename) then goto GetAsName else begin (* No file found *) Writeln (' File "',MyFiles,'" not found on disk.'); Goto Exit ; end ; (* No file found *) STATE := S ; BreakState := NoBreak ; GETREPLY := FALSE ; LastFile := false ; SENDING := TRUE ; ClrScr; GotoXY(10,4); Write(' Number of Packets Sent = '); GotoXY(10,5); Write(' Number of Retries = '); PacketCount := 0 ; WHILE SENDING DO BEGIN (* Send files *) IF GETREPLY THEN IF RECVPACKET THEN IF InPacketType = Ord('Y') THEN ELSE IF InPacketType = Ord('N') THEN RESENDIT(10) ELSE IF InPacketType = Ord('R') THEN STATE := S ELSE STATE := A ELSE RESENDIT(10) ; GotoXY(36,5); Write (RetryCount); GETREPLY := TRUE ; If (InPacketType = Ord('Y')) and (InDataCount > 1) then If RecvData[1] = Ord('X') then STATE := SZ else If RecvData[1] = Ord('Z') then Begin STATE := SZ ; LastFile := true ; End ; If STATE = SD then Case Breakstate of NoBreak : ; BC : Sending := False ; BE : STATE := A ; BX : STATE := SZ ; BZ : Begin STATE := SZ ; LastFile := true ; End ; End ; (* Case Breakstate *) CASE STATE OF S : BEGIN (* Send INIT packit *) OutPacketType := Ord('S') ; PutInitPacket ; SENDPACKET ; STATE := SF ; END ; (* Send INIT packit *) SF: BEGIN (* Send file header *) If InDataCount = 0 then Begin (* Not a Init packet, Resend our Init Packet *) GetReply := False; State := S ; End Else Begin (* Got Init packet, Get init parameters *) GetInitPacket ; OUTSEQ := OUTSEQ + 1 ; IF OUTSEQ >= 64 THEN OUTSEQ := 0 ; OutPacketType := Ord('F') ; OutDataCount := LENGTH(AsFileName); For i := 1 to OutDataCount do SendData[i] := Ord(AsFilename[i]) ; GotoXY(10,2); Write(' Sending file ',Filename,' as ',AsFileName, ' '); Assign(FileToSend,FileName); RESETFILETOSEND; STATE := SD ; SENDPACKET ; End (* Got Init packet, Get init parameters *) END ; (* Send file header *) SD: BEGIN (* Send data *) OutDataCount := 0 ; OUTSEQ := OUTSEQ + 1 ; IF OUTSEQ >= 64 THEN OUTSEQ := 0 ; OutPacketType := Ord('D') ; WHILE (OutDataCount= $80 THEN IF Bit8Quote = $00 THEN (* No bit8 quoting *) (* Just drop the 8th bit *) SendData[OutDataCount] := SendData[OutDataCount] -$80 ELSE BEGIN (* BIT8 QUOTING *) SendData[OutDataCount+1] := SendData[OutDataCount]-$80; SendData[OutDataCount] := Bit8Quote ; OutDataCount := OutDataCount + 1 ; END ; (* BIT8 QUOTING *) IF SendData[OutDataCount] < $20 THEN BEGIN (* CONTROL QUOTING *) SendData[OutDataCount+1] := SendData[OutDataCount] +$40; SendData[OutDataCount] := CntrlQuote ; OutDataCount := OutDataCount + 1 ; END ; (* CONTROL QUOTING *) IF SendData[OutDataCount] = $7F THEN BEGIN (* DEL QUOTING *) SendData[OutDataCount+1] := $3F ; SendData[OutDataCount] := CntrlQuote ; OutDataCount := OutDataCount + 1 ; END ; (* DEL QUOTING *) IF (SendData[OutDataCount] = CntrlQuote) OR (SendData[OutDataCount] = Bit8Quote) THEN BEGIN (* Quote the quote *) SendData[OutDataCount+1] := SendData[OutDataCount] ; SendData[OutDataCount] := CntrlQuote ; OutDataCount := OutDataCount + 1 ; END ; (* Quote the quote *) END ; (* Read a char *) PacketCount := PacketCount + 1 ; GotoXY(36,4) ; WRITE (PacketCount); IF EndFile THEN STATE := SZ ; SENDPACKET ; END ; (* Send data *) SZ: BEGIN (* End of File *) (* WRITELN ('end of file'); *) Close(FILETOSEND); GotoXY(10,6) ; If BreakState = NoBreak then WRITELN ('File ',Filename,' has been sent as ',AsFileName, ' ') else Writeln('File ',Filename,' Partially sent as ',AsFileName, ' '); If Lastfile then STATE := SB else GetNextFile: (* Get next file *) If Nextfile(Myfiles,Filename) then If NewAsFile(Myfiles,Filename,AsFilenames,AsFilename) then STATE := SF else goto GetNextFile else STATE := SB ; If Breakstate = BX then Breakstate := NoBreak ; SendPacketType('Z') ; END ; (* End of File *) SB: BEGIN (* Last file sent *) (* WRITELN ('SENT last file completed'); *) SendPacketType('B') ; STATE := C ; END ; (* Last file sent *) C: BEGIN (* Completed Sending *) GotoXY(10,7) ; If BreakState = NoBreak then WRITELN ('Sending FILEs completed OK ') else WRITELN ('Sending FILEs terminated due to manual Interruption '); SENDING := FALSE ; END ; (* Completed Sending *) A: BEGIN (* Abort Sending *) Close(FILETOSEND); GotoXY(10,7) ; WRITELN ('SENDing files ABORTED'); ABORT := BADSF ; SENDING := FALSE ; (* SEND ERROR packet *) OutDataCount := 15 ; OUTSEQ := 0 ; ErrorMsg := 'Send file abort' ; for i := 1 to OutDataCount do SendData[i] := Ord(ErrorMsg[i]) ; OutPacketType := Ord('E'); SENDPACKET ; END ; (* Abort Sending *) END ; (* CASE of STATE *) END ; (* Send files *) Exit: END ; (* SENDFILE procedure *) (* +FILE+ RECVFILE.PASMSCPM *) (* ------------------------------------------------------------ *) (* BreakACK - Procedure will send a ACK plus a break char *) (* X or Z . *) (* ------------------------------------------------------------ *) PROCEDURE BreakACK (Achar : Char); BEGIN (* SEND ACK or NAK *) OutDataCount := 1 ; OUTSEQ := OUTSEQ + 1 ; IF OUTSEQ >= 64 then OUTSEQ := 0; OUTPACKETTYPE := ord('Y'); SendData[1] := Ord(Achar); SENDPACKET ; END ; (* SEND ACK or NAK *) (* ------------------------------------------------------------ *) (* RenameDup- Procedure will check to see if a file is *) (* already present if it is it returns a new *) (* name modified with &. *) (* Note : this procedure is maybe called recursively. *) (* ------------------------------------------------------------ *) PROCEDURE RenameDup(var MyFile:comstring); BEGIN (* RenameDup *) If Firstfile(MyFile,MyFile) then Begin (* change name of file *) Insert ('&',Myfile,Pos('.',Myfile)); if Pos('.',Myfile) > 9 then Delete(Myfile,Pos('&',Myfile)-1,1); RenameDup(Myfile); End ; (* change name of file *) END ; (* RenameDup *) (* **************************************************************** *) (* RECVFILE - This routine handles the Receiving of a file from *) (* the Main frame computer. *) (* *) (* **************************************************************** *) PROCEDURE RECVFILE (var InParms : comstring); VAR Bit8 : BYTE ; Lastseqnum : INTEGER ; Receiving,ReplaceFile : BOOLEAN ; Retries,PacketCount, CharCount,i,j : INTEGER ; Filenames,FileName, Myfiles,Myfile,Astring : ComString ; ErrorMsg : ComString ; FileComing : TEXT ; Label Gotinit; (* ------------------------------------------------------------ *) (* SENDNAK - Procedure of RECVFILE, will check the number of *) (* RETRIES , if it is greater than 0 it will send a *) (* call SendPacketType('N') which send a NAK packet *) (* and decrements the RETRIES by 1. *) (* Side Effect - RETRIES is decremented by 1. *) (* STATE is set to A if no more retries. *) (* - RetryCount is incremented *) (* ------------------------------------------------------------ *) PROCEDURE SENDNAK ; BEGIN (* SEND NAK *) RetryCount := RetryCount + 1; IF RETRIES > 0 then BEGIN (* Ask for a retransmission *) SendPacketType('N'); RETRIES := RETRIES - 1 ; END (* Ask for a retransmission *) else STATE := A ; END ; (* SEND NAK *) BEGIN (* ------- RECVFILE procedure ------- *) WRITELN (' RECEIVE file command . ',InParms); Packetcount := 0 ; ReplaceFile := false ; Lastseqnum := 0 ; (* Scan Parameter string *) FileNames := GETTOKEN(InParms); MyFiles := FileNames ; Astring := Uppercase(GetToken(Inparms)); If Astring = 'AS' then if length(InParms) > 0 then Begin (* get AS name *) MyFiles := GetToken(Inparms); Astring := Uppercase(GetToken(Inparms)); If Pos(Astring,' REPLACE') = 2 then ReplaceFile := True else InParms := Astring + InParms; End (* get AS name *) else MyFiles := FileNames else If Pos(Astring,' REPLACE') = 2 then ReplaceFile := True else InParms := Astring + InParms ; If FileNames <> '' then Begin (* Send a R type packet requesting the file *) OutDataCount := length(Filenames); OutSeq := 0 ; OutPacketType := ord('R'); For i := 1 to length(Filenames) do SendData[i] := Ord(FileNames[i]) ; WaitXon := false ; SendPacket ; End (* Send a R type packet requesting the file *) else WaitXon := XonXoff ; STATE := R ; RECEIVING := TRUE ; BreakState := NoBreak ; RETRIES := 10 ; (* Up to 10 retries allowed. *) RetryCount := 0 ; clrscr ; GotoXY(10,4) ; Write('Number of Data Packets Received = '); GotoXY(10,5) ; Write('Number of Nak responses sent = '); WHILE RECEIVING DO CASE STATE OF (* R ------ Initial receive State ------- *) (* Valid received msg type : S *) R : BEGIN (* Initial Receive State *) If InPacketType =Ord('S') then goto Gotinit; IF (NOT RECVPACKET) OR (INPACKETTYPE=Ord('N')) then SENDNAK else Gotinit: (* Get a packet *) IF INPACKETTYPE = Ord('S') then BEGIN (* Got INIT packet *) GetInitPacket ; (* Get Init parameters *) (* Reply with ACK and init parameters *) OutPacketType := Ord('Y'); PutInitPacket ; SENDPACKET ; STATE := RF ; END (* Got INIT packet *) else BEGIN (* Not init packet *) STATE := A ; (* ABORT if not INIT packet *) ABORT := NOT_S ; END ; (* Not init packet *) END ; (* Initial Receive State *) (* RF ----- Receive Filename State ------- *) (* Valid received msg type : S,Z,F,B *) RF: IF (NOT RECVPACKET) OR (INPACKETTYPE=Ord('N')) then SENDNAK else (* Get a packet *) IF INPACKETTYPE = Ord('S') then STATE:=R else IF INPACKETTYPE = Ord('Z') then SendPacketType('N') else IF INPACKETTYPE = Ord('B') then STATE:=C else IF INPACKETTYPE = Ord('F') then BEGIN (* Got file header *) For i := 1 to InDataCount do FileName[i] := Chr(RecvData[i]) ; FileName[0] := Chr(InDataCount) ; If Filenames = '' then Myfile := Filename else If NewAsfile(Filenames,Filename,MyFiles,Myfile) then; GotoXY(10,2); If ReplaceFile then (* write over old file *) else ReNameDup(Myfile); Writeln('Receiving file ',Filename,' as ',Myfile, ' '); Assign(FileComing,Prefixof(Filenames)+MyFile); STATE := RD ; If not ForPrinter then Begin {$I-} REWRITE(FileComing); If IOresult <> 0 then Begin (* IO error *) Writeln(' Directory Full '); STATE := A ; SendPacketType('N'); End ; (* IO error *) End ; {$I+} SendPacketType('Y'); END (* Got file header *) else BEGIN (* Not S,F,B,Z packet *) STATE := A ; (* ABORT if not a S,F,B,Z type packet *) ABORT := NOT_SFBZ ; END ; (* Not S,F,B,Z packet *) (* RD ----- Receive Data State ------- *) (* Valid received msg type : D,Z *) RD: IF (NOT RECVPACKET) OR (INPACKETTYPE=Ord('N')) then SENDNAK else If lastseqnum = inseq then SendPacketType('Y') else BEGIN (* Got a good packet *) lastseqnum := inseq ; IF INPACKETTYPE = Ord('D') then BEGIN (* Receive data *) (* WRITELN ('RECEIVE data '); *) PacketCount := PacketCount + 1 ; GotoXY(44,4) ; Write (PacketCount); GotoXY(44,5) ; Writeln(RetryCount); I := 1 ; WHILE I <= InDataCount DO BEGIN (* Write Data to file *) IF RecvData[I] = RepChar then BEGIN (* Repeat char *) I := I+1 ; charcount := RecvData[I] - 32 ; I := I + 1 ; For j := 1 to charcount - 1 do If ForPrinter then Write(LST,Chr(RecvData[i])) else Begin {$I-} Write(FileComing,Chr(RecvData[i])); If IOresult <> 0 then Begin (* IO error *) Writeln(' Disk is Full or file too large'); STATE := A ; SendPacketType('N'); End ; (* IO error *) End ; {$I+} END ; (* Repeat char *) IF RecvData[I] = Bit8Quote then BEGIN (* 8TH BIT QUOTING *) I := I+1 ; BIT8 := $80 ; END (* 8TH BIT QUOTING *) else BIT8 := 0 ; IF RecvData[I] = CntrlQuote then BEGIN (* CONTROL character *) I := I+1 ; IF RecvData[I] = $3F then (* Make it a del *) RecvData[I] := $7F else IF RecvData[I] >= 64 then (* Make it a control *) RecvData[I] := RecvData[I] - 64 ; END ; (* CONTROL character *) RecvData[I] := RecvData[I] + BIT8 ; If ForPrinter then Write(LST,Chr(RecvData[i])) else Begin {$I-} Write(FileComing,Chr(RecvData[i])); If IOresult <> 0 then Begin (* IO error *) Writeln(' Disk is Full or file too large'); STATE := A ; SendPacketType('N'); End ; (* IO error *) End ; {$I+} I := I + 1 ; END ; (* Write Data to File *) Case Breakstate of NoBreak : SendPacketType('Y'); BC : RECEIVING:=false ; BE : SendPacketType('N') ; BX : BreakAck('X') ; BZ : BreakAck('Z') ; End; (* Case BreakState *) If Breakstate <> NoBreak then Writeln('Receiving file ',Filename,' as ',Myfile,' Interrupted'); If BreakState = BX then Breakstate := NoBreak ; END (* Receive data *) else IF INPACKETTYPE = Ord('F') then BEGIN (* repeat *) OutSeq := OutSeq - 1 ; SendPacketType('Y') ; END (* repeat *) else IF INPACKETTYPE = Ord('Z') then BEGIN (* End of Incoming File *) If not ForPrinter then Begin {$I-} CLOSE(FileComing); If IOresult <> 0 then Begin (* IO error *) Writeln(' Disk is Full or file too large'); End ; (* IO error *) End ; {$I+} STATE := RF ; SendPacketType('Y'); END (* End of Incoming File *) else BEGIN (* Not D,Z packet *) STATE := A; (* ABORT - Type not D,Z, *) ABORT := NOT_DZ ; END ; (* Not D,Z packet *) END ; (* Got a good packet *) (* C ----- COMPLETED State ------- *) C: BEGIN (* COMPLETED Receiving *) SendPacketType('Y'); If BreakState = NoBreak then Writeln ('Receiving files completed OK.') else Writeln('Receiving Files terminated by manual interruption'); RECEIVING := FALSE ; END ; (* COMPLETED Receiving *) (* A ----- A B O R T State ------- *) A: BEGIN (* Abort Sending *) {$I-} CLOSE(FileComing); If IOresult <> 0 then Writeln(' Unable to close file, is DISK FULL '); {$I+} WRITELN ('RECEIVEing files ABORTED'); RECEIVING := FALSE ; (* SEND ERROR packet *) OutSeq := 0 ; ErrorMsg :=' RECVfile abort' ; OutDataCount := length(ErrorMsg) ; For i := 1 to length(ErrorMsg) do SendData[i] := Ord(ErrorMsg[i]) ; OutPacketType := Ord('E'); SENDPACKET ; END ; (* Abort Sending *) END ; (* CASE of STATE *) END ; (* ------- RECVFILE procedure -------*) (* +FILE+ CONNECT.PASVT52 *) (* ================================================================== *) (* Global Var *) (* ================================================================== *) Const Gversion = ' ' ; TermType = ' VT52 ' ; Graphics = '- Not applicable ' ; (* ================================================================== *) (* ReadkeyTable - Dummy procedure *) (* ================================================================== *) Procedure ReadKeyTable ; Begin End ; (* ================================================================== *) (* Connection - Connect to the other computer and simulates *) (* a VT52 type terminal . *) (* *) (* ================================================================== *) Procedure Connection ; VAR achar,bchar : byte ; i : integer ; (* -------------------------------------------------------- *) Procedure Escape ; Type EscapeType=(A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z); Var Xpos,Ypos : byte ; Begin (* Escape Sequence *) If Readchar(achar) then CASE EscapeType(achar-$41) of A: CursorUp ; (* System Dependent Routine *) B: CursorDown ; (* System Dependent Routine *) C: CursorRight ; (* System Dependent Routine *) D: CursorLeft ; (* System Dependent Routine *) H: (* Clear Screen *) If ReadChar(achar) then (* read next ESC char *) If ReadChar(achar) then (* read J char *) ClrScr; K: ClrEol ; Y: Begin (* Cursor Position *) If ReadChar(achar) then Ypos := achar - $1F ; If ReadChar(achar) then Xpos := achar - $1F ; GotoXY(Xpos,Ypos); End ; (* Cursor Position *) End ; (* Case *) End ; (* Escape Sequence *) (* -------------------------------------------------------- *) Procedure RemoteCommand ; Var i : integer ; Filename : Comstring ; Begin (* RemoteCommand procedure *) GotSOH := true ; If RecvPacket then Begin (* Got a Packet *) If InPacketType = Ord('S') then (* Send Packet *) Begin (* Receive *) writeln('Got a Send request '); Filename := '' ; RecvFile(filename); End (* Receive *) else If InPacketType = Ord('R') then (* Receive Packet *) Begin (* Receive *) writeln('Got a receive request '); for i := 1 to InCount-3 do filename[i] := chr(RecvData[i]); Filename[0] := chr(InCount-3) ; waitxon := XonXoff ; SendFile(filename); End (* Receive *) else If InPacketType = Ord('G') then (* General Packet *) Begin (* Receive *) writeln('Got a General request '); SendPacketType('Y'); End (* Receive *) else Begin (* Unknow packet Type *) OutCount := 15 ; Outseq := 0 ; OutPacketType := Ord('E'); (* SendData := 'Unknow Command'; *) End; (* Unknown packet Type *) End (* Got a Packet *) End ; (* RemoteCommand Procedure *) (* -------------------------------------------------------- *) Begin (* Connection *) DialModem ; RemoteScreen ; (* Save local screen, restore remote screen *) While connected do Begin (* connected *) If RecvChar(achar) then if achar < $20 then Begin (* Control Character *) if achar = SOH then RemoteCommand else if achar = EOT then connected := false else if achar = ESC then Escape else if achar in [7,8,10,13] then write(chr(achar)); End (* Control Character *) else If achar <> DEL then write(chr(achar)); if KeyChar(achar,bchar) then Begin (* key input *) if achar = $00 then if bchar = 83 then SendChar($7F) (* DEL *) else if bchar = 82 then SendChar($19) (* INS *) else Begin (* Special Key *) SendChar(Esc); CASE bchar of $3B,$3C,$3D,$3E,$3F,$40,$41,$42,$43: SendChar(bchar-10); (* PF1 to PF9 keys *) $44: SendChar($30) ; (* PF10 key *) $54: SendChar($2D) ; (* PF11 key *) $55: SendChar($3D) ; (* PF12 key *) $56: SendChar($71) ; (* PF13 key *) $57: SendChar($77) ; (* PF14 key *) $58: SendChar($65) ; (* PF15 key *) $59: SendChar($72) ; (* PF16 key *) $5A: SendChar($74) ; (* PF17 key *) $5B: SendChar($79) ; (* PF18 key *) $5C: SendChar($75) ; (* PF19 key *) $5D: SendChar($69) ; (* PF20 key *) $48: SendChar($41) ; (* Esc A - up arrow *) $50: SendChar($42) ; (* Esc B - down arrow *) $4D: SendChar($43) ; (* Esc C - rightarrow *) $4B: SendChar($44) ; (* Esc D - left arrow *) $47,$4C: SendChar($48) ; (* Esc H - home arrow *) $51,$77: SendChar($4A) ; (* Esc J - Clear *) $4F,$75: SendChar($4B) ; (* Esc K - Erase Eol *) End; (* Case bchar *) End (* Special Key *) else Begin (* Normal Key *) if achar = LocalChar then connected := false else if achar = BreakChar then SendBreak else Sendchar(achar); if LocalEcho and connected then write(chr(achar)); End ; (* Normal Key *) End; (* key input *) End; (* connected *) LocalScreen ; (* save remote screen , restore local screen *) End ; (* Connection *) (* +FILE+ CONNECT.PASADM3A *) (* ================================================================== *) (* Global Declarations - for ADM3A type of terminal emulation *) (* ================================================================== *) Const Gversion = ' ' ; TermType = ' ADM3A ' ; Graphics = '- Not Implemented ' ; Procedure ReadKeytable ; Begin End ; (* dummy procedure - for MsDos systems only *) (* ================================================================== *) (* Connection - Connect to the other computer and simulates *) (* a DUMB terminal . *) (* *) (* ================================================================== *) Procedure Connection ; VAR achar,bchar : byte ; i : integer ; (* -------------------------------------------------------- *) Procedure RemoteCommand ; Var i : integer ; Filename : Comstring ; Begin (* RemoteCommand procedure *) GotSOH := true ; If RecvPacket then Begin (* Got a Packet *) If InPacketType = Ord('S') then (* Send Packet *) Begin (* Receive *) writeln('Got a Send request '); Filename := '' ; RecvFile(filename); End (* Receive *) else If InPacketType = Ord('R') then (* Receive Packet *) Begin (* Receive *) writeln('Got a receive request '); for i := 1 to InCount-3 do filename[i] := chr(RecvData[i]); Filename[0] := chr(InCount-3) ; waitxon := XonXoff ; SendFile(filename); End (* Receive *) else If InPacketType = Ord('G') then (* General Packet *) Begin (* Receive *) writeln('Got a General request '); SendPacketType('Y'); End (* Receive *) else Begin (* Unknow packet Type *) OutCount := 15 ; Outseq := 0 ; OutPacketType := Ord('E'); (* SendData := 'Unknow Command'; *) End; (* Unknown packet Type *) End (* Got a Packet *) End ; (* RemoteCommand Procedure *) (* -------------------------------------------------------- *) Begin (* Connection *) DialModem ; RemoteScreen ; (* Save local screen, restore remote screen *) While connected do Begin (* connected *) If RecvChar(achar) then if achar = SOH then RemoteCommand else if achar = EOT then connected := false else if achar in [17,19,127] then (* don't write *) else Ritechar(achar); if KeyChar(achar,bchar) then Begin (* key input *) Begin (* Normal Key *) if LocalEcho then Ritechar(achar); if achar = LocalChar then connected := false else if achar = BreakChar then SendBreak else Sendchar(achar); End ; (* Normal Key *) End; (* key input *) End; (* connected *) LocalScreen ; (* save remote screen , restore local screen *) End ; (* Connection *) (* +FILE+ CONNECT.PASVT100 *) (* ================================================================== *) (* Global Var and Procedures for special key specifications. *) (* ================================================================== *) Const Gversion = ' ' ; TermType = ' VT100 ' ; Graphics = '- Not applicable ' ; Var EscSeq : Array [1..$88,1..2] of char ; KeyTableName : String[14] ; KeyTable : Text ; (*------------------------------------------------------------------- *) Function hexinteger (chars : string2): byte ; begin (* HexInteger *) If chars[1] in ['A'..'F'] then chars[1]:=chr(ord(chars[1])+9); If chars[2] in ['A'..'F'] then chars[2]:=chr(ord(chars[2])+9); hexinteger := (ord(chars[1]) shl 4) + (ord(chars[2]) and $0F) ; end ; (* HexInteger *) (*------------------------------------------------------------------- *) Procedure ReadKeytable ; var I : integer ; Newname : string[15] ; comment : string[80] ; label retry ; Begin (* ReadKeytable *) keytablename := 'KEYTABLE.DAT' ; Assign(keytable,keytablename) ; retry : {$I-} Reset(keytable); {$I+} If IORESULT = 0 then Begin (* Initiate key table *) For i := 1 to $88 do Begin (* init EscSeq table *) Readln(KeyTable,EscSeq[i,1],EscSeq[i,2],comment) ; If copy(comment,2,2) <> ' ' then EscSeq[i,1] := Chr(HexInteger(copy(comment,2,2))) ; If copy(comment,4,2) <> ' ' then EscSeq[i,2] := Chr(HexInteger(copy(comment,4,2))) ; End ; (* init EscSeq table *) Close(keytable); End (* Initiate key table *) else Begin (* Warning *) ClrScr ; Writeln('*** File ',Keytablename,' not found on drive.'); Writeln(' Please specify drive or new name of keytable file. '); Readln(newname); If Length(Newname) = 1 then keytablename := Newname + ':' + keytablename else keytablename := Newname ; Assign(keytable,keytablename); If length(keytablename)<3 then Running := false else Goto Retry ; End ; (* Warning *) End ; (* ReadKeytable *) const APLTABLE : array [0..127] of byte = {00} ($00,$01,$02,$03,$04,$05,$06,$07,$08,$09,$0A,$0B,$0C,$0D,$0E,$0F, {0F} {01} $10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$1A,$1B,$1C,$1D,$1E,$1F, {1F} {02} $20,$05,$29,$3C,$F3,$3D,$3E,$5D,$FA,$5E,$86,$F6,$2C,$2B,$2E,$2F, {1F} {03} $30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$28,$5B,$3B,$78,$3A,$5C, {3F} {04} $FD,$E0,$E6,$EF,$8F,$EE,$5F,$EC,$91,$E2,$F8,$27,$95,$FE,$E7,$F9, {4F} {05} $2A,$3F,$FB,$8D,$7E,$19,$FC,$17,$0E,$18,$0B,$1B,$1D,$1A,$F2,$2D, {5F} {06} $40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$4A,$4B,$4C,$4D,$4E,$4F, {6F} {07} $50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$5A,$7B,$1C,$7D,$24,$2D); {7F} Over1 = 'T('#$E5'T)'#$EA'GM'#$1F'HM'#$1E'OM'#$E8'O?'#$ED'O_'#$E9'OP'#$0F ; Over2 = 'BN'#$15'GT'#$13'BJ'#$F5'NJ'#$F4'?_'#$A7'/_'#$EB'CJ'#$A6'KL'#$97 ; Over3 = 'K.'#$21'L+'#$98 ; Over4 = 'aFabFbcFcdFdeFefFfgFghFhiFijFjkFklFlmFmnFnoFopFpqFqrFrsFs' ; Over5 = 'tFtuFuvFvwFwxFxyFyzFz' ; (* ================================================================== *) (* Connection - Connect to the other computer and simulates *) (* a VT100 type terminal . *) (* *) (* ================================================================== *) Procedure Connection ; VAR achar,bchar : byte ; i : integer ; overchar : string[2] ; overchars : string[160] ; EscapeFlag : boolean ; (* -------------------------------------------------------- *) Procedure Escape ; Var Pn,Pc : byte ; Function PNumber (var achar : byte) : integer ; var Numstr : string[3]; Num,result : integer ; Begin (* PNumber *) Numstr := '' ; While chr(achar) in ['0'..'9'] do Begin (* get number *) Numstr := Numstr + chr(achar) ; If Readchar(achar) then ; End ; (* get number *) Val(Numstr,Num,Result); PNumber := Num ; End ; (* PNumber *) Begin (* Escape Sequence *) If Readchar(achar) then CASE chr(achar) of (* First Level *) '[': If Readchar(achar) then CASE chr(achar) of (* Second level *) 'C': CursorRight ; 'D': CursorLeft ; 'J': ClrScr ; (* Erase End of Display *) 'K': ClrEol ; (* Erase End of Line *) '?': ; (* Special functions - not yet implemented *) 'H': GoToXY(0,0); (* Cursor Home *) 'm':(* NormVideo*) ; (* Exit all attribute modes *) else Begin (* Esc [ Pn x functions *) Pn := PNumber(achar); CASE chr(achar) of (* third level *) 'A': For i := 1 to Pn do Cursorup ; 'B': For i := 1 to Pn do Cursordown ; 'C': For i := 1 to Pn do CursorRight ; 'D': For i := 1 to Pn do CursorLeft ; ';': Begin (* Direct cursor addressing *) If readchar(achar) then ; Pc := PNumber (achar); GoToXY(Pc,Pn); If (pn<1) or (pc<1) then writeln('***',pn,' ',pc,'***'); End ; (* Direct cursor addressing *) 'q': FatCursor(Pn=1) ; 'm', '}': Case Pn of (* Field specs *) 0: begin (* Normal *) TextColor(LightGray); Textbackground(black); end ; 1: begin (* High Intensity *) TextColor(White); Textbackground(black); end ; 4: begin (* Underline *) TextColor(White); Textbackground(black); end ; 5: begin (* Blink *) TextColor(White+ blink); Textbackground(black); end ; 7: begin (* Reverse *) TextColor(Black); Textbackground(white); end ; 8: begin (* Invisible *) TextColor(Black); Textbackground(black); end ; 30: Textcolor(Black); 31: Textcolor(Red); 32: Textcolor(Green); 33: Textcolor(yellow); 34: Textcolor(Blue); 35: Textcolor(Magenta); 36: Textcolor(Cyan); 37: Textcolor(White); 40: Textbackground(Black); 41: Textbackground(Red); 42: Textbackground(Green); 43: Textbackground(Yellow); 44: Textbackground(Blue); 45: Textbackground(Magenta); 46: Textbackground(Cyan); 47: Textbackground(White); End ; (* case of Field specs *) 'J': Case Pn of 0: ClrScr ; 1: ClrScr ; (* clear to beginning *) 2: ClrScr ; End ; (* J - Pn Case *) 'K': Case Pn of 1: ClrEol ; (* clear to beginning *) 2: ClrEol ; (* clear line *) End ; (* J - Pn Case *) 'L': For i := 1 to Pn do InsLine ; (* Insert Line *) 'M': For i := 1 to Pn do DelLine ; (* Delete Line *) '@': For i := 1 to Pn do (* InsertChar *) ; 'P': For i := 1 to Pn do (* DeleteChar *) ; End ; (* Case third level *) End ; (* Esc [ Pn x functions *) End ; (* second level Case *) 'D': CursorDown ; (* Index *) 'M': CursorUp ; (* Reverse Index *) 'H': ; (* Set Tab Stop *) '(': ; (* G0 *) ')': ; (* G1 *) End ; (* First Level Case *) End ; (* Escape Sequence *) (* -------------------------------------------------------- *) Procedure RemoteCommand ; Var i : integer ; Filename : Comstring ; Begin (* RemoteCommand procedure *) GotSOH := true ; If RecvPacket then Begin (* Got a Packet *) If InPacketType = Ord('S') then (* Send Packet *) Begin (* Receive *) writeln('Got a Send request '); Filename := '' ; RecvFile(filename); End (* Receive *) else If InPacketType = Ord('R') then (* Receive Packet *) Begin (* Receive *) writeln('Got a receive request '); for i := 1 to InCount-3 do filename[i] := chr(RecvData[i]); Filename[0] := chr(InCount-3) ; waitxon := XonXoff ; SendFile(filename); End (* Receive *) else If InPacketType = Ord('G') then (* General Packet *) Begin (* Receive *) writeln('Got a General request '); SendPacketType('Y'); End (* Receive *) else Begin (* Unknow packet Type *) OutCount := 15 ; Outseq := 0 ; OutPacketType := Ord('E'); (* SendData := 'Unknow Command'; *) End; (* Unknown packet Type *) End (* Got a Packet *) End ; (* RemoteCommand Procedure *) (* -------------------------------------------------------- *) Begin (* Connection *) DialModem ; Overchars := Over1+Over2+Over3+Over4+Over5 ; RemoteScreen ; (* Save local screen, restore remote screen *) While KeyChar(achar,bchar) do ; (* Empty keyboard buffer *) While connected do Begin (* connected *) If RecvChar(achar) then if achar < $20 then Begin (* Control Character *) if achar = StartChar then RemoteCommand else if achar = EOT then connected := false else if achar = ESC then Escape else if (achar=BS) and AplFlag then Begin (* Overstrick character *) overchar[0] := chr(2) ; If Readchar(achar) then overchar[2]:=chr(achar); i:=Pos(overchar,overchars); If i > 0 then achar := ord(overchars[i+2]) else begin (* reverse order *) overchar[2] := overchar[1] ; overchar[1] := chr(achar); i:=Pos(overchar,overchars); If i>0 then achar := ord(overchars[i+2]) else achar := AplTable[ord(overchar[2])]; end ; (* reverse order *) write(chr(BS),chr(achar)); End (* Overstrick character *) else if achar in [7,8,10,13] then write(chr(achar)); End (* Control Character *) else If achar <> DEL then if AplFlag then begin (* APL char *) write(chr(APLTABLE[achar])); overchar[1] := chr(achar) ; end else write(chr(achar)); if KeyChar(achar,bchar) then Begin (* key input *) if bchar = $70 then connected := false else (* Alt F9 *) if bchar = $71 then SendBreak else (* Alt F10 *) If ((achar=0) or (EscSeq[bchar,1]<>' ') or (EscSeq[bchar,2]<>' ') ) and (achar <> $09) then Begin (* Send escape sequence *) If EscSeq[Bchar,1]<>' ' then SendChar(Esc); If EscSeq[Bchar,1]<>' ' then SendChar(Ord(EscSeq[bchar,1])) ; If EscSeq[bchar,2]<>' ' then SendChar(Ord(EscSeq[bchar,2])) ; End (* Send Escape Sequence *) else Begin (* Normal Key *) If EscapeFlag then if achar = $7B then AplFlag := true else if achar = $7D then AplFlag := false ; Escapeflag := achar = ESC ; if achar = LocalChar then connected := false else if achar = BreakChar then SendBreak else Sendchar(achar); if LocalEcho and connected then if AplFlag then write(chr(APLTABLE[achar])) else write(chr(achar)); End ; (* Normal Key *) End; (* key input *) End; (* connected *) LocalScreen ; (* save remote screen , restore local screen *) End ; (* Connection *) (* +FILE+ CONNECT.PASTEK10 *) (* ================================================================== *) (* Global Var and Procedures for special key specifications. *) (* ================================================================== *) Const Gversion = 'G ' ; TermType = ' TEK4010' ; Graphics = ' by Victoria Henderson ' ; Var EscSeq : Array [1..$88,1..2] of char ; KeyTableName : String[14] ; KeyTable : Text ; (*------------------------------------------------------------------- *) Function hexinteger (chars : string2): byte ; begin (* HexInteger *) If chars[1] in ['A'..'F'] then chars[1]:=chr(ord(chars[1])+9); If chars[2] in ['A'..'F'] then chars[2]:=chr(ord(chars[2])+9); hexinteger := (ord(chars[1]) shl 4) + (ord(chars[2]) and $0F) ; end ; (* HexInteger *) (*------------------------------------------------------------------- *) Procedure ReadKeytable ; var I : integer ; Newname : string[15] ; comment : string[80] ; label retry ; Begin (* ReadKeytable *) keytablename := 'KEYTABLE.DAT' ; Assign(keytable,keytablename) ; retry : {$I-} Reset(keytable); {$I+} If IORESULT = 0 then Begin (* Initiate key table *) For i := 1 to $88 do Begin (* init EscSeq table *) Readln(KeyTable,EscSeq[i,1],EscSeq[i,2],comment) ; If copy(comment,2,2) <> ' ' then EscSeq[i,1] := Chr(HexInteger(copy(comment,2,2))) ; If copy(comment,4,2) <> ' ' then EscSeq[i,2] := Chr(HexInteger(copy(comment,4,2))) ; End ; (* init EscSeq table *) Close(keytable); End (* Initiate key table *) else Begin (* Warning *) Writeln('No ',Keytablename); Readln(Keytablename); Assign(keytable,keytablename); If length(keytablename)<1 then Running := false else Goto Retry ; End ; (* Warning *) End ; (* ReadKeytable *) (* ================================================================== *) (* Connection - Connect to the other computer and simulates *) (* a VT100 type terminal with Tek4010 graphics. *) (* *) (* ================================================================== *) Procedure Connection ; CONST us = #31; rs = #30; gs = #29; fs = #28; ff = #12; syn = #22; exclam = #33; VAR achar,bchar : byte ; i : integer ; LastX, LastY: INTEGER; HiY, LoY, HiX, LoX, NewX, NewY: INTEGER; TextColour: Integer; DrawMode: Boolean; Heapmark : ^WrkString ; (* -------------------------------------------------------- *) PROCEDURE InitGraph; BEGIN Mark(heapmark); InitGraphic; DefineWorld (1,0,779,1023,0); DefineWindow(1,0,0,xmaxglb,ymaxglb); SelectWorld(1); SelectWindow(1); SetWindowModeOn; DrawMode := True; END; PROCEDURE EndGraph; BEGIN Repeat Until Keypressed; LeaveGraphic; {clear graphics screen and return to text mode} DrawMode := False; Release(Heapmark); END; (* -------------------------------------------------------- *) PROCEDURE EscapeSequence (VAR ach:byte); CONST Percent = #37; Exclam = #33; ff = #12; sub = #26; VAR Xpos, Ypos : BYTE; Pn,Pc : byte ; Function PNumber (var achar : byte) : integer ; var Numstr : string[3]; Num,result : integer ; Begin (* PNumber *) Numstr := '' ; While chr(achar) in ['0'..'9'] do Begin (* get number *) Numstr := Numstr + chr(achar) ; If Readchar(achar) then ; End ; (* get number *) Val(Numstr,Num,Result); PNumber := Num ; End ; (* PNumber *) Begin (* Escape Sequence *) IF ReadChar(ach) THEN IF DrawMode THEN CASE chr(ach) OF sub: EndGraph; ff: BEGIN LeaveGraphic; DrawMode := False; END; {ff} END {case} ELSE {not drawmode, check system functions} CASE chr(achar) of (* First Level *) '[': If Readchar(achar) then CASE chr(achar) of (* Second level *) 'C': CursorRight ; 'D': CursorLeft ; 'J': ClrScr ; (* Erase End of Display *) 'K': ClrEol ; (* Erase End of Line *) '?': ; (* Special functions - not yet implemented *) 'H': GoToXY(0,0); (* Cursor Home *) 'm':(* NormVideo*) ; (* Exit all attribute modes *) else Begin (* Esc [ Pn x functions *) Pn := PNumber(achar); CASE chr(achar) of (* third level *) 'A': For i := 1 to Pn do Cursorup ; 'B': For i := 1 to Pn do Cursordown ; 'C': For i := 1 to Pn do CursorRight ; 'D': For i := 1 to Pn do CursorLeft ; ';': Begin (* Direct cursor addressing *) If readchar(achar) then ; Pc := PNumber (achar); GoToXY(Pc,Pn); End ; (* Direct cursor addressing *) 'q': FatCursor(Pn=1) ; 'm', '}': Case Pn of (* Field specs *) 0: begin (* Normal *) TextColor(LightGray); Textbackground(black); end ; 1: begin (* High Intensity *) TextColor(White); Textbackground(black); end ; 4: begin (* Underline *) TextColor(White); Textbackground(black); end ; 5: begin (* Blink *) TextColor(White+ blink); Textbackground(black); end ; 7: begin (* Reverse *) TextColor(Black); Textbackground(white); end ; 8: begin (* Invisible *) TextColor(Black); Textbackground(black); end ; 30: Textcolor(Black); 31: Textcolor(Red); 32: Textcolor(Green); 33: Textcolor(yellow); 34: Textcolor(Blue); 35: Textcolor(Magenta); 36: Textcolor(Cyan); 37: Textcolor(White); 40: Textbackground(Black); 41: Textbackground(Red); 42: Textbackground(Green); 43: Textbackground(Yellow); 44: Textbackground(Blue); 45: Textbackground(Magenta); 46: Textbackground(Cyan); 47: Textbackground(White); End ; (* case of Field specs *) 'J': Case Pn of 0: ClrScr ; 1: ClrScr ; (* clear to beginning *) 2: ClrScr ; End ; (* J - Pn Case *) 'K': Case Pn of 1: ClrEol ; (* clear to beginning *) 2: ClrEol ; (* clear line *) End ; (* J - Pn Case *) 'L': For i := 1 to Pn do InsLine ; (* Insert Line *) 'M': For i := 1 to Pn do DelLine ; (* Delete Line *) '@': For i := 1 to Pn do (* InsertChar *) ; 'P': For i := 1 to Pn do (* DeleteChar *) ; End ; (* Case third level *) End ; (* Esc [ Pn x functions *) End ; (* second level Case *) 'D': CursorDown ; (* Index *) 'M': CursorUp ; (* Reverse Index *) 'H': ; (* Set Tab Stop *) '(': ; (* G0 *) ')': ; (* G1 *) End ; (* First Level Case *) End ; (* Escape Sequence *) (* -------------------------------------------------------- *) PROCEDURE DrawVector (VAR ach:byte); CONST ParityBit = 127; BitCheck = 96; LoYBit = 96; LoXBit = 64; HiBit = 32; FiveBits = 31; ScaleX = 1.6; {tek4010 co-ordinates are 1024 x 780} ScaleY = 3.47; {scale into screen size 640 x 225 } us = #31; gs = #29; esc = #27; sub = #26; VAR XFlag, DrawFlag: BOOLEAN; CByte: Integer; ch: char; BEGIN XFlag := FALSE; DrawFlag := FALSE; ch := chr(ach); WHILE (ch <> us) and (ch <> esc) DO BEGIN IF ReadChar(ach) THEN BEGIN IF ch = gs THEN DrawFlag := False; ch := chr(ach); CByte := ord(ch) and ParityBit; {remove parity bit} IF (CByte and BitCheck) = HiBit THEN IF XFlag THEN HiX := CByte and FiveBits ELSE HiY := CByte and FiveBits ELSE IF (CByte and BitCheck) = LoYBit THEN BEGIN LoY := CByte and FiveBits; XFlag := TRUE; END ELSE IF (CByte and BitCheck) = LoXBit THEN BEGIN LoX := CByte and FiveBits; XFlag := FALSE; NewX := (HiX*32 + LoX); NewY := 779 - (HiY*32 + LoY); IF DrawFlag THEN DrawLine ( LastX, LastY, NewX, NewY) ELSE BEGIN SetColorBlack; DrawPoint( NewX, NewY); SetColorWhite; DrawFlag := TRUE; END; LastX := NewX; LastY := NewY; END; {IF} END; {IF} END; {while} END; {drawvector} PROCEDURE AlphaMode (VAR ach:byte); VAR I: INTEGER; Str: String[255]; BEGIN Str := ''; I := 1; IF ReadChar(ach) THEN WHILE (chr(ach) <> gs) and (I <= 255) and (ach <> esc) DO BEGIN Str := Str + chr(ach); I := I+1; IF ReadChar(ach) THEN END; {while} DrawTextW(LastX*1.0,LastY*1.0,1,Str); IF (chr(ach) = gs) and (not DrawMode) THEN InitGraph; IF (ach = esc) THEN EndGraph; END; {alphamode} (* -------------------------------------------------------- *) Procedure RemoteCommand ; Var i : integer ; Filename : Comstring ; Begin (* RemoteCommand procedure *) GotSOH := true ; If RecvPacket then Begin (* Got a Packet *) If InPacketType = Ord('S') then (* Send Packet *) Begin (* Receive *) (* writeln('Got a Send request'); *) Filename := '' ; RecvFile(filename); End (* Receive *) else If InPacketType = Ord('R') then (* Receive Packet *) Begin (* Receive *) (* writeln('Got a receive request '); *) for i := 1 to InCount-3 do filename[i] := chr(RecvData[i]); Filename[0] := chr(InCount-3) ; waitxon := XonXoff ; SendFile(filename); End (* Receive *) else If InPacketType = Ord('G') then (* General Packet *) Begin (* Receive *) (* writeln('Got a General request '); *) SendPacketType('Y'); End (* Receive *) else Begin (* Unknow packet Type *) OutCount := 15 ; Outseq := 0 ; OutPacketType := Ord('E'); (* SendData := 'Unknow Command'; *) End; (* Unknown packet Type *) End (* Got a Packet *) End ; (* RemoteCommand Procedure *) (* -------------------------------------------------------- *) Begin (* Connection *) DialModem ; RemoteScreen ; (* Save local screen, restore remote screen *) While KeyChar(achar,bchar) do ; (* Empty keyboard buffer *) HiY := 0; LoY := 0; HiX := 0; LoX := 0; LastX := 0; LastY := 0; DrawMode := False; While connected do Begin (* connected *) If RecvChar(achar) then if achar < $20 then Begin (* Control Character *) if achar = SOH then (* RemoteCommand *) else if achar = EOT then connected := false else if achar in [7,8,10,13] then write(chr(achar)) ELSE IF chr(achar) = gs THEN BEGIN IF not DrawMode THEN InitGraph; WHILE chr(achar) = gs DO BEGIN DrawVector(achar); IF achar = esc THEN EscapeSequence(achar) ELSE AlphaMode(achar); END; {while} END {if} ELSE IF chr(achar) = fs THEN DrawVector(achar) ELSE IF chr(achar) = syn THEN {ignore} ELSE IF achar = esc THEN EscapeSequence(achar) ELSE IF char(achar) = rs THEN EndGraph; {sas terminator} End (* Control Character *) else If achar <> DEL then write(chr(achar)); if KeyChar(achar,bchar) then Begin (* key input *) If ((achar=0) or (EscSeq[bchar,1]<>' ') or (EscSeq[bchar,2]<>' ') ) and (achar <> $09) then Begin (* Send escape sequence *) If EscSeq[Bchar,1]<>' ' then SendChar(Esc); If EscSeq[Bchar,1]<>' ' then SendChar(Ord(EscSeq[bchar,1])) ; If EscSeq[bchar,2]<>' ' then SendChar(Ord(EscSeq[bchar,2])) ; End (* Send Escape Sequence *) else Begin (* Normal Key *) if achar = LocalChar then connected := false else if achar = BreakChar then SendBreak else Sendchar(achar); if LocalEcho and connected then write(chr(achar)); End ; (* Normal Key *) End; (* key input *) End; (* connected *) LocalScreen ; (* save remote screen , restore local screen *) End ; (* Connection *) (* +FILE+ SETSHOW.PASMSCPM *) (* ================================================================== *) (* ShowOptions - Show Parameter Options setting for Kermit. *) (* *) (* ================================================================== *) Procedure ShowOptions ; Begin (* ShowOptions Procedure *) ClrScr ; (* Clear the Screen *) GotoXY(1,2); (* Start at line 2 *) Writeln(' QK-KERMIT version ',version,Gversion,' - ',Date); Writeln(' '); Writeln(' Current Setting Options '); Writeln('------------------- --------------------------------------'); Writeln('Baud Rate = ',Baudrate,' ( 300 600 1200 2400 4800 9600 19.2 )'); Write ('Parity = ') ; Case paritytype(parity) of OddP : write('Odd '); EvenP: write('Even '); MarkP: write('Mark '); NoneP: write('None '); end ; (* parity case *) Writeln(' ( Odd Even Mark None ) '); Write ('Duplex = '); If LocalEcho then Write('Half ') else Write('Full '); writeln(' ( Half Full ) '); Write ('Protocol = '); If Series1 then write('Series/1 ') else If XonXoff then write('Xon-Xoff ') else write('Standard '); writeln(' ( Xon-Xoff Series/1 Standard )'); Writeln(' '); Write ('Disk Drive = ',chr(DefaultDrive+$41),': ') ; writeln(' ( A: B: C: D: )'); Write ('Com Port = '); If PrimaryPort then Write('One ') else Write('Two '); writeln(' ( One Two ) ' ); Write ('Destination='); If ForPrinter then Write(' Printer ') else Write(' Disk '); writeln(' ( Disk Printer )'); Writeln(' '); If ParmFlag then Begin (* Display Packet Parameters *) Writeln('-------------------------------------------------------------'); Writeln('Packet Parameters'); Writeln(' Packetsize = ',Packetsize,' Timeout = ',Timeout:2,' *'); Writeln(' NumPad = ',NumPad:2,' PadChar = ',PadChar:2,' *'); Write (' Startchar = ',StartChar:2,' EndChar = ',EndChar:2); Writeln(' * use decimal values '); Write (' CntrlQuote = ',chr(CntrlQuote),' Bit8Quote = ',chr(Bit8quote)); Writeln(' | use character values '); Write (' CheckType = ',chr(CheckType),' RepChar = ',chr(RepChar)); Writeln(' | use NULL for null character )'); End ; (* Display Packet Parameters *) If logging then Begin writeln(' '); writeln(' Logging data to file ',LogName); end; End; (* ShowOptions Procedure *) (* ================================================================== *) (* SetOptions - Set Parameter Options setting for Kermit. *) (* *) (* ================================================================== *) Procedure SetOptions (var instring:comstring); Const OP1Table : String[40] = ' 300 600 1200 2400 4800 9600 19.2 '; OP2Table : String[30] = 'ODD EVEN MARK NONE HALF FULL '; OP3Table : String[40] = 'XON-XOFF SERIES/1 STANDARD ONE TWO '; OP4Table : String[40] = 'A: B: C: D: DISK PRINTER '; PP1Table : String[44] = ' PACKETSIZE TIMEOUT NUMPAD '; PP2Table : String[44] = 'PADCHAR STARTCHAR ENDCHAR CNTRLQUOTE '; PP3Table : String[33] = 'BIT8QUOTE CHECKTYPE REPCHAR ' ; Type Options = (zero,b300,b600,b1200,b2400,b4800,b9600,b19200, PO,PE,PM,PN,HALF,FULL, Xon,xon1,Series,ser1,Stand,stand1,one,two, A,B,C,D,Disk,Print,print1) ; PParms = (Pzero,Psize,PTime,PNumPad,PPadChar, PStartChar,PEndChar,PcntrlQuote,Pbit8Quote, PChecktype,PRepChar); Var Option : comstring ; OptionTable : String[255]; PParmTable : String[122]; Ix : integer ; ScanOptions : boolean ; Procedure SetValue ( var Pvalue : byte ); var I,Retcode : integer ; Begin (* Set Value *) Val(Gettoken(Instring),I,Retcode); If Retcode = 0 then Pvalue := I else Begin Writeln('>>> Invalid value specified <<<');Delay(2000);End; End ; (* Set Value *) Procedure SetChar ( var Pchar : byte ); Var atoken : string[10]; Begin (* set char *) Atoken := UpperCase(Gettoken(Instring)) ; If Atoken = 'NULL' then Pchar := 0 else If Length(Atoken) = 1 then Pchar := Ord(Atoken[1]) else Begin Writeln('>>> Invalid Specification <<<');delay(2000);End; End ; (* set char *) Begin (* SetOptions Procedure *) OptionTable := OP1Table + OP2Table + OP3Table + OP4Table ; PParmTable := PP1Table + PP2Table + PP3Table ; If length(instring)<1 then Begin (* Get Settings *) ShowOptions; Write ('Enter Option Setting >'); If audioflag then Begin Sound(1000); Delay(250); Sound(2000); Delay(50); Nosound;end; Readln(instring); End ; (* Get Settings *) ScanOptions := true ; While (length(instring)>0) and ScanOptions do Begin (* Parse instring *) Option := GetToken(instring); ScanOptions := Option<>';'; Option := Concat(' ',Uppercase(Option)); ix := Pos(Option,OptionTable) div 5 ; If ix <> 0 then Case Options(ix) of b300 : Baudrate := 300 ; b600 : Baudrate := 600 ; b1200 : Baudrate := 1200 ; b2400 : Baudrate := 2400 ; b4800 : Baudrate := 4800 ; b9600 : Baudrate := 9600 ; b19200 : Baudrate := 19200 ; PO : Parity := OddP ; PE : parity := EvenP ; PM : Parity := MarkP ; PN : parity := NoneP ; HALF : LocalEcho:= True ; FULL : LocalEcho:= False ; Xon : Begin XonXoff := True; Series1 := False; End; (* Series : Begin XonXoff := True; Series1 := True; End; *) Series : Begin XonXoff := False; Series1 := True; End; Stand : Begin XonXoff := False; Series1 := False; End; One : PrimaryPort := True ; Two : PrimaryPort := False ; A : SetDefaultDrive(0) ; B : SetDefaultDrive(1) ; C : SetDefaultDrive(2) ; D : SetDefaultDrive(3) ; Disk : ForPrinter := false ; Print : ForPrinter := true ; End (* case of options *) else Begin (* check packet parms *) ix := Pos(Option,PParmTable) div 11 ; If (ix <> 0) and ParmFlag then Case PParms(ix) of Psize: SetValue(Packetsize) ; PTime: SetValue(Timeout) ; PNumPad: SetValue(NumPad) ; PPadChar: SetValue(PadChar) ; PStartChar: SetValue(StartChar) ; PEndChar: SetValue(EndChar) ; PcntrlQuote: SetChar(CntrlQuote) ; Pbit8Quote: SetChar(Bit8Quote) ; PChecktype: SetChar(CheckType) ; PRepChar : SetChar(RepChar) ; End ; (* Case of PParms *) If chr(CheckType) in ['1','2','3'] then else CheckType := 49 ; End ; (* check packet parms *) ResetModem; Initmodem ; SetModem ; End ; (* Parse instring *) ShowOptions ; End ; (* SetOptions Procedure *) (* ================================================================== *) (* DisplayCommands - Display all the valid Kermit Commands. *) (* *) (* ================================================================== *) Procedure DisplayCommands; Begin (* DisplayCommands Procedure *) ClrScr ; Writeln(' The Following are the valid Kermit Commands :'); Writeln('---------------------------------------------------------------'); Writeln('CONNECT - connect to a remote host as a dumb terminal.'); Writeln(' '); Writeln('SEND AS RAW'); Writeln('RECEIVE AS REPLACE'); Writeln(' '); Writeln('SET - set option settings.'); Writeln('STATUS - display optional settings and status'); Writeln(' '); Writeln('DIRECTORY,ERASE,RENAME,TYPE,RUN - local commands'); Writeln('MKDIR,CHDIR,RMDIR - local commands'); Writeln('REMOTE - remote commands'); Writeln(' '); Writeln('LOG - Record data received in a log file.'); Writeln('TAKE - Take and execute commands from a file.'); Writeln('DEFINE - define a word to equal a string.'); Writeln('AUDIO,PARMS - toggle options .'); Writeln('QUIT - terminate local or remote kermit program.'); Writeln(' QuitOptions : LOCAL,REMOTE,DISCONnect,ALL'); Writeln(' '); Writeln(' Note: All parameters are optional and all commands maybe'); Writeln(' abbreviated to a minimum of unique characters.'); Writeln('---------------------------------------------------------------'); End; (* DisplayCommand Procedure *) (* +FILE+ LOCAL.PASMSCPM *) (* ----------------------------------------------------------------- *) (* DisplayDir - Displays the directory for the mask given in the *) (* input parameter string. *) (* ----------------------------------------------------------------- *) Procedure DisplayDir (Myfiles : Comstring) ; var filename : comstring ; column,row : integer ; Begin (* DisplayDir Procedure *) if (length(myfiles)<1) or (Myfiles[length(myfiles)] in ['\','/',':']) then myfiles := myfiles + '*.*'; Clrscr; If firstfile(myfiles,filename) then Begin (* found files *) writeln(' directory ',myfiles); write(filename); column := 21 ; row := 2; while nextfile(myfiles,filename) do begin (* list rest of files *) gotoxy(column,row); write (filename); column := column + 20 ; if column > 61 then begin row := row + 1 ; column := 1 ; end ; end ; (* list rest of files *) End (* found files *) else writeln(' no file found '); writeln(' '); DisplayDiskStatus ; End ; (* DisplayDir Procedure *) (* ----------------------------------------------------------------- *) (* EraseFiles - Erases a file or files from the disk. *) (* *) (* ----------------------------------------------------------------- *) Procedure EraseFiles (Myfiles : Comstring) ; var tempname : comstring ; tempfile : text ; column,row : integer ; Begin (* EraseFile Procedure *) While length(myfiles)<1 do Begin (* get file name *) write(' enter name of file to be erased > '); readln(myfiles); End ; If firstfile(myfiles,tempname) then Begin (* found files *) Clrscr; writeln(' Erasing file(s) ',myfiles); assign(tempfile,prefixof(myfiles)+tempname); erase(tempfile); write(tempname); column := 21 ; row := 2; while nextfile(myfiles,tempname) do begin (* list rest of files *) gotoxy(column,row); assign(tempfile,prefixof(myfiles)+tempname); erase(tempfile); write (tempname); column := column + 20 ; if column > 61 then begin row := row + 1 ; column := 1 ; end ; end ; (* list rest of files *) writeln(' '); writeln('The above file(s) have been erased. '); End (* found files *) else writeln(' no file found '); End; (* EraseFile *) (* ----------------------------------------------------------------- *) (* RenameFile - Remame a file. *) (* *) (* ----------------------------------------------------------------- *) Procedure RenameFile (Var Instring : Comstring) ; var oldnames,oldname,newname : comstring ; tempfile : text ; label exit ; Begin (* RenameFile Procedure *) If length(Instring)<1 then Begin (* get file name *) write(' Enter old file name > '); readln(Instring); End ; (* get file name *) If length(Instring)<1 then goto exit ; oldnames := uppercase(GetToken(instring)); newname := uppercase(GetToken(instring)); If length(newname)<1 then Begin (* get new file name *) write(' Enter new file name > '); readln(Instring); newname := uppercase(GetToken(instring)); End ; (* get new file name *) If firstfile(oldnames,oldname) then Begin (* found File *) assign(tempfile,prefixof(oldnames)+oldname); Rename(tempfile,newname); writeln(' '); writeln('File ',oldname, ' renamed to ',newname); End (* found File *) else writeln(' No file - ',oldname); exit: End; (* RenameFile *) (* ----------------------------------------------------------------- *) (* DisplayFile - display a file. *) (* *) (* ----------------------------------------------------------------- *) Procedure DisplayFile (Myfile : Comstring) ; var oldname,newname : comstring ; tempfile : text ; achar : char ; label exit ; Begin (* DisplayFile Procedure *) If length(Myfile)<1 then Begin (* get file name *) write(' Enter file name > '); readln(Myfile); End ; (* get file name *) If length(Myfile)<1 then goto exit ; Assign(tempfile,myfile); { $I- } Reset(tempfile); { $I+ } If IOResult = 0 then Begin (* found File *) Clrscr ; While not eof(tempfile) do begin (* Display file *) Read(tempfile,achar); Write(achar); end; (* Display file *) writeln(' '); End (* found File *) else writeln(' No file - ',Myfile); exit: End; (* DisplayFile *) (* +FILE+ REMOTE.PASMSCPM *) (* ----------------------------------------------------------------- *) (* RemoteProc - Remote procedure. *) (* ----------------------------------------------------------------- *) Procedure RemoteProc (var Instring : Comstring) ; Const Gsubtype : String[18] = 'CDEFHIJKLMPQRTUVW' ; TYPE RemoteCommandindex = ( rem_zero, rem_cwd, rem_directory, rem_erase, rem_finish, rem_help, rem_login, rem_journal, rem_copy, rem_logout, rem_message, rem_program, rem_query, rem_rename, rem_type, rem_usage, rem_variable, rem_who); Var ErrorMsg : comstring ; Rem_CommandTable : String[255] ; Rem_Command : comstring ; Index : integer ; Receiving : boolean ; Retries : integer ; j,CharCount,Bit8 : integer ; (* ----------------------------------------------------------------------- *) Procedure AddParmString ; Begin (* Add parms *) If length(instring) > 0 then Begin (* add parameter *) SendData[OutdataCount+1] := length(instring) + $20 ; For i := 1 to length(instring) do SendData[OutdataCount+1+i] := ord(instring[i]) ; OutdataCount := OutdataCount + length(instring) + 1 ; Instring := ''; End ; End ; (* Add parms *) (* *********************************************************************** *) Begin (* RemoteProc *) rem_commandtable := concat('bad ', 'CWD ', 'DIRECTORY ', 'ERASE ', 'FINISH ', 'HELP ', 'LOGIN ', 'JOURNAL ', 'COPY ', 'LOGOUT ', 'MESSAGE ', 'PROGRAM ', 'QUERY ', 'RENAME ', 'TYPE ', 'USAGE ', 'VARIABLE ', 'WHO ') ; rem_command := ' ' + Uppercase(GETTOKEN(instring)); if rem_command = ' HOST' then Begin (* Host Command *) End (* Host Command *) else Begin (* Generic Kermit Commands *) index := POS(rem_command,rem_commandtable) div 10 ; if index = 0 then Begin (* list commands *) Writeln (rem_command,' - Invalid REMOTE command. '); Writeln(' Valid REMOTE Commands are as follows: '); Writeln('CWD directory - Change Working Directory'); Writeln('DIRECTORY filespec - Directory '); Writeln('ERASE filespec - Erase (delete) a file '); Writeln('FINISH - Terminate Kermit server '); Writeln('HELP keywords - Help from server '); Writeln('LOGIN userid - Login '); Writeln('JOURNAL command - Transaction Logging '); Writeln('COPY filespec - Copy file '); Writeln('LOGOUT - Logout the remote host '); Writeln('MESSAGE destination - Message '); Writeln('PROGRAM program-name - Program execution '); Writeln('QUERY - Query server status '); Writeln('RENAME old-filespec - Rename file '); Writeln('TYPE filespec - Type (list) file '); Writeln('USAGE area - Disk Usage Query '); Writeln('VARIABLE command - Set or Query a Variable '); Writeln('WHO userid - Who is logged in '); End (* list commands *) else Begin (* Issue Remote command Request *) (* Send Init Packet *) OutPacketType := Ord('I'); PutInitPacket ; SendPacket ; STATE := R ; RECEIVING := TRUE ; BreakState := NoBreak ; RETRIES := 10 ; (* Up to 10 retries allowed. *) WHILE RECEIVING DO CASE STATE OF (* R ------ Initial receive State ------- *) (* Valid types - Y *) R : BEGIN (* Initial Receive State *) If ( Not RecvPacket) or (InPacketType=Ord('N')) then Resendit(10) else Begin (* Send Request *) If InPacketType=Ord('Y') then GetInitPacket ; If series1 then waitxon := false ; OutPacketType := Ord('G') ; SendData[1] := Ord(GSubtype[index]) ; OutDataCount := 1 ; OUTSEQ := OUTSEQ + 1 ; IF OUTSEQ >= 64 THEN OUTSEQ := 0; Case RemoteCommandIndex(index) of rem_zero: ; rem_cwd: Begin (* Change Working Directory *) AddParmString; Writeln (' Enter Password ') ; Readln(instring); AddParmString ; End ; (* Change Working Directory *) rem_directory: AddParmString; rem_erase: AddParmString; rem_finish: AddParmString; rem_help: AddParmString; rem_login: Begin (* Login *) AddParmString; Writeln (' Enter Password ') ; Readln(instring); AddParmString ; Writeln (' Enter Account Number ') ; Readln(instring); AddParmString ; End ; (* Login *) rem_journal: Begin (* Journal *) AddParmString; Writeln (' Enter Journal Argument ') ; Readln(instring); AddParmString ; End ; (* Jounral *) rem_copy: Begin (* Copy file *) AddParmString; Writeln (' Enter destination ') ; Readln(instring); AddParmString ; End ; (* Copy file *) rem_logout: AddparmString; rem_message: Begin (* Message *) AddParmString; Writeln (' Enter Message text ') ; Readln(instring); AddParmString ; End ; (* Message *) rem_program: Begin (* Program *) AddParmString; Writeln (' Enter Program commands ') ; Readln(instring); AddParmString ; End ; (* Program *) rem_query: ; rem_rename: Begin (* Rename file *) AddParmString; Writeln (' Enter New Name ') ; Readln(instring); AddParmString ; End ; (* Rename file *) rem_type: AddParmString; rem_usage: AddParmString; rem_variable: Begin (* Variable *) AddParmString; Writeln (' Enter First Argument ') ; Readln(instring); AddParmString ; Writeln (' Enter Second Argument ') ; Readln(instring); AddParmString ; End ; (* Variable *) rem_who: Begin (* Who *) AddParmString; Writeln (' Enter Options ') ; Readln(instring); AddParmString ; End ; (* Who *) End ; (* Case *) SendPacket ; STATE := RF ; End ; (* Send Request *) END ; (* Initial Receive State *) (* RF ----- Receive Filename State ------- *) (* Valid received msg type : S,Z,F,B *) RF: IF (NOT RECVPACKET) OR (InPacketType=Ord('N')) then ReSendit(10) else (* Get a packet *) IF (InPacketType = Ord('Y')) or (InPacketType=Ord('E')) then BEGIN (* Got simple reply *) For i := 1 to InDataCount do Write(Chr(RecvData[i])) ; Writeln(' '); RECEIVING := false END (* Got simple reply *) else IF InPacketType = Ord('S') then Begin GetInitPacket; PutInitPacket; SendPacket; End else IF (InPacketType = Ord('X')) or (InPacketType = Ord('F')) then BEGIN (* Got file header *) For i := 1 to InDataCount do Write(Chr(RecvData[i])) ; Writeln(' '); STATE := RD ; SendPacketType('Y'); END (* Got file header *) else BEGIN (* Not S,F,B,Z packet *) STATE := A ; (* ABORT if not a S,F,B,Z type packet *) ABORT := NOT_SFBZ ; END ; (* Not S,F,B,Z packet *) (* RD ----- Receive Data State ------- *) (* Valid received msg type : D,Z *) RD: IF (NOT RECVPACKET) OR (InPacketType=Ord('N')) then ReSendit(10) else (* Got a good packet *) IF InPacketType = Ord('D') then BEGIN (* Receive data *) (* WRITELN ('RECEIVE data '); *) I := 1 ; WHILE I <= InDataCount DO BEGIN (* Write Data to file *) IF RecvData[I] = RepChar then BEGIN (* Repeat char *) I := I+1 ; charcount := RecvData[I] - 32 ; I := I + 1 ; For j := 1 to charcount - 1 do Write(Chr(RecvData[i])); END ; (* Repeat char *) IF RecvData[I] = Bit8Quote then BEGIN (* 8TH BIT QUOTING *) I := I+1 ; BIT8 := $80 ; END (* 8TH BIT QUOTING *) else BIT8 := 0 ; IF RecvData[I] = CntrlQuote then BEGIN (* CONTROL character *) I := I+1 ; IF RecvData[I] = $3F then (* Make it a del *) RecvData[I] := $7F else IF RecvData[I] >= 64 then (* Make it a control *) RecvData[I] := RecvData[I] - 64 ; END ; (* CONTROL character *) RecvData[I] := RecvData[I] + BIT8 ; Write(Chr(RecvData[i])) ; I := I + 1 ; END ; (* Write Data to File *) Case Breakstate of NoBreak : SendPacketType('Y'); BC : RECEIVING:=false ; BE : SendPacketType('N') ; BX : BreakAck('X') ; BZ : BreakAck('Z') ; End; (* Case BreakState *) END (* Receive data *) else IF (InPacketType = Ord('F')) or (InPacketType=Ord('X')) then BEGIN (* repeat *) OutSeq := OutSeq - 1 ; SendPacketType('Y') ; END (* repeat *) else IF InPacketType = Ord('Z') then SendPacketType('Y') else IF InPacketType = Ord('B') then Receiving := False else BEGIN (* Not D,Z packet *) STATE := A; (* ABORT - Type not D,Z, *) ABORT := NOT_DZ ; END ; (* Not D,Z packet *) (* C ----- COMPLETED State ------- *) C: BEGIN (* COMPLETED Receiving *) SendPacketType('Y'); RECEIVING := FALSE ; END ; (* COMPLETED Receiving *) (* A ----- A B O R T State ------- *) A: BEGIN (* Abort Sending *) RECEIVING := FALSE ; (* SEND ERROR packet *) OutSeq := 0 ; ErrorMsg :=' Abort while receiving data' ; OutDataCount := length(ErrorMsg); for i := 1 to length(ErrorMsg) do SendData[i] := Ord(ErrorMsg[i]) ; OutPacketType := Ord('E'); SENDPACKET ; END ; (* Abort Sending *) END ; (* CASE of STATE *) End ; (* Issue Remote command Request *) End ; (* Generic Kermit Commands *) End ; (* RemoteProc *) (* +FILE+ MISCCOMM.PASMSCPM *) (* ================================================================== *) (* LOGIT - creates a Log file to record all incoming data from the *) (* remote line. *) (* The file name is specified in the Parameter . *) (* if no parameter specified logging is turned off. *) (* ================================================================== *) Procedure Logit (filename : comstring); Begin (* Logit Procedure *) If (length(filename) < 3) or (filename='OFF') then Begin (* Turn off Logging *) Logging := false ; Close (Logfile); Writeln (' Logging is turned off '); End (* Turn off Logging *) else Begin (* Turn on Logging *) If Logging then Close (Logfile); Logging := True ; Assign(Logfile,Filename); Rewrite(Logfile); Writeln(' Logging data to file ',filename); LogName := filename ; End ; (* Turn on Logging *) End ; (* Logit Procedure) (* ================================================================== *) (* Takeit - read commands from a file and executes them. *) (* if no file specified or file is not there if does nothing *) (* ================================================================== *) Procedure Takeit (filename : comstring); Begin (* Takeit Procedure *) If length(filename) > 1 then If Firstfile(filename,dummy) then Begin (* Active file *) Writeln ('Activating Command file ',filename); ActiveCommandfile := true ; Assign(Commandfile,filename); Reset(Commandfile); End (* Active file *) else Writeln('No file ',filename) ; End ; (* Takeit Procedure) (* ================================================================== *) (* QuitExit - Terminates the KERMIT. *) (* the QuitOptions are: *) (* LOCAL,REMOTE,DISCONnect,ALL *) (* if LOCAL or noparms only the local kermit terminates.*) (* if REMOTE then only the remote kermit terminates. *) (* if DISCONect then the remote kermit is terminated *) (* and the remote is logged off. *) (* if ALL then both kermits are terminated and remote *) (* is logged off. *) (* *) (* ================================================================== *) Procedure QuitExit (QuitOption : comstring); Const QuitTable : String[35] = ' LOCAL REMOTE DISCON ALL ' ; Type QuitType = (zero,local,remote,discon,all); Var Qix : integer ; Begin (* QuitExit Procedure *) QuitOption := Uppercase(Concat(' ',QuitOption)); Qix := Pos(QuitOption,QuitTable) div 7 ; Case QuitType(Qix) of (* Quit Type *) zero, local: Running := false ; remote : Begin (* terminate remote kermit *) (* Send a Finish packet *) OutDataCount := 1 ; OutSeq := OutSeq + 1 ; If OutSeq > 64 then OutSeq := 0 ; OutPacketType := Ord('G'); SendData[1] := Ord('F'); WaitXon := False ; SendPacket ; If RecvPacket and (InPacketType = Ord('Y')) then Writeln (' Remote Kermit terminated. ') else Writeln(' Unable to terminate Remote Kermit. '); End ; (* terminate remote kermit *) discon, all: Begin (* logoff Remote *) (* Send a Logoff packet *) OutDataCount := 1 ; OutSeq := OutSeq + 1 ; If OutSeq > 64 then OutSeq := 0 ; OutPacketType := Ord('G'); SendData[1] := Ord('L'); WaitXon := false ; SendPacket ; If RecvPacket and (InPacketType = Ord('Y')) then Writeln (' Remote host is logging off ') else Writeln(' Remote host unable to execute a log off '); If (Qix = Ord(all)) then Running := False ; End; (* Logoff Remote *) End ; (* Case Quit Type *) End; (* QuitExit Procedure *) (* +FILE+ TYPEDEF.PASDUMMY *) (* TYPEDEF.SYS - Dummy Include file for non-graphics terminal simulation *) (* +FILE+ GRAPHIX.PASDUMMY *) (* GRAPHIX.SYS - Dummy Include file for non-graphics terminal simulation *) (* +FILE+ KERNEL.PASDUMMY *) (* KERNEL.SYS - Dummy Include file for non-graphics terminal simulation *) (* +END-OF-FILES+ *)