ftn7x,s program kermit(6,49) ,<890525.1144> >File transfer utility implicit none ! HP-1000 KERMIT main program ! ! rev date reason.......................................... ! 1.98a 23Jul86 First release to CUCCA (supersedes all previous) ! 1.98b 06Aug86 receive/get with rename lost DS info in mask ! >>> Released to Interex Detroit swap tape ! 1.98c 09Oct86 Repaired checksum-type parameter-return [recpar] ! 1.99 10Apr87 New CONNECT removes mux lockups; altered CONTROL ! and SLEEP routine to go with new CONNECT. A lot ! of reorganization, moving system-dependent code ! to KxSUBS (x=A or 6 for RTE-A or RTE-6). This ! makes KERMIT a transportable program! ! 1.99a 14Jul87 Fix in GetMux (KASUBS) for tracking down the DVT ! address (near statement label 10). Several fixes ! for compatibility with RTE revision 5.0. ! 1.99b 16Oct87 Fix in ReportFileError to load 3rd segment before ! calling SndErr; fix in Connect to (hopefully) let ! B- and C-mux terminal-emulation work under RTE-A. ! 1.99c Jun '88 More fixing to Connect - it is now tested with a ! 12040D and 12040C, and with a 12792C. Hopefully ! this is the last I need to hear about this! ! >>> Released to Interex 2830 CSL tape ! 1.99d May '89 Fix in RINIT to properly handle timeout. Now ! supports "D" mux on both RTE-A and RTE-6! ! >>> Released to CUCCA in Dec. '89 ! ! Permission is granted to any individual or institution to copy ! or use this program, except for explicitly commerical purpose. ! ! RTE-6/VM KERMIT was originally implemented by John Lee, of ! RCA Laboratories 6/29/84. ! ! Heavily modified by Paul Schumann at E-Systems, Inc. beginning ! 11/09/84 for a "full" implementation of KERMIT, including local- ! host mode, server operation, and hierarchical file access, on ! both RTE-6 and RTE-A. ! ! Installation instructions: ! ! KERMIT is designed to work on both RTE-6 and RTE-A systems from ! the C.83 revision (first appearance of CI file space) or later. ! In order to minimize the installation time, all of the system- ! dependent code has been moved to K6SUBS.FTN (for RTE-6/VM) or ! KASUBS.FTN (for RTE-A); the link command-file KERMIT.LOD will ! select the appropriate routines when you link. ! ! NOTE: the KERMIT relocatables you received are already set for ! any system revision from A.84 to 4.1. If you are actually ! using a C.83 system, you must edit KERCOM.ftni and change ! the "SysRev" parameter to any value less than 2440, then ! recompile KERMIT. It should not be necessary to recompile ! KASUBS or K6SUBS. Failure to do this will result in an ! undefined external reference to FTRAP. If you force-load ! KERMIT, you will be told to make the change just described, ! and then KERMIT will abort. ! ! Link KERMIT using the supplied KERMIT.LOD. Undefined external ! references (except for FTRAP - see above) are caused by failure ! to use the correct KERMIT library file (KASUBS or K6SUBS) or be- ! cause your system is simply too old (before C.83). ! ! Copy KERMIT.HLP to the /SYSTEM or /KERMIT directory, or if you ! have no CI space, copy it as "KERMI to any FMGR space. This ! file is generated by running the RTE-6 GENIX utility against ! the KERMIT.TEXT file, which is user-editable. You need not ! rebuild KERMIT.HLP if you have not altered KERMIT.TEXT. ! ! Paul Schumann ! E-Systems, Inc. ! PO Box 1056 CBN 148 ! Greenville, TX 75401 ! (214) 457-5358 ! ! A note on the programming style... ! I use IMPLICIT NONE in order to protect myself from typos ! (I am a terrible typist); obviously this means that I must ! define all symbols before I use them. I have attempted as ! much as possible to make the symbol names self-documenting, ! but I don't LIKE to type either, so I use very short names ! which I prefixed as follows: ! fiXx is a variable pertaining to the current file being ! sent or received ! dbXx is a variable pertaining to some debugging ! cmXx is a variable pertaining to the command line ! fXxx is a logical flag of some type ! ! I firmly adhere to the concept of "data hiding" as a tool to improve ! software reliability: a module cannot change a variable if it has no ! access to it. I have a number of common blocks with separate include ! files so that a routine which needs access to control variables but ! which needs no access to file variables can have exactly that access. ! Would-be KERMIT modifiers should keep this in mind before they decide ! to re-combine the common include-files. (It also improves compiler ! speed when FTN7X doesn't need to keep up with a lot of unused symbol ! names!) ! ! In the interest of saving paper, the complete listings of all common ! blocks appear only in the block-data routine. I regret any problems ! this may cause. ! ! The following is a definition of ALL variables in /KER/, the ! main control common block for KERMIT-RTE. Variables are defined ! in storage order (for cross-referencing to /KER/ itself). The ! numbers in parentheses after a variable name (if any) give the ! storage allocation in 16-bit words; if absent, assume 1 word. ! ! SysRev(0) - the highest system revision-code expected by this ! KERMIT version ! Delay - # of seconds waited before sending out the first ! SINIT packet (only in remote mode). ! EOL - End of line delimiter required by other KERMITS. ! EsChar - The character used to return back to command mode ! from CONNECT. ! L - Local TTY channel (to which the user is logged) ! ImxTry - Maximum number of retries/packet before giving up on ! start-up of a [group] file-transfer ! MaxTry - maximum number of retries/packet before giving up on ! any packet once transfers are already under way ! R - Remote TTY channel (to which user is NEVER logged) ! This is also the local channel if KERMIT is in ! remote-host mode. ! p - a general-purpose byte pointer variable; used by ! pPutc and its callers in building a packet ! rlen - The data length of the last packet received ! Seq - The sequence number of the current packet ! Class - The class# to use during CONNECT mode. ! slen - The data size of the next packet to send ! trCb(144) - Transfer-file control block ! fePath - An assigned label. If a file error of some kind ! occurs, execution will continue at (fePath) after ! the error is processed. Only the KERMIT main and ! the SERVER subroutine should ever change fePath! ! sPcnt - The number of parameters the other KERMIT sent me. ! (Some KERMITs don't like to see more parameters than ! they sent out, notably an older IBM-PC version...) ! Parity - The parity of the remote line: ! 1 = Even 2 = Mark 3 = None ! 4 = Odd 5 = Space ! My packet parameters follow: ! PakSiz - The maximum packet size I want to receive ! Timeout - Time (sec) the other KERMIT should wait for me to ! - send a packet (0 means wait forever) ! nPad - The # of pad characters I require (I require none) ! EOLch - The terminator I require at the end of each packet; ! - this is hard-coded to 13 (carriage-return)! ! Quote - The character I must see before control characters ! Bit8 - The character I must get if the next data byte is ! to have its 8th bit set ! ChkTyp - the checksum type I want to receive on packets ! Repc - The character which tells me a repeat-count follows ! capas(2) - My capabilities bits (I can do time-out; I accept ! server commands; I can send/receive attribute packets) ! Sync - the character with which my incoming packets start ! My partner's packet parameters follow: ! sPkSiz - the maximum packet size I am allowed to send ! sTime - Time (sec) I will wait for a packet from my partner ! (0 means wait forever) ! sPad - The number of pad characters my partner needs ! sPadch - The character my partner wants for padding ! sEOL - My partner's packet-terminator character ! sQuote - The character I must put before control characters ! sBit8 - The character I must send before sending a character ! - whose 8th-bit is set ! sCheck - My partner's checksum type ! sRepc - The character my partner will use before repeat counts ! sCapas(2) - My partner's capability bits ! sSync - The character I must send as the start of a packet ! Assorted flags follow ! fWarn - True if file-overwrite warning is desired ! fIBM - True if talking to a CMS KERMIT, false otherwise ! If true, I must wait for a DC1 (XON or ^Q) before I ! can send anything. Additionally, if I am CONNECTed, ! I will locally echo keystrokes. ! fServ - True if in server mode, false otherwise ! fTrans - True if commands are coming from a transfer-file ! fBit8 - True if I am doing 8th-bit quoting ! fRepc - True if I am doing repeat-count prefixing ! fPkIO - True if I am doing packet-I/O ! fSend - True if sending a file; false if receiving a file ! (valid only during file-transfers) ! f8OK - True if 8th-bit quoting is enabled ! String things follow ! HlpNam(32) - the file-descriptor for KERMIT's help file ! Packet(50) - A character array which holds the outgoing packet ! RecPkt(128) - A character array which holds the incoming packet ! pData(48) - A character array for the data part of a packet ! state - The current file-transfer state ! ErrMsg(36) - Text of most recent error-message (SndErr takes ! the error-packet text from this variable!) ! Prompt(10) - The string used as a command-prompt ! Other labeled common areas: ! /KCMNDS/ forms KERMIT-RTE's vocabulary ! /KERCMD/ holds the current command-line & parameters ! /KERCNF/ holds configuration info for the system and for the ! two LUs KERMIT is currently using ! /KERDBG/ holds (self) debugging parameters ! /KERFIL/ holds control parameters for the file being sent or ! received currently. ! /KERSTA/ holds file-transfer statistical information ! WARNING -- KERMIT uses "unusual" techniques in order to keep a large ! program comfortably within the address space, while maintaining ! the functionality. These are: ! 1) 'ASSIGN nn to fePath' appears in KERMIT's main program only. ! "fePath" is a variable in KERCOM which is used only by the ! file-error reporting routine, ReportFileError, to return to ! the main quickly without propagating an error-code through ! the subroutine call-chain. WARNING: this usage alone makes ! KERMIT unfit for Code and Data Separation (CDS), although ! there is a CDS-compatible method which performs the same job. ! 2) KERMIT is segmented in an unusual way: all modules in the ! segments (except for the "segment header") are subroutines or ! functions that are called FROM SOME PART OF THE MAIN! This ! method was used to reduce KERMIT (1.97 and previous revisions) ! from 31 pages (under RTE-A) to 24 before the RUn command was ! added. This "feature" makes KERMIT unfit for LOADR; you must ! use LINK. (Actually, there is a method by which LOADR can be ! made to load this KERMIT, but it involves splitting the object ! files at segment boundaries -- it isn't worth the trouble!) ! ! If you find bugs in KERMIT, please let me know! I can advise you ! in the most expedient wat to fix them, as well as fix them for ! other KERMIT users. If you contemplate extending the capabilities ! of this KERMIT, be sure you understand the segmenting method. A ! few guidelines are: ! a) If it is already in the main, don't move it to any of ! the segments, or you'll probably lose return addresses! ! b) If it parses an interactive command, at least some of it ! must be in K1CMD's (command processing) segment. ! c) If it deals ONLY with communicating to the other end ! (file-transfers or server), it >>probably<< belongs in ! K3XFR's (packet-transfer) segment. ! d) K2MSK's segment may appear the smallest in terms of the ! number of source lines, but all of the file-masking code ! loads there. It is still the smallest segment, but it's ! unlikely that any more useful code could be put there. ! e) If it may be called from 2 or more segments, and all ! calls it makes are to the system or other modules in ! the main only, it >>probably<< belongs in the main. ! ! I apologize in advance for any problems this may cause the reader. include kercom.ftni,NOLIST include kercmd.ftni,NOLIST integer*2 loglu,junk logical*2 succeed,send,receive L = loglu(junk) !Get user's I/O channel do junk = 3,1,-1 !Insure all segments load call LoadSeg(junk) !...ending with command-processor end do ! K1CMD performs initialization code on 1st entry only. assign 10 to fePath !Set File-error path ! The following infinite loop is terminated by ! a) An exit-type command if interactive ! b) A finish-type command if serving 10 if ( fServ ) then !Serving? call LoadSeg(3) $ call Server !Yes - Server never returns else call LoadSeg(1) $ Call Command !No - do interactive commands endif ! A command requiring packet-I/O is ready to execute call LoadSeg(3) $ call PakIO !Prepare for packet-I/O if (cmTk .eq. 'BYE') then call Bye else if (cmTk .eq. 'FINISH') then call Finish else if (cmTk .eq. 'GET') then call Get else if (cmTk .eq. 'RECEIVE') then succeed = receive('R') call success(succeed) else if (cmTk .eq. 'SEND') then if (L .eq. R) call sleep(delay) succeed = send() call success(succeed) endif cmCh = ' ' $ call NrmIO $ goto 10 !Get something else to do end Subroutine LoadSeg(SegNum) ,<890525.1144> >Overlay loader implicit none include kercom.ftni,NOLIST integer*2 SegNum,err,segn(3) character*6 cSegNam,SegNames(3) equivalence (cSegNam,segn) data SegNames /'K1CMD ','K2MSK ','K3XFR '/ if (segnum .eq. seg) return !Segment is already loaded cSegNam = SegNames(SegNum) call SegLd(segn,err) !Try to load the segment if (err .ne. 0) then !Did it load (and return)? call tpI2('Segment-Loader error _',err,0) call tpCh(' on -',cSegNam) stop 'aborting with segment-load problems' endif return end Subroutine tPrint ,<890525.1144> >Term-print mini-formatter implicit none include kercom.ftni,NOLIST !To define "L" ! Define the names of all entry parameters integer*2 i2Var !Integer*2 variable to print integer*4 i4Var !Integer*4 variable to print integer*2 iflen !length of the integer field character*(*) chFmt !"format" string to print character*(*) chVar !character variable to print integer*2 tp,ioBuf(129),TrimLen,xl(2),cw logical*2 fReady !True when string ready to print integer*4 w4,mul character*20 IntToDecimal,DintToDecimal,chWk,jRight character chBuf*258 equivalence (ioBuf,chBuf) data tp /1/ !IO-buffer starts at byte# 1 data cw /0/ !No control bits on the LU c Formatting rules: c If a "format" ends with an underscore ("_") then the string c being built will not be printed on this call, but the c format string will be put in the I/O buffer without it. c If a "format" ends with a dash ("-") then the string being c built will be printed without it. This allows trailing c blanks to be put in the format which would otherwise be c deleted. c The field length parameter is given as the number of digits c allowed for the formatted number if right-justification c is desired. If the field length is positive, blanks are c padded on the left as needed; if negative, zeroes are c padded on the left. If the field length is zero, the c number will be printed left-justified. c If the number being formatted occupies more characters in the c string than the field-length, the number will display as c (iflen) stars (just like the formatter!). c A maximum of 257 characters may ever be printed at one time. entry tpFm(chFmt) !Append a format only call CopyMore(chFmt,chBuf,tp,fReady) goto 10 entry tpI2(chFmt,i2Var,ifLen) !Append format and I*2 number call CopyMore(chFmt,chBuf,tp,fReady) chWk = jRight(IntToDecimal(i2var),iflen) chBuf(tp:) = chWk !Copy in the number tp = tp + TrimLen(chWk) !Adjust the pointer goto 10 entry tpI4(chFmt,i4Var,ifLen) !Append format and I*4 number call CopyMore(chFmt,chBuf,tp,fReady) chWk = jRight(DintToDecimal(i4Var),iflen) chBuf(tp:) = chWk tp = tp + TrimLen(chWk) goto 10 entry tpCh(chFmt,chVar,ifLen) !Append format and string call CopyMore(chFmt,chBuf,tp,fReady) chBuf(tp:) = chVar if (ifLen .gt. 0) then !Was a field-size given tp = tp + ifLen !Yes - "truncate" at that size else tp = tp + TrimLen(chVar) !No - use all but trailing blanks endif 10 tp = min(tp,258) !Don't overflow the string if (fReady) then !If string is ready to print... xl = L !Set LU in XLUEX control words call xluex(2,xl,iobuf,1-tp) !...print it tp = 1 !...and reset the pointer endif return end subroutine CopyMore(frm,dest,tp,fdone) ,<890525.1144> >do "formats" implicit none character*(*) frm,dest integer*2 tp logical*2 fdone integer*2 i,TrimLen i = TrimLen(frm) !Where does the format end? if (frm(i:i) .eq. '_') then !Are we finishing the buffer? fdone = .false. !No - flag it to caller i = i - 1 !Don't copy continue flag to buf else fdone = .true. if (frm(i:i) .eq. '-') i=i-1 !Remove trailing-blanks flag endif if (i .gt. 0) then !Anything to copy? dest(tp:) = frm(:i) !Copy the correct part tp = tp + i !adjust the pointer tp = min(tp,258) endif return end character*20 function jRight(chNum,flen) ,<890525.1144> >do "Ix" formats implicit none character*(*) chNum integer*2 flen integer*2 i,ilen,TrimLen character*20 stars,blanks,zeroes data stars /'********************'/ data blanks /' '/ data zeroes /'00000000000000000000'/ ilen = iabs(flen) if (ilen .gt. 20) then call quit stop 'I-field length > 20 (jRight)' endif i = TrimLen(chNum) !How big is the number if (ilen .ne. 0) then !Was a field-length given? if (i .gt. ilen) then !Yes - will the number fit? jRight = stars(:ilen) !No - replace number with stars else if (i .lt. ilen) then i = ilen - i !fits ok; get # of fill bytes if (flen .lt. 0) then !Doing zero or blank fill? jRight = zeroes(:i) // chNum else jRight = blanks(:i) // chNum endif else jRight = chNum !exact fit endif else jRight = chNum !Else no formatting requested endif return end subroutine FtnTrap(abreg,preg) ,<890525.1144> >Trap FORTRAN errors implicit none include kercom.ftni,NOLIST include kerdbg.ftni,NOLIST integer*2 abreg(2),preg(2),abcod(3) character ecode*6, addr*8, IntToDecimal*6, IntToOctal*6 equivalence (abcod,ecode) ! If KERMIT incurs a FORTRAN error, it will most likely be a type-2 ! (always fatal) error. The point of this routine is to insure the ! restoration of all MUX configurations and file-closure should the ! "impossible" happen. In fact, the most likely error will be from ! a string routine. On completion of it's task, FtnTrap allows the ! standard "runtime error" termination to occur. addr = IntToOctal(preg)//'/'//char(seg+48) !Format error addr/seg# if (abreg .lt. 20000b) then !Group-2 error? ecode = IntToDecimal(abreg) !Yes - format the number else abcod = abreg !Copy Group-1/-3 error to the abcod(2) = abreg(2) !message abcod(3) = 2h !Clear the end of the message endif ErrMsg = 'Runtime error ' // ecode // ' @' // addr call kdebug(all,ErrMsg,' ') !Try to log the error call LoadSeg(3) $ Call SndErr !Do error-packet if in transfer call quit !Clean myself up return !allow me to abort end subroutine kdebug(type,header,info) ,<890525.1144> >Do KERMIT debug logging implicit none include kerdbg.ftni,NOLIST integer*2 type character*(*) header,info integer*2 LogBf,TrimLen,err character*150 LogCh equivalence (LogCh,LogBf) c This routine performs the debug logging requested by KERMIT's c user. If debug logging of (type=STATES, PACKET, or ALL) is c enabled and logging is not suspended, then (header) and (info) c are concatenated into a log record and written to the log file. if (dbLv .lt. 1) return !No debugging is active if (iand(type,dbLv) .ne. 0) then !Logging this type of stuff? LogCh = ' ' // header // info !Yes - form the record call FmpWrite(dbCb,err,LogBf,TrimLen(LogCh)) !...& write it call FmpPost(dbCb,err) endif !IGNORE file-write errors! return end subroutine quit ,<890525.1144> >Terminate KERMIT cleanly implicit none include kerfil.ftni,NOLIST !Defines fiCB and maCB include kercom.ftni,NOLIST !Defines trCB, R, and L include kercnf.ftni,NOLIST !Defines fRmx and fLmx include kerdbg.ftni,NOLIST !Defines dbCB integer*2 junk call FmpClose(fiCB,junk) call FmpClose(dbCB,junk) call FmpClose(trCB,junk) call FmpEndMask(maCb) !The next line is an attempt to prevent both ends of a CPU-CPU !link from trying (and always failing) to log each other on. !Hopefully, 5 seconds is enough time for logout- or program- !termination activity to stop before this side's interrupts !get re-enabled. if (R .ne. L) then call sleep(500) call restore(L) !Restore local configuration call enable(L,fLmx) !...and interrupt-scheduling endif call restore(R) !Restore remote configuration call enable(R,fRmx) !Restore remote interrupt-sched call lurq(100000b) !Release any locks I've done return end real*4 function control(lu,fcn,param) ,<890525.1144> >Perform control calls implicit none real*4 rstat integer*2 lu,fcn,param,xl(2),cw equivalence (xl(2),cw),(xl,rstat) ! While this routine is >never< actually called as a function, we define ! it as such so that ABReg will work to return the status of the control ! request to the caller (as used by connect). xl = lu cw = fcn call xluex(3,xl,param) !Perform the control function call abreg(xl,cw) !get the status of the request control = rstat !Return it to the caller return end subroutine ReportFileError(err,nam) ,<890525.1144> >Report file errors implicit none c Since it is the nature of this routine to never return to its c caller, we will ALWAYS close the current file (being sent or c received) as well as terminating any masked-/indirect-search c operation in progress include kercom.ftni,NOLIST include kercmd.ftni,NOLIST include kerdbg.ftni,NOLIST include kerfil.ftni,NOLIST integer*2 err,j,TrimLen character*(*) nam cmCh = ' ' !Clear the current command call FmpError(err,ErrMsg) !Decode the error-number j = TrimLen(ErrMsg) + 1 !Find the end of the text if (TrimLen(nam) .gt. 0) then ErrMsg(j:) = ': ' // nam !Tack on the file-name endif call FmpClose(fiCb,err) !Shut down file/mask operations call FmpEndMask(maCb) call kdebug(all,ErrMsg,' ') !Log the error-message (debug) call LoadSeg(3) $ Call SndErr !If in packet-I/O, do error-pkt if (R.eq.L .and. .not. fServ) then call NrmIO !Restore "local" in remote-host endif goto fePath !Return to KERMIT MAIN PROGRAM end subroutine Server ,<890525.1144> >Be a KERMIT Server implicit none c The only way out of this, once begun, is to receive a FINISH or c BYE command from the other KERMIT. include kercom.ftni,NOLIST include kercnf.ftni,NOLIST !Defines fRmx include kerdbg.ftni,NOLIST include kerfil.ftni,NOLIST integer*2 len,num logical*2 receive,send character*1 pt,RecPack 10 call Set_Timeout(R,9000,fRmx) !Do 90-second server timeout sCheck = 1 !Server commands use 1-byte checks call LoadSeg(3) !Insure file-xfr subs are callable call PakIO !Set flags for packet-I/O pt = RecPack(len,num) !Get a command packet if (pt.eq.'S' .or. pt.eq.'I') then !Send file or initialize? seq = num !Yes - make seq# agree fSend = .false. !Do param-stuff like a receive call RecPar(len) !Get partner's parameters if (fBnry .and. Parity.ne.3 .and. .not.fBit8) then ErrMsg = 'Can''t receive binary file (parity problem)' call SndErr fBnry = .false. goto 10 endif if (pt .eq. 'I') call doIpacket !Change my params to remote's vals call SndPar('Y',seq) !...and send mine if (pt .eq. 'S') then !Actually send a file? sCheck = NewChk !OK to change checksum type now first = .true. !Allow LEGALIZE to process RMASK mask = rmask !Set the receive mask seq = mod(seq+1,64) if (receive('F')) then call kdebug(all,'Server receive completed',' ') else call kdebug(all,'Server receive failed',' ') endif endif else if (pt .eq. 'R') then !Send file(s)? first = .true. !Prepare to do file masking fiNm = ' ' !Clear old file name mask = RecPkt(5:len+4) !Get the file mask if (send()) then call kdebug(all,'Server send completed',' ') else call kdebug(all,'Server send failed',' ') endif else if (pt .eq. 'G') then !Generic command? pt = RecPkt(5:5) !Get the data field if (pt .eq. 'F') then !Finish? call SndPack('Y',num,0) !Yes - acknowledge it call quit !Turn off everything call exec(6) !...and stop else if (pt .eq. 'L') then !Bye (logout)? call SndPack('Y',num,0) !Acknowledge it call quit !Turn everything off call Logoff3 !and log off the session else !Other generic packet type? ErrMsg = 'Unknown generic packet type: ' // pt call kdebug(all,ErrMsg,' ') call SndErr endif else if (pt .eq. 'T') then !Time-out? seq = 0 !Reset the sequence number call SndPack('N',seq,0) !Guard against lost packets goto 10 !Ignore it else if (pt .ne. 'N') then !Something other than NAK? ErrMsg = 'Unknown Server packet type: ' // pt call kdebug(all,ErrMsg,' ') call SndErr endif goto 10 end logical*2 function Send() ,<890525.1144> >Send-state switch implicit none include kercom.ftni,NOLIST include kerdbg.ftni,NOLIST include kerfil.ftni,NOLIST include kersta.ftni,NOLIST integer*2 retry character*1 sdata,sfile,seof,sinit,sbreak character*3 c_r state = 'S' !Set initial state c_r = char(13) // ' _' fSend = .true. !Set Send/Receive flag for send send = .false. !Clear the success flag retry = 0 !Reset the retry-counter call LoadSeg(2) $ call NextFile !Get 1st file to send if (fiNm .eq. ' ') return !Nothing to send call LoadSeg(3) $ call StartStats !Prepare for packet-I/O 10 if (state .eq. 'D') then !Send data? state = sdata(retry) else if (state .eq. 'F') then !Send file header? state = sfile(retry) else if (state .eq. 'Z') then !Send EOF? state = seof(retry) !Yes - send the packet if (state .eq. '@') then !Ready for next file? call LoadSeg(2) !Get the file-masking routines call NextFile !Get next file to send call LoadSeg(3) !Restore packet-I/O capability if (fiNm .eq. ' ') then !Is there one? state = 'B' !No - break the connection else state = 'F' !Yes - do a file-header endif endif else if (state .eq. 'S') then !Send initial packet? state = sinit(retry) else if (state .eq. 'B') then !Send final packet? state = sbreak(retry) else if (state .eq. 'C') then !Last file sent? call endstats !Turn off statistics logging send = .true. return else if (state .eq. 'E') then !Did we receive an error packet? call endstats if (.not. fServ) call tpFm(ErrMsg) return else if (state .eq. '!') then !Did we get an error? call endstats call SndErr return else !Unknown packet? call endstats ErrMsg = 'Send-state error; state = ' // state call kdebug(states,ErrMsg,' ') if (R .ne. L) then call tpFm(ErrMsg) endif call SndErr return endif call kdebug(states,'TxState: ',state) if (retry .ne. 0) rtry = rtry + 1 if (R .ne. L) then call tpI2(c_r,spak,6) call tpI2('/_',rtry,-3) call tpFm(' _-') endif goto 10 end subroutine sleep(csec) ,<890525.1144> >Delay for N centiseconds implicit none integer*2 csec,i if (csec .gt. 0) then !Need negative units to wait i = -csec else i = -2 !Always wait at least 2 units endif call exec(12,0,1,0,i) c ^ ^ ^ ^ ^ c ! ! ! ! +----> number of units to delay c ! ! ! +------> repeat this how many times?" (none = 0) c ! ! +--------> Units are centiseconds c ! +----------> Suspend myself (not some other task) c +------------> Executive request code to suspend c In order to read the above diagram, read upwards: c "I want the executive to suspend me once for (csec) centiseconds, c and then I will do something else." return end block data main_common ,<890525.1144> >KERMIT's labeled common areas implicit none include kcmnds.ftni include kconcw.ftni include kercmd.ftni include kercnf.ftni include kercom.ftni include kerdbg.ftni include kerfil.ftni include kersta.ftni data Lsyu /0/ ! Insure 1st-time stuff is done data seg /0/ ! Insure 1st LoadSeg call works data delay /1500/ ! 15 sec from SEND to 1st pkt data EsChar /29/ ! CTRL-] returns to local KERMIT data MaxTry /5/ ! Normal retry-limit is 5 data ImxTry /15/ ! Initial retry-limit is 15 data R /0/ ! Remote LU is unknown at startup data seq /0/ ! Sequence numbers starts at 0 data Class /0/ ! We get a class# as needed data sPcnt /9/ ! I only have 9 parameters to send data Parity /0/ ! 'Not set yet' ! My packet parameters follow data PakSiz /94/ ! Current packet size data Timeout /0/ ! (filled in by GetPakTime) data nPad /0/ ! I require no padding, but... data Padch /0/ ! ...use nulls if you must pad data EOLch /13/ ! I require CR as a terminator data Quote /35/ ! I want "#" before controls data Bit8 /38/ ! I want "&" before 8th-bit set data ChkTyp /1/ ! I do type-1 checksums data Repc /126/ ! Repeat-count prefix is "~" data Sync /1/ ! CTRL-A starts my packets ! My partner's defaults are reset by subroutine RecPar to: data sPkSiz /80/ ! Packet size data sTime /30/ ! Timeout (never wait past 30 sec) data sPad /0/ ! I'll never send padding data sPadch /0/ ! (If I pad, I'll use nulls) data sEOL /13/ ! is end-of-packet data sQuote /35/ ! "#" precedes control-characters data sBit8 /32/ ! No 8th-bit quoting assumed data sCheck /1/ ! 1-byte checksums used data sRepc /32/ ! No repeat-counts assumed data sSync /1/ ! CTRL-A starts your packets ! Utility defaults follow data fWarn /.true./ ! I will warn of file overwrites data fIBM /.false./ ! I am not in IBM mode data fServ /.false./ ! I am not in server mode data fEcho /.false./ ! I am not echoing transfer-file data fTrans /.false./ ! I am not using a transfer-file data f8OK /.true./ ! I will allow 8-th bit quoting data HlpNam /' '/ ! I don't know the help file name data state /'C'/ ! File-transfer is C(omplete) data Prompt /'Kermit-RTE>'/ ! Command-line prompt ! File defaults follow data fBnry /.false./ ! Assume ASCII transfers data Mask /' '/ ! Set default (directory) mask data Rmask /' '/ ! Clear the server-receive mask data fiNm /' '/ ! Clear the file-name storage ! Debugging defaults follow data dbNm /' '/ ! No debugging file opened data dbLv /0/ ! No debugging in progress ! Status stuff follows data tspak /0/ ! No packets sent yet (total) data trpak /0/ ! No packets received yet (total) data trtry /0/ ! No retries yet (total) data spak /0/ ! No packets sent yet (current) data rpak /0/ ! No packets received yet (current) data rtry /0/ ! No retries yet (current) data sbytes /0/ ! No bytes sent data rbytes /0/ ! No bytes received data sovrhd /0/ ! No overhead bytes sent data rovrhd /0/ ! No overhead bytes received ! WARNING: The order of the pvalues must match the order of the parity ! commands themselves in /KCMNDS/ ! Parity bits = EVEN, MARK, NONE, ODD, SPACE data pvalu / 41400b, 41000b, 140000b, 40400b, 40000b, > 41400b, 40400b, 0b, 41000b, 40000b/ ! Command constants follow data commands/ > 'BYE', 'CONNECT', 'EXIT', 'FINISH', 'GET', > 'HELP', 'QUIT', 'RECEIVE', 'RUN', 'SEND', > 'SERVER', 'SET', 'SHOW', 'STATUS', 'TRANSFER'/ data setparms/ > 'BINARY', 'BQUOTE', 'CHECK', 'DEBUG', 'DELAY', 'ESCAPE', > 'IBM', 'LINE', 'PACKET', 'PARITY', 'PROMPT', 'QUOTE', > 'REPEAT', 'RETRY', 'RMASK', 'SYNC', 'WARNING'/ data parits / 'EVEN', 'MARK', 'NONE', 'ODD', 'SPACE'/ data debugs / 'ALL', 'FILE', 'OFF', 'PACKETS', 'STATES'/ end program K1CMD(5) ,<890525.1144> >KERMIT command processors implicit none include kercom.ftni,NOLIST include kercmd.ftni,NOLIST include kercnf.ftni,NOLIST $alias /datc/ = '$DATC', NoAllocate $alias xla = '.XLA', direct integer*2 datc,SyRv,xla common /datc/ datc seg = 1 if (Lsyu .eq. 0) then !Need to initialize? call GetMux(L,LocCnf) !Get the local configuration SyRv = xla(datc) !Get the system date-code call tpCh('HP-1000 RTE-KERMIT Version 1.99d <890525.1144>' > ,char(10),0) call tpCh(' KERMIT-RTE requires EOL=13!',char(10),0) call HostMode !Check and/or change host mode fServ = .false. !Can't be serving on startup cmCh = ' ' !Clear the command-line call getst(cmIn,-65,cmLn) !Get a possible run-string if (SyRv .gt. 5010) then !Newer than I know about? call tpFm('BEWARE - KERMIT has not been tested_') call tpFm(' under this system revision!') endif call SetTrap(SyRv) !Set FORTRAN-traps as needed endif call SegRt end subroutine Command ,<890525.1144> >Do user commands implicit none include kercom.ftni,NOLIST include kercmd.ftni,NOLIST include kcmnds.ftni,NOLIST include kerdbg.ftni,NOLIST integer*2 i,err,xl(2),cw,FmpOpen,FmpRead,TrimLen,Match logical*2 MustBeLocal character*1 cmC1(80) equivalence (xl(2),cw),(cmC1,cmLn) data cw /400b/ !Set Echo on terminal LU xl = L !Put LU into control-word 10 if (fTrans) then !Getting transfer-file commands? cmCh = ' ' !Yes - clear the command-line cmLn=FmpRead(trCb,err,cmIn,65) !Yes - get one if (err.lt.0 .or. cmLn.lt.0) then !On EOF or error... call FmpClose(trCb,fTrans) !(don't destroy read-error) fTrans = .false. !Turn off transfer-file flag endif if (err.lt.0) call ReportFileError(err,'') endif ! By first going to the transfer-file for a command and allowing zero- ! length commands, I can perform a sort of 'return to the console' ! operation FOR ONE COMMAND ONLY per blank line in in the transfer- ! file. If you find yourself at a console prompt unexpectedly, you ! can make KERMIT go back to the transfer-file (without processing a ! dummy command) by entering one or more commas only. cmLn = TrimLen(cmCh) if (cmLn .lt. 1) then fPkIO = .false. !Can't be in packet-I/O here 20 call tpCh(Prompt,' _',0) !Prompt the user call xreio(1,xl,cmIn,-65) !get a command call abreg(i,cmLn) !Get the input length cmCh(cmLn+1:) = ' ' !Clear unused part of command cmLn = TrimLen(cmCh) !Now get the data length if (cmLn .lt. 1) goto 20 !Reprompt if none given endif ! This is the top-level parser. For a given top-level keyword, do the ! function indicated. Most commands can be (severely!) abbreviated. if (fEcho) call tpCh(' -',cmCh,0) !Echo as directed call kdebug(all,'Command: ',cmCh) !log the command cmRu = cmCh !Save for RunProgram/SetPrompt call CaseFold(cmCh) !Convert to upper case do i = 1,cmLn !Convert commas to blanks if (cmC1(i) .eq. ',') cmC1(i) = ' ' enddo cmLn = TrimLen(cmCh) !"Kill" trailing blanks if (cmLn .lt. 1) goto 10 !Ignore the current command cmP2 = 0 !Initialize token search call gettok('?') !Locate a token i = match(commands,cmtsiz,0) !Find the command in vocabulary if (cmTk .eq. '?') goto 30 if (i .gt. 0) then !If in vocabulary... cmTk = commands(i) !...expand the command token endif ! In the "case" statement which follows, we only return after surviving ! the parsing for commands which perform packet-I/O. if (cmTk .eq. 'BYE') then if ( MustBeLocal() ) return !Only return if local-host else if (cmTk .eq. 'CONNECT') then call connect else if (cmTk.eq.'EXIT' .or. cmTk.eq.'QUIT') then call quit call exec(6) else if (cmTk .eq. 'FINISH') then if ( MustBeLocal() ) return !Remote-host not allowed else if (cmTk .eq. 'GET') then if ( MustBeLocal() ) then call GetFile(*30) cmTk = 'GET' return endif else if (cmTk .eq. 'HELP') then call help else if (cmTk .eq. 'RECEIVE') then call RecFile(*30) cmTk = 'RECEIVE' return else if (cmTk .eq. 'SEND') then call SndFile(*30) !Parse the command cmTk = 'SEND' return else if (cmTk .eq. 'SERVER') then call ServerInit(*30) !Ok to go to server? cmTk = 'SERVER' return else if (cmTk .eq. 'SET') then call Set else if (cmTk .eq. 'SHOW') then call show else if (cmTk .eq. 'STATUS') then call status else if (cmTk .eq. 'TRANSFER') then if (fTrans) then call tpFm('Transfer-files may not be nested!') else call gettok(' ') !Get transfer-file's name if (FmpOpen(trCb,err,cmTk,'ro',1) .gt. 0) then fTrans = .true. call gettok('NO') !Default to no echo fEcho = (cmTk(:2) .ne. 'NO') else call FmpReportError(err,cmTk) endif endif else !If no token matches... call RunProgram !...assume it is a program name endif 30 cmCh = ' ' !Clear last command out goto 10 !Get another command end subroutine HostMode ,<890525.1144> >Check host mode implicit none include kercom.ftni,NOLIST include kercnf.ftni,NOLIST !Defines fRmx integer*2 bngdb,i character*5 rates(0:15) data rates/'????','50','75','110','134.5','150','300','1200', > '1800','2400','4800','9600','19.2k','38.4k','115k', > 'sense'/ if (R .eq. 0) then !Is remote lu undefined? R = L !Assume remote-host mode call MoveWords(LocCnf,RemCnf,CnfSiz) !local config -> remote array endif call tpFm('KERMIT-RTE is in _') call GetPakTimeout(i) !Sense "remote" baud rate if (R .eq. L) then call tpFm('remote-host mode_') if (.not. fRmx) then call tpFm(', but not on a mux port') call tpFm('(You''ll need to SET LINE to some mux LU_') call tpFm(' before you can transfer files)') call tpFm(' "Server" is not available at this LU!') else call tpFm('; file transfers are ok') if (bngdb() .eq. 0) call lurq(100001b,L,1) endif else call tpI2('local-host mode to LU _',R,0) call tpCh(' @ _',rates(i)) !Show the baud rate call tpFm(' baud; _') call ShowParity call lurq(100001b,R,1) endif return end integer*2 function GetPakTimeout(i) ,<890525.1144> >Get Packet-I/O timeout implicit none include kercom.ftni,NOLIST include kercnf.ftni,NOLIST integer*2 baudtimes(14),i,ixget c baud rate--> 50, 75, 110,134.5, 150, 300, 1200+ data baudtimes / 2500, 1900, 1500, 1300, 1200, 900, 8*600 / c This routine sets my timeout value (in my parameter block) as a c function of the REMOTE's baud-rate. It returns as it's parameter c the index to the baud-rate table, and as it's value the number of c 100ths of a second to wait for a packet (from me) as follows: c the time required to receive 100 bytes at the given baud rate c + 1 second for any fractional second from the above c + 5 seconds for processing time. c NOTE: the remote KERMIT will tell me (in the SINIT packet) if I c should time-out a packet-receive; even if the remote KERMIT doesn't c want that processing, I'll still time-out a packet receive after c 30 seconds. Note that in any event, under RTE-A no receive-packet c timeouts will occur because the device driver must be bypassed. i = r30c !Get the current configuration i = iand(ishft(i,-3),17b) !Isolate/right-justify rate if (i.lt.1 .or. i.gt.12) then !Is it a legal value? i = 0 !No - return "unknown" Timeout = 0 !...and don't do timeouts else Timeout = baudtimes(i)/100 !Put in my parameter block endif GetPakTimeout = Timeout * 100 !Tell SERVER the timeout value return end subroutine ShowParity ,<890525.1144> >Show remote-port parity implicit none include kercom.ftni.NOLIST include kercnf.ftni.NOLIST include kcmnds.ftni.NOLIST integer*2 i,j,k,pmask,pvals(5,2) parameter (pmask = 141400b) !Mask removes current parity bits equivalence (pvalu,pvals) i = r30c .and. pmask !Isolate current parity bits j = (iRmx .and. 1) + 1 !Set pvalu index for B/C or D mux call tpFm(' Parity = _') do k = 1,prtsiz if (i .eq. pvals(k,j)) then call tpFm(parits(k)) return endif enddo call tpFm(' Unknown!') return end logical function ctoi(rval) ,<890525.1144> >Parse ASCII to integer implicit none c This routine parses ASCII characters into a single 16-bit integer. c The character data may be in decimal, octal ("B" must be the last c byte), or hexadecimal ("H" must be the last byte), and may contain c a leading sign. A character-literal may be entered as a number if c the other (last) character is a '"'. CTOI returns false if no c numeric can be parsed due to no data or illegal data. The c command-line pointer cmP2 is expected to point to the end of the c previous token on entry; cmP1 and cmP2 will point to the next c token on exit, or cmP1 will equal 0 if there are no more tokens c on the line. include kercmd.ftni,NOLIST integer*2 p,i,e,rval,base character*1 c,s ctoi = .false. !Show initial "no number found" rval = 0 !...and clear the value save call gettok(' ') !Isolate the numeric if (cmP1 .lt. 1) return !there isn't a number there e = cmP2 !Save end pointer c = cmCh(e:e) !Get base character (if any) if (c .eq. 'B') then !Is it octal? base = 8 !Yes e = e - 1 !Don't parse the "b" else if (c .eq. 'H') then !No? try hexadecimal base = 16 e = e - 1 !Don't parse the "h" else if (c .eq. '"') then !No? try ASCII literal if ( (cmP2-cmP1) .eq. 1) then !(must be the literal, then a '"') c = cmCh(cmP1:cmP1) !Get the character rval = ichar(c) !Convert to integer ctoi = .true. return endif else !No? assume decimal base = 10 endif p = cmP1 !Save the starting pointer c = cmCh(p:p) !Get sign (if any) if (c.eq.'+' .or. c.eq.'-') then !If there is a sign... p = p + 1 !Bump the byte pointer s = c !...and save the sign byte else s = ' ' endif do while (p .le. e) !Parse the number c = cmCh(p:p) !Get a byte p = p + 1 !Bump the byte pointer i = ichar(c) - 60b !Convert numerics to integer if (i .lt. 0) return !non-numeric found if (i.gt.9) then !Allow possible hex digits if (i.lt.17 .or. i.gt.22) return !Insure it is 'A' thru 'F' i = i - 7 !Scale hex digits endif if (i .ge. base) return !Illegal byte for this base rval = (rval*base) + i !Continue forming number end do ctoi = .true. if (s .eq. '-') rval = -rval !Deal with a "-", if found return end subroutine gettok(default) ,<890525.1144> >Get a command-line token implicit none c This routine is sets cmP1 and cmP2 to the start and end of a "token" c (one or more non-blanks in the command line), and cmTk is set to the c token itself. If there are no more tokens in the line, cmP1 returns c zero, cmP2 is undefined, and cmTk returns the "default" string. c c NOTICE -- cmP1 is always set to cmP2+1 before use; to locate the c first token in a line you must set cmP2 to 0. Locating the "next" c token on a line is automatic. include kercmd.ftni,NOLIST character*(*) default cmP1 = cmP2 + 1 !Always go to next byte call skipbl(cmP1) !Skip leading blanks cmP2 = cmP1 !We have start-of-token call skip2bl(cmP2) !go 1 past end-of-token cmP2 = cmP2 - 1 !Back up to end-of-token if (cmP1 .gt. cmLn) then !Are we past last token? cmP1 = 0 !Yes - note it cmTk = default else cmTk = cmCh(cmP1:cmP2) endif return end integer*2 function match(tabl,tlen,dum) ,<890525.1144> >Match token to token-table implicit none include kercmd.ftni,NOLIST include kercom.ftni,NOLIST character*(*) tabl(*) integer*2 tlen,dum logical*2 fCMMD !True for special COMMAND call character*1 tc integer*2 t1,t2,len,TrimLen c MATCH tries to locate the token (cmTK) in the TABLe of strings c containing TLEN entries. If the token is found >uniquely< in c the table, the index of that entry is returned as the value of c MATCH; otherwise MATCH returns 0. If the token contains a "?", c any table entries which were matched up to (but not including) c the "?" are printed on locally with an appropriate message. c In the absence of a "?", if more than one table entry matches c the token, MATCH returns as if there was no match and prints a c message to inform the user of ambiguous data and shows all of c the possible choices. c c cmTk must not contain embedded blanks c TABL must be in alphabetical order fCMMD = pcount() .eq. 3 !True if special COMMAND call len = TrimLen(cmTk) !Get the token's length t1 = 1 !Set current low table index t2 = tlen !Set current high index p = 1 !Set token byte-pointer match = 0 !Show no match initially do while (p .le. len) !Begin matching here tc = cmTk(p:p) !Get a token character if (tc .eq. '?') then !If "?" then give possibilities call tpFm('The following are legal at this point:') call outtbl(tabl,t1,t2) return endif c (do while token is less than lower table entry) do while (tc.gt.tabl(t1)(p:p) .and. t1.le.t2) t1 = t1 + 1 enddo c (do while token is greater than upper table entry) do while (tc.lt.tabl(t2)(p:p) .and. t2.ge.t1) t2 = t2 - 1 enddo c (if we know we have a mismatch...) if (t2 .lt. t1) then if ( fCMMD ) return call tpCh('No such command or parameter -',cmTk(:len),0) call tpFm('The following are legal at this point:') call outtbl(tabl,1,tlen) return endif p = p + 1 !Bump the token byte-pointer enddo c After scanning all of the token, is it still ambiguous? if (T1 .ne. T2) then if ( fCMMD ) return call tpCh('"_',cmTk,len) call tpFm('" is ambiguous; possible matches are:') call outtbl(tabl,t1,t2) else match = t1 cmTk = tabl(t1) !Expand the token endif return end subroutine outtbl(tabl,t1,t2) ,<890525.1144> >Print strings (tabular) implicit none character*(*) tabl(*) integer*2 t1,t2 integer*2 cwid,ncol,i,j,k c This routine prints strings in a table (TAB) from indexes T1 to T2 cwid = len(tabl(1)) !Get the column width ncol = 80 / (cwid + 2) !Get # of displayable columns do i = t1,t2,ncol !Output the columns do j = 1,ncol !print each table entry k = i + j - 1 if (k .le. t2) then call tpCh(' _',tabl(k),cwid) if (j .lt. ncol) call tpFm(' _') endif enddo call tpFm('-') enddo return end subroutine connect ,<890525.1144> >Do terminal-emulation implicit none include kconcw.ftni,NOLIST !Defines XLUEX ConWords + term include kercom.ftni,NOLIST include kercmd.ftni,NOLIST include kercnf.ftni,NOLIST include kerdbg.ftni,NOLIST integer*2 ib(128),il !The input buffer & its length integer*2 k,a,b,gtnw !Various temporaries logical*2 eflag !TRUE if escape-char processed logical*2 NeedRTerm !TRUE if Remote needs termination logical*2 ifbrk,SetLine,MustBeLocal k = cmP2 !Save current parsing pointer call GetTok('none') !See if there is another parameter if (cmTk .ne. 'none') then !If so, do Set Line for the user cmP2 = k !Restore the parsing pointer cmTk = 'CONNECT' !...and the "current" command if (.not. SetLine() ) return !The set line didn't work endif if (.not. MustBeLocal() ) return !User hasn't Set Line yet eflag = .false. !No escape-char seen yet fASI = .not. fLmx !Set for Local ASIC-type card fRcm = .not. btest(iRmx,0) !Note if remote uses B/C mux fLcm = .not. btest(iLmx,0) !Note if local uses B/C mux if (class .eq. 0) then !Do we need a class number? call clrq(100001b,class) !Yes - get one call abreg(a,b) !Get return status if (a .lt. 0) then !Did we get a class # ? call tpFm('Cannot connect: no class numbers available') return else class = ior(class,20000b) !Set "don't de-allocate" bit endif endif ! (Since GtNW is not in common, we must set it here) gtnw = ior(class,100000b) !Set no-wait bit call cPrep !Prepare ports for connect-mode call tpI2('[connecting to LU _',R,0) call tpFm('; return via "control-_') call tpCh(char(EsChar+64),'" then "C"]',0) if ( fASI ) then !Non-mux local does class I/O call xluex(17,Lrx,ib,-1,0,0,class) !Start local read endif if ( fRcm ) NeedRTerm = .true. !Terminate 1st B/C mux buffer ! The connect loop consists of an inner polling-loop and the outer ! processing-loop as follows: ! The inner polling-loop interrogates the remote status looking ! for availability of type-ahead data, and the local keyboard ! (via a no-wait class "get" call, or, if on a mux, when some ! typed-ahead data becomes available) until one of them shows ! data available, or until the break-flag is set (which will ! simulate the user typing "C" to close the ! connection. Processing of remote data is handled within ! the inner-loop; we exit the inner-loop on receipt of any ! keyboard data or if another user "breaks" this KERMIT. ! The outer processing-loop has two major divisions: the polling ! loop, and local data-handling, which must be checked on a ! character-by-character basis for the presence of the escape ! character. An escape character signals the beginning of a ! user command to (the local) KERMIT. ! ! The flow of this code is sufficiently complicated that I have elected ! to use (gasp!) a few statement numbers rather than the more elegant ! (and more cumbersome) if-then-else and unnumbered do-while constructs ! found in previous versions of this routine. ! ! I am indebted to Bruce K. Swope, of Intermedics, Inc. in Freeport, ! Texas, for his assistance in locating the cause of the "mux lockup". ! His ideas on the handling of the remote port have resulted in greatly ! reducing (if not completely eliminating) occurrences of this dreaded ! condition. ! ! "D" mux handling notes: as you can probably see from the code, the ! 12040D handles much nicer than the B or C revisions (can't wait for ! the M/E/F version!). The card can buffer up to 1024 bytes, but I ! don't want to tie up that much memory; I have elected to never read ! more than 256 bytes from remote port at any given time. 10 do while (.true.) !inner-loop begins if (NeedRTerm) then !Need to terminate remote? call control(R,term,0) !Yes - do it, but not more than NeedRTerm = .false. !...once per input buffer endif call sleep(4) !Let other folks run for 40 ms. if ( IfBrk(k) ) goto 40 !Proceed as if "C" entered if ( fLmx ) then !Local on mux? call control(L,dstat,0) !Yes - get local status call abreg(a,il) if (il .gt. 0) then !Any data available? call xluex(1,Lrx,ib,-1) !Yes - get only 1 byte... if ( fLcm ) then !For local B/C mux... call control(L,term,0) !...re-terminate input endif il = 1 $ goto 20 !...and process it endif else call exec(21,gtnw,ib,-1) !Look for keyboard data call abreg(a,il) !Get the status if (a .gt. 0) goto 20 !Keyboard data is available endif call control(R,dstat,0) !Request remote status call abreg(a,il) !Get it back from driver if (il .gt. 0) then !Data available? il = min(il,256) !Limit input to 256 bytes call xluex(1,Rrx,ib,-il) !Yes - get it if ( fLmx ) then !Local on a mux? call xluex(2,Ltx,ib,-il) !Yes - just write else call clrq(3,class,L) !Abort pending keyboard read call xluex(2,Ltx,ib,-il) !Copy remote data to display call xluex(17,Lrx,ib,-1,0,0,class) !Set new keyboard read endif if ( fRcm ) then !Terminate remote on next pass... NeedRTerm = .true. !...if using B or C mux endif endif end do 20 if (il .le. 0) goto 30 !(Ignore keyboard timeout) if (fIBM) call xluex(2,Ltx,ib,-1) !Do local echo as needed k = ishft(ib,-8) !Get the local keystroke if (k.gt.140b .and. k.lt.172b) k=k-40b !Shift to upper-case if (k .eq. EsChar) then !Escape? eflag = (.not. eflag) !Yes - toggle the escape flag if (eflag) il = 0 !Send if previous was escape else if (eflag) then !If last keypress was escape... il = 0 !say "don't send this" eflag = .false. !turn off escape flag if (k .eq. 103b) then !'C' or 'c': close the connection goto 40 else if (k .eq. 122b) then !'R' or 'r': resume debug logging dblv = iand(dblv,77777b) else if (k .eq. 123b) then !'S' or 's': stop debug logging dblv = ior(dblv,100000b) else if (k .eq. 63) then !'?': help call tpFm(' C = Close the connection') call tpFm(' R = Resume debug logging') call tpFm(' S = Suspend debug logging') call tpCh('control-_',char(eschar+64),0) call tpFm(' (again) = send escape to remote') eflag = .true. else call tpFm('Unknown escape function') endif endif if (il .gt. 0) then !Anything left to send? call xluex(2,Rtx,ib,-1) !Send keystroke to remote endif 30 if ( fASI ) then !reset local (non-mux) read call xluex(17,Lrx,ib,-1,0,0,class) endif goto 10 !keep looping 40 if ( fASI ) then !Do non-mux local cleanup call clrq(3,class,L) !Clear pending local requests a = 0 !Prepare to kill completed reqs do while (a .ge. 0) call exec(21,gtnw,ib,-1) !Get any completed requests call abreg(a,il) enddo elseif ( fLcm ) then !Cleanup from local B/C mux? call control(L,3700b,102000b) !Yes (RESTORE does the rest endif if ( fRcm ) then !Restore from B/C connect call control(R,3300b,22500b) !cn33: read reconfig on call control(R,3700b,102000b) !cn37: terminate on CR only endif call control(R,2600b,1) !cn26: clear (all) card buffers call restore(L) !Restore local parameters call enable(L,fLmx) !Restore int scheduling call tpFm('[back at KERMIT-RTE]') return end subroutine help ,<890525.1144> >Process HELP commands implicit none include kcmnds.ftni,NOLIST include kercmd.ftni,NOLIST include kercom.ftni,NOLIST integer*2 i,match,err,o integer*2 TrimLen,FmpOpen,FmpSetPosition,FmpRead integer*4 cr,nr,OldP,CurP,NxtP,DoPos logical*2 fExist integer*2 hfCb(16) !Help-file control block integer*2 hBuf(128),hInd(18,7) !Help-file record buffer character*256 hStr character*36 hKey(7) !Help-file key entries character*24 TheKey equivalence (hBuf(3),hInd,hKey),(hBuf,hStr) ! Statement function -- encodes rec# and offset into a double-integer DoPos(cr,o) = ishft(cr,8) + iand(o,377b) call gettok('HELP') !Set pointers to 2nd parameter i = match(commands,cmtsiz) if (i .lt. 1) return !Just drop invalid commands if (cmTk .eq. 'SET') then !Since SET has parameters... call gettok('<') !...parse the 3rd parameter if (cmTk .ne. '<') then !If it wasn't defaulted... i = match(setparms,setsiz) !...expand the keyword if (i .lt. 1) return !Drop an unknown set parameter endif endif if (HlpNam .eq. ' ') then !Have we found the help file? if (fExist('kermit.hlp::system',1)) then !No - try system dir HlpNam = 'kermit.hlp::system' else if (fExist('kermit.hlp::kermit',1)) then !then KERMIT's dir HlpNam = 'kermit.hlp::kermit' else if (fExist('kermit.hlp',1)) then !Then user's dir HlpNam = 'kermit.hlp' else if (fExist('"kermi::0',1)) then !Last, try FMGR space HlpNam = '"kermi::0' else call tpFm('KERMIT.HLP missing or wrong file-type') return endif endif i = TrimLen(cmTk) !Clean up the key if (FmpOpen(hfCb,err,HlpNam,'ro',1).lt.0) then call ReportFileError(err,HlpNam) endif if (FmpRead(hfCb,err,hBuf,256).lt.0) then !Read 1st record call FmpClose(hfCb,i) call ReportFileError(err,HlpNam) endif OldP = DoPos(0J,0) !Set previous position cr = 1 !Note current record#... nr = 1 !...and desired ("new") record o = 1 !...and current offset CurP = DoPos(cr,o) !Save "current" position NxtP = DoPos(nr,o) !Save "next" position 10 if (NxtP .eq. OldP) then !In an endless loop? call tpFm('Sorry, no help available') !Yes: kill endless loop return else OldP = CurP !Else save where we've been CurP = NxtP endif if (nr .ne. cr) then !At correct file position? if (cr .ne. 0) then !Handle 1st record after open if (FmpSetPosition(hfCb,err,nr,-nr).lt.0) then call FmpClose(hfCb,i) call ReportFileError(err,HlpNam) endif endif if (FmpRead(hfCb,err,hBuf,256).lt.0) then call FmpClose(hfCb,i) call ReportFileError(err,HlpNam) endif cr = nr !Note new current position endif TheKey = hKey(o) if (cmTk .lt. TheKey(:i)) then !Current token too high? nr = hInd(15,o) !Get new record o = hInd(16,o) !...and new offset else if (cmTk .gt. TheKey(:i)) then !Current token too low? nr = hInd(17,o) o = hInd(18,o) else !Found the key, so... nr = hInd(13,o) !...get the text rec# o = hInd(14,o) !...and char offset goto 20 endif NxtP = DoPos(nr,o) !Build next-position value goto 10 !Look some more 20 if (FmpSetPosition(hfCb,err,nr,-nr).lt.0) then call FmpClose(hfCb,i) call ReportFileError(err,HlpNam) endif if (FmpRead(hfCb,err,hBuf,256).lt.0) then call FmpClose(hfCb,i) call ReportFileError(err,HlpNam) endif i = index(hStr(o:),char(4)) - 1 !Locate possible terminator if (i .lt. 1) then !No terminator yet call tpCh(hStr(o:) // '-','_',0)!Print the record o = 1 !...reset the offset nr = nr + 1 !...and go on to next record goto 20 else i = i + o call tpFm(hStr(o:i)) endif 999 call FmpClose(hfCb,err) return end logical*2 function fExist(name,type) ,<890525.1144> >Flag file existence and type implicit none character*(*) name integer*2 type,ActType c This routine returns .true. if the named file exists with the c given file-type. If the file-type is given as a number less c than zero, the type-checking is omitted, and fExist returns c true if the named file exists as any file type include kercom.ftni,NOLIST integer*2 err,FmpOpen,hfCb(16) ActType = FmpOpen(hfCb,err,name,'ro',1) call FmpClose(hfCb,err) if (type .ge. 0) then fExist = (type .eq. ActType) else fExist = (ActType .ge. 0) endif return end subroutine Set ,<890525.1144> >Parse/Perform SET commands implicit none include kcmnds.ftni,NOLIST include kercom.ftni,NOLIST include kercmd.ftni,NOLIST include kerfil.ftni,NOLIST integer*2 i,match call gettok('?') !Isolate the parameter name i = match(setparms,setsiz) if (i .lt. 1) then !Just return on invalid choice return else cmTk = setparms(i) endif if (cmTk .eq. 'BINARY') then call Tok_On_True(fBnry) if (fBnry .and. Parity.ne.3 .and. .not.f8OK) then fBnry = .false. call tpFm('Can''t do binary transfers') endif else if (cmTk .eq. 'BQUOTE') then call SetBQuote else if (cmTk .eq. 'CHECK') then call SetCheck else if (cmTk .eq. 'DEBUG') then call SetDebug else if (cmTk .eq. 'DELAY') then call SetDelay else if (cmTk .eq. 'ESCAPE') then call SetEscape else if (cmTk .eq. 'IBM') then if (R .eq. L) then call tpFm('SET IBM is illegal in remote-host mode') else call Tok_On_True(fIBM) endif else if (cmTk .eq. 'LINE') then call SetLine else if (cmTk .eq. 'PACKET') then call SetPacket else if (cmTk .eq. 'PARITY') then call SetParity else if (cmTk .eq. 'PROMPT') then call SetPrompt else if (cmTk .eq. 'QUOTE') then call SetQuote else if (cmTk .eq. 'REPEAT') then call SetRepeat else if (cmTk .eq. 'RETRY') then call SetRetry else if (cmTk .eq. 'RMASK') then call gettok(' ') !Get the server-receive mask rmask = cmTk else if (cmTk .eq. 'SYNC') then call SetSync else if (cmTk .eq. 'WARNING') then call Tok_On_True(fWarn) endif return end subroutine show ,<890525.1144> >Process SHOW command implicit none include kercom.ftni,NOLIST include kerdbg.ftni,NOLIST include kerfil.ftni,NOLIST !To define fBnry call HostMode !Show who's boss if (R .ne. L) then !we're in local-host mode call tpCh('ESCAPE character is ^-',char(eschar+64),1) call tpFm('IBM flag is_') if (fIBM) then call tpFm(' ON; prompt char is DC1') else call tpFm(' OFF') endif endif call tpFm('Binary transfers are_') if (fBnry) then call tpFm(' enabled') else call tpFm(' disabled') endif call tpFm('Receiving a duplicate file will be_') if (fWarn) then call tpFm(' aborted') else call tpFm(' allowed') endif call tpI2('File-send delay (seconds) = -',delay/100,0) call tpI2('Checksum type is -',ChkTyp,0) call tpI2('PACKET size is -',paksiz,0) call tpCh('QUOTE is -',char(quote),1) if ( f8OK ) then call tpCh('BQUOTE is -',char(Bit8),1) else call tpFm('Binary quoting is disabled') endif call tpCh('REPEAT is -',char(Repc),1) call tpCh('SYNC is ^-',char(sync+64),1) call tpCh('File transfer-state is -',state,1) if (dbNm .eq. ' ') then call tpFm('The debug log-file is undefined; not debugging') else if (dbLv .eq. 0) then call tpCh('Nothing is being debug-logged to -',dbNm,0) else if (dbLv .eq. ALL) then call tpCh('Everything is being debug-logged to -',dbNm,0) else if (dbLv .eq. STATES) then call tpCh('States are being debug-logged to -',dbNm,0) else if (dbLv .eq. PACKETS) then call tpCh('Packets are being debug-logged to -',dbNm,0) endif return end subroutine status ,<890525.1144> >Give transmission statistics implicit none include kercom.ftni,NOLIST include kersta.ftni,NOLIST integer*4 time,baud,tbytes,work integer*2 hr,min,sec work = tspak + trpak call tpCh(char(10),'Statistics since startup:',0) call tpI2(' Packets sent =_',tspak,7) call tpI2(' Packets received =_',trpak,7) call tpI4(' Total packets =',work,9) call tpI2(' (_',trtry,0) call tpFm(' of the total were retries)') time = endtim - startim !How long did it take (seconds) hr = time/3600 !Get time in hours time = time - hr * 3600 !Remove hours from the time min = time/60 !Get time in minutes sec = time - min * 60 !...and in seconds call tpCh(char(10),'Statistics of last transfer:',0) call tpI2(' Transfer time (hh:mm:ss) =_',hr,3) call tpI2(':_',min,-2) call tpI2(':',sec,-2) call tpI4(' Avg tx-packet size =_',sbytes/spak,3) call tpI4(' Avg rx-packet size =',rbytes/rpak,3) work = spak + rpak call tpI2(' Packets sent =_',spak,7) call tpI2(' Packets received =_',rpak,7) call tpI4(' Total packets =',work,9) call tpI2(' (_',rtry,0) call tpFm(' of the total were retries)') work = sbytes + rbytes call tpI4(' Bytes sent =_',sbytes,9) call tpI4(' Bytes received =_',rbytes,9) call tpI4(' Total bytes =',work,11) work = sovrhd + rovrhd call tpI4(' Send overhead (bytes) =_',sovrhd,9) call tpI4(' Receive overhead (bytes) =',rovrhd,9) call tpI4(' Total overhead (bytes) =',work,0) time = endtim - startim work = (sbytes + rbytes) / time call tpI4(' Total bytes per second: -',work,0) work = ( (sbytes+rbytes) - (sovrhd+rovrhd) ) / time * 10 call tpI4(' Effective baud rate: -',work,0) return end $alias lurq, NOABORT subroutine RunProgram ,<890525.1144> >Process RUN command implicit none include kcmnds.ftni,NOLIST include kercom.ftni,NOLIST include kercmd.ftni,NOLIST integer*2 prams(5),err,FmpRunProgram,TrimLen character*5 RunName if (cmTk .eq. 'RUN') then call GetTok('!') !See if a program name was given endif if (cmTk .eq. '!') then call tpFm('Usage: [ru ]program [params...]') else call lurq(40000b,L,1,*10) !Allow other progs to use this LU 10 err = FmpRunProgram(cmRu,prams,RunName) if (err .lt. 0) then if (err .eq. -6) then call match(commands,CmtSiz) else call FmpReportError(err,cmTk) endif else call exec(14,1,cmIn,-78) !Get possible run-string call abreg(err,cmLn) !Get length of that run-string if (err .ne. 0) then !Was a string returned? cmLn = 0 !No - clear the length return else cmLn = min(TrimLen(cmCh),cmLn) endif if (cmLn.gt.0 .or. prams.ne.0) then call tpCh('"_',RunName) call tpFm('" has returned the following _') if (cmLn .gt. 0) then call tpFm('string:') call tpFm(' '//cmCh(:cmLn)) if (prams.ne.0) call tpFm('and the following _') endif call tpFm('parameters (decimal):') if (prams .ne. 0) then do err = 1,5 call tpI2(' _',prams(err),6) end do endif call tpFm(' -') !Can't send all blanks to tpFm endif call HostMode !Re-assert locks as needed endif endif return end subroutine SetDebug() ,<890525.1144> >Process SET DEBUG commands implicit none include kcmnds.ftni,NOLIST include kercmd.ftni,NOLIST include kercom.ftni,NOLIST include kerdbg.ftni,NOLIST integer*2 match,i,err,FmpOpen,FmpSetEof,DcbOpen call gettok('?') !Locate the next token i = match(debugs,dbtsiz) if (i .lt. 1) return !Ignore bad parameter if (cmTk .eq. 'FILE') then dbLv = 0 !Changing the file turns it off if (dbNm .ne. ' ') then call FmpClose(dbCb,err) dbNm = ' ' endif call gettok(' ') !Get the file-name pointers if (cmP1 .lt. 1) then !None supplied? call tpFm('Usage: SET DEBUG FILE ') return endif dbNm = cmTk !Get the name if (FmpOpen(dbCb,err,dbNm,'wco',1) .lt. 0) then dbNm = ' ' call ReportFileError(err,dbNm) !(error on open - tell user) endif if (FmpSetEof(dbCb,err) .lt. 0) then !Insure we can write call FmpClose(dbCb,err) dbNm = ' ' call ReportFileError(err,dbNm) else call FmpRewind(dbCb,err) return endif endif if (DcbOpen(dbCb,err) .ne. 0) then !Is debug file open? call tpFm('You need to SET DEBUG FILE first') else if (cmTk .eq. 'ALL') then dbLv = ALL else if (cmTk .eq. 'STATES') then dbLv = STATES else if (cmTk .eq. 'PACKETS') then dbLv = PACKETS else if (cmTk .eq. 'OFF') then dbLv = 0 endif return end subroutine SetDelay ,<890525.1144> >Process SET DELAY command implicit none include kercom.ftni,NOLIST integer*2 i logical*2 ctoi if (R .ne. L) then call tpFm('Set Delay is invalid in Local Host mode') else if (ctoi(i)) then if (i .lt. 0) then call tpFm('Invalid delay value') else if (i .gt. 30) then call tpFm('Value too big; using 30 seconds') delay = 3000 else delay = i * 100 endif else call tpFm('Usage: SET DELAY ') endif endif return end subroutine SetEscape ,<890525.1144> >Process SET ESCAPE command implicit none include kercom.ftni,NOLIST integer*2 i logical*2 ctoi if (R .eq. L) then call tpFm('SET ESCAPE is invalid in Remote Host mode') else if (.not. ctoi(i)) then call tpFm('Usage: SET ESCAPE ') else if (i.gt.0 .and. i.lt.32) then eschar = i else call tpFm('The escape must a control character') endif endif return end Logical*2 function SetLine() ,<890525.1144> >Process SET LINE command implicit none include kercom.ftni,NOLIST include kercmd.ftni,NOLIST include kercnf.ftni,NOLIST integer*2 rmtlu,lutru,p30val,p30add,idadd,user(3),lu,sylu character*6 cUser character*1 CmdSav integer*2 WhoLockedLu,bngdb logical*2 ctoi equivalence (cUser,user) CmdSav = CmTk !Save 1st command character SetLine = .false. !"abort" command on error condition call lurq(100000b) !Clear all locks if (.not. ctoi(rmtlu)) then !Get the LU# parameter if (CmdSav .eq. 'C') then !Called from CONNECT? call tpFm('Usage: CONNECT []') else call tpFm('Usage: SET LINE ') endif goto 10 endif sylu = lutru(rmtlu) !Get the system LU equivalent if (sylu .lt. 1) then !In user's session? call tpFm('That LU is not in your session') goto 10 endif if (R .ne. L) then !If switching remote lu's... call control(R,2600b,1) call restore(R) !Restore old configuration call enable(R,fRmx) R = 0 endif if (lutru(L) .ne. sylu) then R = rmtlu !Set new remote-LU call lurq(100001b,R,1) !Try to lock it call abreg(idadd,lu) !Get return status from lock if (idadd .ne. 0) then !Were we successful? idadd = WhoLockedLu(sylu) !No - find out who has it call IdAddToName(idadd,user,lu) call tpI2('LU _',R,0) call tpCh(' is locked to _',cUser,0) call tpI2('/_',lu,0) call tpFm(' ...Sorry Charlie') R = 0 goto 10 endif call GetMux(R,RemCnf) !Get its configuration if (.not. fRmx) then !Is the LU on a mux? call tpFm('That LU is not on a mux') R = 0 else if (r30c .eq. 0) then !Has the port been configured? call tpFm('That LU has never been configured') R = 0 else call disable(R,fRmx) !Kill remote interrupt-scheduling call KillEnqAck !Disable ENQ/ACK as needed SetLine = .true. !OK to continue a Connect... endif endif 10 call HostMode return end subroutine SetParity ,<890525.1144> >Process SET PARITY command implicit none include kercom.ftni,NOLIST include kercmd.ftni,NOLIST include kcmnds.ftni,NOLIST include kercnf.ftni,NOLIST include kerfil.ftni,NOLIST !To define fBnry integer*2 i,j,match,pmask,ixget,pvals(5,2) logical*2 MustBeLocal parameter (pmask = 36377b) !Mask removes current parity bits equivalence (pvalu,pvals) if (.not. MustBeLocal() ) return !Can't be remote call gettok('?') !Get the parity type requested i = match(parits,prtsiz) !Do we recognize it? if (i .lt. 1) return Parity = i !Set B-quoting as needed r30c = r30c .and. pmask !Get configuration w/o parity j = (iRmx .and. 1) + 1 !Set pvals index r30c = r30c .or. pvals(i,j) !Plug in desired parity call control(R,3000b,r30c) !Send it to the card call sleep(100) !Let the card catch up (?) call ShowParity !Show the changed parity if (parity.ne.3 .and. fBnry .and. .not.f8OK) then call tpFm('Can''t do binary transfers') fBnry = .false. endif return end subroutine SetPacket ,<890525.1144> >Process SET PACKET command implicit none include kercom.ftni,NOLIST integer*2 i logical*2 ctoi if (ctoi(i)) then if (i.gt.30 .and. i.lt.95) then PakSiz = i else call tpFm('Packet Size must be from 31 to 94') endif else call tpFm('Usage: SET PACKET ') endif return end subroutine SetCheck ,<890525.1144> >Process SET CHECK command implicit none include kercom.ftni,NOLIST integer*2 i logical*2 ctoi if (ctoi(i)) then if (i.gt.0 .and. i.lt.4) then ChkTyp = i else call tpFm('Checksum type must be from 1 to 3') endif else call tpFm('Usage: SET CHECK ') endif return end subroutine SetPrompt ,<890525.1144> >Process SET PROMPT command implicit none include kercmd.ftni,NOLIST include kercom.ftni,NOLIST call gettok('Kermit-RTE>') !Set default if (cmP1 .ne. 0) then !Was new prompt given? Prompt = cmRu(cmP1:cmP2) !Yes - retrieve from original line else Prompt = CmTk !Else retrieve the default prompt endif return end subroutine SetQuote ,<890525.1144> >Process SET QUOTE command implicit none include kercom.ftni,NOLIST integer*2 i logical*2 ctoi if (ctoi(i)) then if (i.gt.32 .and. i.lt.127) then if (i .eq. Bit8) then call tpFm('Invalid: conflicts with BQUOTE') else if (i .eq. Repc) then call tpFm('Invalid: conflicts with REPEAT') else Quote = i endif else call tpFm('Invalid: value must be from 33 to 126') endif else call tpFm('Usage: SET QUOTE ') endif return end subroutine SetBQuote ,<890525.1144> >Process SET BQUOTE command implicit none include kercom.ftni,NOLIST include kerfil.ftni,NOLIST !To define fBnry integer*2 i logical*2 ctoi if (ctoi(i)) then if ( (i.gt.31 .and. i.lt.63) .or. > (i.gt.95 .and. i.lt.127) ) then if (i .eq. Quote) then call tpFm(' Invalid: conflicts with QUOTE') else if (i .eq. Repc) then call tpFm(' Invalid: conflicts with REPEAT') else Bit8 = i f8OK = Bit8 .ne. 32 !.true. if 8th-bit quote enabled if (.not. f8OK) then !Did they turn it on? if (fBnry .and. Parity.ne.3) then !Can we do binary? fBnry = .false. call tpFm('Can''t do binary transfers') endif endif endif else call tpFm('Invalid: value must be 32-62 or 96-126') endif else call tpFm('Usage: SET BQUOTE ') endif return end subroutine SetRepeat ,<890525.1144> >Process SET REPEAT command implicit none include kercom.ftni,NOLIST integer*2 i logical*2 ctoi if (ctoi(i)) then if ( (i.gt.32 .and. i.lt.63) .or. > (i.gt.95 .and. i.lt.127) ) then if (i .eq. Quote) then call tpFm(' Invalid: conflicts with QUOTE') else if (i .eq. Bit8) then call tpFm(' Invalid: conflicts with BQUOTE') else Repc = i endif else call tpFm('Invalid: value must be 33-62 or 96-126') endif else call tpFm('Usage: SET REPEAT ') endif return end subroutine SetRetry ,<890525.1144> >Process SET RETRY command implicit none include kercom.ftni,NOLIST include kercmd.ftni,NOLIST integer*2 i logical*2 ctoi,fInit if (ctoi(i)) then call GetTok(' ') !Look for (I)nitial fInit = cmTk(1:1) .eq. 'I' if (i.lt.5 .or. i.gt.30) then call tpFm('Invalid: value must be from 5 to 30') else if ( fInit ) then ImxTry = i else maxtry = i endif endif else call tpFm('Usage: SET RETRY [I]') endif return end subroutine SetSync ,<890525.1144> >Process SET SYNC command implicit none include kercom.ftni,NOLIST integer*2 i logical*2 ctoi if (ctoi(i)) then if (i.lt.1 .or. i.gt.31) then call tpFm('Invalid: value must be from 1 to 31') else if (i.eq.EOLch .or. i.eq.17) then call tpFm('Conflicts with EOL or IBM-PROMPT') else sync = i endif else call tpFm('Usage: SET SYNC ') endif return end subroutine Skip2Bl(ptr) ,<890525.1144> >Skip to blanks in commands implicit none c This routine finds the first blank in cmCh past the current c PTR position (if any) and returns it in PTR. If there are no c blank characters from PTR to the end of the string, PTR is c returned pointing to the end of the string + 1. include kercmd.ftni,NOLIST integer*2 ptr do while (ptr .le. cmLn) !Stay in the string if (cmCh(ptr:ptr) .eq. ' ') then return else ptr = ptr + 1 endif end do return end subroutine SkipBl(ptr) ,<890525.1144> >Skip blanks in commands implicit none c This routine finds the first non-blank in cmCh past the current c PTR position (if any) and returns it in PTR" If there are no c non-blank characters from PTR to the end of the string, PTR is c returned unchanged. include kercmd.ftni,NOLIST integer*2 i,ptr i = ptr do while (i .le. cmLn) !Stay in the string if (cmCh(i:i) .ne. ' ') then ptr = i return else i = i + 1 endif end do return end subroutine tok_on_true(flag) ,<890525.1144> >Flag if next token = "ON" implicit none c This routine sets its parameter "true" if the next command-line c token is "ON"; or sets it "false" if that token is "OFF". If c the token is neither of these, subroutine MATCH prints a message, c and this routine leaves its parameter alone. logical*2 flag character*3 on_off(2) integer*2 match,i data on_off/'OFF','ON'/ call gettok('?') !Locate next token i = match(on_off,2) !Match it to "ON" or "OFF" if (i .eq. 1) then !If "OFF" matched... flag = .false. !...do the "off" thing else if (i .eq. 2) then !If "ON" matched... flag = .true. !...do the "on" thing endif !Else do nothing return end subroutine SndFile(*) ,<890525.1144> >Send file(s) implicit none include kercmd.ftni,NOLIST !defines cmTk include kercnf.ftni,NOLIST !defines fRmx include kerfil.ftni,NOLIST !defines mask, first, and fiNm ! This routine was split into a command-processing section (this one) ! and a packet-sending section (in the main) for revision 1.99. if (.not. fRmx) then !Are transfers ok? call tpFm('You need to SET LINE first') return 1 endif call gettok(' ') !Get the ind-file or mask if (cmTk .eq. ' ') then !None given? call tpFm('Usage: SEND ') return 1 else mask = cmTk endif call gettok(' ') !Look for 2nd file name (initial) fiNm = cmTk first = .true. return end subroutine RecFile(*) ,<890525.1144> >Receive file(s) implicit none include kercmd.ftni,NOLIST !Defines cmTk include kercnf.ftni,NOLIST !Defines fRmx include kerfil.ftni,NOLIST !Defines mask and first ! This routine was split into a command-parsing section (this one) and ! a packet-receiving section (in the 3rd segment) at revision 1.99. if (.not. fRmx) then !OK to transfer files? call tpFm('You need to SET LINE first') return 1 endif call gettok(' ') !Get the optional local name first = .true. mask = cmTk return end subroutine GetFile(*) ,<890525.1144> >Receive from a server implicit none include kercmd.ftni,NOLIST !Defines cmTk include kerfil.ftni,NOLIST !Defines GetMask, mask, and first call gettok(' ') !Get the (remote) file name if (cmTk .eq. ' ') then !Was one given? call tpFm('Usage: GET []') return 1 else GetMask = cmTk !Save the mask for the get endif call gettok(' ') !Get optional local file-name mask = cmTk first = .true. return end subroutine ServerInit(*) ,<890525.1144> >Start a KERMIT Server implicit none include kercom.ftni,NOLIST include kercnf.ftni,NOLIST !Defines fRmx if (R .ne. L) then !If local host... call tpFm('Server not available in local-host mode') return 1 else if (.not. fRmx) then call tpFm('You are not on a Mux LU') return 1 else fServ = .true. call tpFm('[KERMIT Server running on an HP-1000 host.') call tpFm(' You must escape to your local machine now!]') endif return end logical*2 function MustBeLocal() ,<890525.1144> >Insure local-host mode implicit none include kercom.ftni,NOLIST MustBeLocal = .false. !Assume we are in remote host if (R .eq. L) then !Are we remote? call tpFm('You need to Set Line to a mux port first!') else MustBeLocal = .true. endif return end program K2MSK(5) ,<890525.1144> >KERMIT file-masking implicit none include kercom.ftni,NOLIST !To define seg seg = 2 !Keep the segment-loader happy call SegRt end Subroutine NextFile ,<890525.1144> >Get next file to send implicit none ! The purpose of this routine is to supply an file, opened for reading, ! to the packet-I/O handler in masked searches. A simple file-name is ! handled as if it was a mask, which doesn't bother the file-system at ! all. This routine is used only to find files to be sent. include kercom.ftni,NOLIST include kerfil.ftni,NOLIST integer*2 err,dntry(32),j integer*2 FmpInitMask,TrimLen,FmpOpen logical*2 FmpNextMask character*64 name1 character*5 openopts if (first) then !Do 1st-entry stuff if needed ! On masked searches, 1st entry consists of initializing ! the search mask. Note that, on error, Error will re- ! turn to the caller if we are a KERMIT server; otherwise, ! execution will continue in the command-processor. ! If the initial file-name was given, then we copy it to ! Name1 and delay clearing the First flag. call FmpEndMask(maCb) !Be sure old mask is closed if (FmpInitMask(maCb,fiEr,mask,CurPath,372) .lt. 0) > call ReportFileError(fiEr,mask) if (fiNm .ne. ' ') then !Was an initial name given? name1 = fiNm !Yes - save it else first = .false. !else no initial-name search endif endif ! Normal processing on masked sends involves getting the next ! name, as above, but the file-system will tell us if there ! is anything else to find. If an initial file-name was given ! we will attempt to match it here. 10 fMore = FmpNextMask(maCb,fiEr,CurPath,dntry) fiNm = ' ' if (fiEr .lt. 0) then !On mask error... if (fiEr.ne.-208) then !(except duplicate directory) call ReportFileError(fiEr,CurPath) else if (fMore) goto 10 !Get another name, if possible goto 20 endif else if (fMore) then call FmpMaskName(maCb,fiNm,dntry,CurPath) else goto 20 endif endif if (first) then !Doing initial-name search? j = TrimLen(name1) !Use only as much as user gave if (name1 .eq. fiNm(:j)) then !Now check: found it yet? first = .false. !Yes - stop searching else goto 10 !not found yet - keep searching endif endif ! If we have a file, open it and return the name to the caller 20 if (fiNm .ne. ' ') then if (fBnry) then openopts = 'rofx' else openopts = 'ro' endif if (FmpOpen(fiCb,fiEr,fiNm,openopts,1) .lt. 0) then call ReportFileError(fiEr,fiNm) fiNm = ' ' else fiPt = 0 !Force 1st record to be read endif endif return !Return to main end program K3XFR(5) ,<890525.1144> >KERMIT file-transfer implicit none include kercom.ftni,NOLIST !To define seg seg = 3 call SegRt end subroutine bye ,<890525.1144> >BYE command processor implicit none include kercom.ftni,NOLIST integer retry,err,num,len logical*2 fRtryi character*1 ptype,RecPack c This routine sends a generic-logout packet to a server running on c another system. On success, we terminate gracefully. pdata = 'L' !Set data to L(ogout) retry = 0 !Reset retry counter 10 if ( fRtryi(retry) ) then !Exceeded retry limit? call tpFm('Unable to send LOGOUT') return !Go back to command processor endif call SndPack('G',seq,1) !Send the logout packet ptype = RecPack(len,num) !Get the response if (ptype .eq. 'T') then !time-out? call tpFm('') goto 10 else if (ptype .eq. 'N') then !NAK? if (mod(seq+1,64) .ne. num) goto 10 ptype = 'Y' num = num - 1 endif if (ptype .eq. 'Y') then !ACK? if (seq .ne. num) goto 10 call quit !Shut ourselves down Stop else if (ptype .eq. 'X') then !Checksum error? call tpFm('Checksum error; retrying') else if (ptype .eq. 'E') then !Error packet? call tpCh('Received error packet: -',RecPkt(5:len+4),0) return else call tpCh('Unknown packet type: -',ptype,1) endif goto 10 end subroutine finish ,<890525.1144> >FINISH command processor implicit none include kercom.ftni,NOLIST integer*2 retry,err,len,num logical*2 fRtryi character*1 ptype,RecPack pdata = 'F' !Set data to F(inish) retry = 0 10 if ( fRtryi(retry) ) then call tpFm('Unable to FINISH') return endif call SndPack('G',seq,1) !Send the finish packet ptype = RecPack(len,num) if (ptype .eq. 'T') then !time-out? call tpFm('') goto 10 else if (ptype .eq. 'N') then !NAK? if (mod(seq+1,64) .ne. num) goto 10 ptype = 'Y' num = num - 1 endif if (ptype .eq. 'Y') then !ACK? if (num .ne. seq) goto 10 return else if (ptype .eq. 'X') then !Checksum error? call tpFm('Checksum error - retrying') else if (ptype .eq. 'E') then !Error packet? call tpFm('Received error packet:') call tpFm(RecPkt(5:len+4)) return else call tpCh('Unknown packet type: -',ptype,1) endif goto 10 end subroutine Logoff3 ,<890525.1144> >(LogOff caller) implicit none call LogOff !We never return... call exec(6) !(just in case) end logical*2 function receive(istate) ,<890525.1144> >Receive-state switch implicit none c This routine performs state switching for file-receive operations. c If file-recepetion is successful, receive returns .true. include kercom.ftni,NOLIST include kerdbg.ftni,NOLIST include kersta.ftni,NOLIST character*(*) istate integer*2 retry character*1 rdata,rinit,rfile character*3 c_r state = istate !Show receiving state call startstats !restart statistics logging retry = 0 c_r = char(13) // ' _' receive = .false. 10 call kdebug(states,'RxState: ',state) if (retry .ne. 0) rtry = rtry + 1 if (R .ne. L) then call tpI2(c_r,rpak,6) call tpI2('/_',rtry,-3) call tpFm(' _-') endif if (state .eq. 'D') then !read a DATA packet state = rdata(retry) else if (state .eq. 'R') then !read a SINIT packet state = rinit(retry) else if (state .eq. 'F') then !read a file header state = rfile(retry) else if (state .eq. 'C') then !file transfer complete? call endstats !turn off statistics logging sCheck = 1 !Revert to type-1 checksums receive = .true. return else if (state .eq. 'E') then !We received an error packet call endstats call fClose if (.not. fServ) call tpFm(ErrMsg) return else if (state .eq. '!') then !we got an error call endstats call fClose call SndErr return else !Unknown receive state call endstats call fClose ErrMsg = 'Receive-state error; state = ' // state call kdebug(states,ErrMsg,' ') if (R .ne. L) then call tpFm(ErrMsg) endif call SndErr return endif goto 10 end character*1 function rinit(retry) ,<890525.1144> >Receive initial packet implicit none include kercom.ftni,NOLIST include kerfil.ftni,NOLIST !To define fBnry integer*2 retry,len,num,svCheck logical*2 fRtryi character*1 ptype,recpack rinit = state !Assume no state change if ( fRtryi(retry) ) then rinit = '!' !exceeded max. # of re-try return !give up endif ptype = recpack(len,num) !read a packet if (ptype .eq. 'S') then !we got a SINIT packet call RecPar(len) !store partner's params if (fBnry .and. Parity.ne.3 .and. .not.fBit8) then ErrMsg = 'Can''t receive binary file (parity problem)' call SndErr fBnry = .false. rinit = 'E' return endif call SndPar('Y',num) !Send my parameters now sCheck = newChk !OK to change check type now seq = mod(num+1,64) !Set new sequence number retry = 0 !Clear the retry counter rinit = 'F' !New state = File header else if (ptype .eq. 'X') then !we got a checksum error call SndPack('N',num,0) !NAK the packet else if (ptype .eq. 'T') then !Timed out? call SndPack('N',seq,0) !just nak it else if (ptype .eq. 'E') then !Error packet? ErrMsg = 'Sender error: ' // RecPkt(5:len+4) rinit = 'E' else ErrMsg = 'Unknown packet type: ' // ptype rinit = '!' !Unexpected packet, so give up endif return end character*1 function rfile(retry) ,<890525.1144> >Read file-header packet implicit none include kercom.ftni,NOLIST include kerfil.ftni,NOLIST integer*2 retry,num,len,FmpOpen,TrimLen,err,typ logical*2 fRetry character*1 recpack,ptype character*5 openopts if ( fRetry(retry) ) then rfile = '!' return endif rfile = state ptype = RecPack(len,num) !Read a packet if (ptype .eq. 'F') then !we got a file-header if (num .ne. seq) then !If the sequence# is bad... ErrMsg = 'Bad sequence number' rfile = '!' !...abort return endif pdata = RecPkt(5:len+4) !copy off the file-name info... call legalize(typ) !...validate & move it to fiNm openopts = 'wc' !min open options: write & create if (.not. fWarn) then !If files can be overlayed... call chApp(openopts,'o') !allow (O)ld files endif if (fBnry) then !If in binary mode... call chApp(openopts,'f') !...(F)orce to type 1 if (typ .ne. 6) then !if not an rp-able program... call chApp(openopts,'x')!...allow e(X)tent access endif endif if (FmpOpen(fiCb,err,fiNm,openopts,1) .lt. 0) then Call ReportFileError(err,fiNm) else fiCh = ' ' !Clear the record buffer fiPt = 0 !Set record pointer call SndPack('Y',num,0) seq = mod(seq+1,64) rfile = 'D' !Switch to data state if (R.ne.L) then !Display the file name locally call tpCh('Receiving -',fiNm,TrimLen(fiNm)) endif retry = 0 endif else if (ptype .eq. 'S') then !Old send-init packet? if (mod(num+1,64) .eq. seq) then call SndPar('Y',num) !Yes - send my parameters retry = 0 else ErrMsg = 'Bad sequence# on old SINIT' rfile = '!' endif else if (ptype .eq. 'Z') then !Old EOF packet? if (mod(num+1,64) .eq. seq) then call SndPack('Y',num,0) !Yes - just ack it retry = 0 else ErrMsg = 'Bad sequence# on old EOF' rfile = '!' endif else if (ptype .eq. 'B') then !Break packet? if (num .ne. seq) then ErrMsg = 'Bad sequence# on BREAK' rfile = '!' else call SndPack('Y',num,0) rfile = 'C' !Change state to Complete retry = 0 endif else if (ptype .eq. 'X') then !Checksum error? call SndPack('N',num,0) else if (ptype .eq. 'T') then !Time-out? call SndPack('N',seq,0) !just NAK it else if (ptype .eq. 'E') then !Error packet? ErrMsg = 'Sender error: ' // RecPkt(5:len+4) rfile = 'E' else !Invalid packet type ErrMsg = 'Unknown packet type: ' // ptype rfile = '!' endif return end subroutine chApp(dest,newstuff) ,<890525.1144> >Append to string implicit none character*(*) dest,newstuff integer*2 TrimLen,i i = TrimLen(dest) + 1 !Find 1st available character if (i .le. Len(dest)) dest(i:) = newstuff return end character*1 function rdata(retry) ,<890525.1144> >Receive data packet implicit none include kercom.ftni,NOLIST integer*2 retry,num,len logical*2 fRetry character*1 ptype,recpack rdata = state !Assume no change in state if ( fRetry(retry) ) then rdata = '!' return endif ptype = recpack(len,num) !read a packet if (ptype .eq. 'D') then !we got the data packet if (num .ne. seq) then !Sequence error? if (mod(num+1,64).eq.seq) then !Was prev packet re-sent? call SndPack('Y',num,0) !Yes - just ack it retry = 0 else ErrMsg = 'Bad Sequence#' rdata = '!' endif else call BufEmp(len) !Sequence # ok - copy to disc call SndPack('Y',num,0) !Ack the packet seq = mod(num+1,64) !Bump the sequence number retry = 0 !Show no more retries endif else if (ptype .eq. 'F') then !Old filename packet? if (mod(num+1,64).eq.seq) then !Yes - sequence# ok? call SndPack('Y',num,0) !Yes - ack it retry = 0 !Show no retries else ErrMsg = 'Bad Sequence#' rdata = '!' endif else if (ptype .eq. 'Z') then !EOF packet? if (num .ne. seq) then !Yes - sequence# ok? rdata = '!' !No - abort the transfer else call SndPack('Y',num,0) !Yes - ACK it call dputc(-2) !Post poss pending buffer to file rdata = 'F' !Look for another file-header seq = mod(num+1,64) !Set next sequence number retry = 0 endif call fClose else if (ptype .eq. 'X') then !Checksum error? call SndPack('N',num,0) !NAK the packet else if (ptype .eq. 'T') then !time-out? call SndPack('N',seq,0) else if (ptype .eq. 'E') then !Error packet? ErrMsg = 'Sender error: ' // RecPkt(5:len+4) rdata = 'E' else !Unknown packet type? ErrMsg = 'Unknown packet type: ' // ptype rdata = '!' !Abort the transfer endif return end subroutine legalize(typ) ,<890525.1144> >Insure valid file names implicit none c This routine is called for any received file to insure that its name c is valid in this system. Name validity has two main components: c * No illegal characters c * Correct specification of directory path c Once validity is insured, this routine copies that name to fiNm, the c global used for files' names in KERMIT-RTE. c c The first issue is addressed by editing the file name so that any c occurrences of "+", "-", ",", or "@" are changed to an underscore. c If the first character is numeric, it also is replaced by an under- c score, as are any embedded blanks in the name. RTE system can only c use a period to separate file-names from the type-extension, if the c other system uses something else, this system won't understand but c won't change it unless it violates one of the rules above. "/" and c ":" are used in different contexts to describe directory paths in c this system; if they appear in the name sent from the other system, c they and their associated information will be removed! c c This routine causes the file to be put into the current working- c directory, or into the directory given by the first parameter of c a RECEIVE command or the second parameter of the GET command. If c there is no active working-directory and no directory was given c by the RECEIVE or GET command, the file will be put in FMGR-space, c and the file-name will be truncated to the left-most 6 characters. c c NOTE: if a full file name is given in GET or RECEIVE, that name is c used for the first file received only; any other files received in c the same stream can be renamed in all parts BUT the file name. include kercom.ftni,NOLIST include kerfil.ftni,NOLIST integer*2 ij,sc,typ,rl,i,TrimLen character name*16,typx*4,rtpx*4,ds*40,junk*1 if (first) then !First time after GET or RECEIVE? ds = ' ' !Clear the DS-information string rtpx = ' ' !...and the (mask) type-extendion first = .false. !Don't do this again if (mask .ne. ' ') then !If a name was given... fiNm = mask !Is it a name and/or a mask? call FmpParsePath(fiNm,mask,name,rtpx,junk,sc,typ,fiSz, > rl,ds) !NOTE: qualifier is illegal here ! but DS-stuff is not! call checkname(rtpx) !Validate the type-extension if (name .ne. ' ') then !If anything is left... if (rtpx .ne. ' ') then !do we also have type-ext? i = TrimLen(name) pdata = name(:i) // '.' // rtpx else pdata = name endif endif endif if (typ .lt. 1) typ = 4 !Default to var-length/editable if (fiSz.lt. 1) fiSz = 24 !...and 24 blocks if (rl .lt. 0) rl = 0 endif c Directory-, qualifier-, or DS-info will never be sent from another c KERMIT, but I parse for them in the following call (the "JUNK" in c 3 places) so that I won't be fooled by something that looks like c that kind of stuff. Further, the security-code, file-type, -size, c and -record-length fields are also dummies ("IJ" in 4 places). call FmpParsePath(pdata,junk,name,typx,junk,ij,ij,ij,ij,junk) call CheckName(name) !Replace illegals in the name if (rtpx .ne. ' ') then !Replace type-extension? typx = rtpx !Yes - do it else call CheckName(typx) !Replace illegals in type-extension endif c Now reconstruct the name. If anything beyond a file-name was given in c a GET or RECEIVE command, it was parsed above; it will now be used c here to build a full file-name. call FmpBuildPath(fiNm,mask,name,typx,' ',sc,typ,fiSz,rl,ds) return end subroutine CheckName(name) ,<890525.1144> >Make file-name info legal implicit none character*(*) name integer*2 i,TrimLen character*1 b c This routine checks file-name and -extensions to insure that all c occurrences of '+', '-', ',', '@', leading numeric characters, and c embedded blanks or control-characters are replaced by '!'. do i = 1,TrimLen(name) !Scan the file name b = name(i:i) !Extract a character if (i .eq. 1) then !Check for numeric 1st character if (b.ge.'0' .and. b.le.'9') then b = '!' endif else if (b .eq. '+') then b = '!' else if (b .eq. '-') then b = '!' else if (b .eq. '@') then b = '!' else if (b .eq. ',') then b = '!' else if (b .le. ' ') then b = '!' endif name(i:i) = b !Replace (possibly) changed byte end do return end character*1 function sinit(retry) ,<890525.1144> >Send initial packet implicit none include kercom.ftni,NOLIST include kerfil.ftni,NOLIST integer*2 retry,num,len,FmpOpen,err logical*2 fRtryi character*1 ptype,RecPack character*4 openopts if ( fRtryi(retry) ) then !Retry limit exceeded? sinit = '!' !Yes - abort the send call SendAbort !Close all associated files return endif sCheck = 1 !SINIT always uses 1-byte checks call SndPar('S',seq) !Send my parameters ptype = RecPack(len,num) !Get the response sinit = state !Assume no change in state if (ptype .eq. 'N') then !NAK? return !Yes - try again else if (ptype .eq. 'T') then !Time-out? return !try again else if (ptype .eq. 'E') then !Error packet? ErrMsg = 'Receiver error: ' // RecPkt(5:len+4) sinit = 'E' call SendAbort return else if (ptype .eq. 'Y') then !ACK? if (seq .ne. num) then !Yes - for this packet? return !No - try again endif call RecPar(len) !Get partner's parameters sCheck = NewChk !Ok to do new checksum type now if (fBnry .and. Parity.ne.3 .and. .not.fBit8) then ErrMsg = 'Can''t send binary file (parity problem)' fBnry = .false. sinit = 'E' call SendAbort return endif retry = 0 !Clear the retry counter seq = mod(seq+1,64) !Get next sequence number if (fBnry) then openopts = 'rofx' else openopts = 'ro' endif if (FmpOpen(fiCb,err,fiNm,openopts,1).lt.1) then call ReportFileError(err,fiNm) else fiPt = 0 !Force a record to be read sinit = 'F' !Go to File-name state endif else if (ptype .ne. 'X') then !Any response except checksum err? ErrMsg = 'Unknown packet type: ' // ptype sinit = '!' !Yes - abort the send call SendAbort endif return end character*1 function sfile(retry) ,<890525.1144> >Send file-name packet implicit none include kercom.ftni,NOLIST include kerfil.ftni,NOLIST integer*2 retry,len,num,TrimLen,j logical*2 fRetry character*1 ptype,RecPack character name*16,typex*4,cj*1 if ( fRetry(retry) ) then !Exceeded retry limit? sfile = '!' !Yes - abort the transfer call SendAbort !Close all files return endif c Get the "normal form" of the file-name. The "J" and "CJ" variables c are "junk" (unused fields) from the parse. call FmpParsePath(fiNm,cj,name,typex,cj,j,j,j,j,cj) j = TrimLen(name) if (typex .ne. ' ') then !Was a type-extension given? pdata = name(:j) // '.' // typex else pdata = name endif call SndPack('F',seq,TrimLen(pdata)) !Send the file name ptype = RecPack(len,num) !Get the response sfile = state !Assume no change in state if (ptype .eq. 'T') then !Time-out? return !just retry else if (ptype .eq. 'E') then !Error packet? ErrMsg = 'Receiver error: ' // RecPkt(5:len+4) sfile = 'E' call SendAbort return else if (ptype .eq. 'N') then !NAK or time-out? if (mod(seq+1,64) .ne. num) then return else ptype = 'Y' num = num - 1 endif endif if (ptype .eq. 'Y') then !ACK? if (seq .ne. num) then return endif retry = 0 seq = mod(seq+1,64) !Get next sequence number sfile = 'D' !Go to the data state if (R.ne.L) then !Display the file name locally call tpCh('Sending -',fiNm,TrimLen(fiNm)) endif call buffill !Get first data packet's worth else if (ptype .ne. 'X') then !Anything else but checksum err... ErrMsg = 'Unknown packet type: ' // ptype sfile = '!' !...makes us abort the send call SendAbort endif return end character*1 function sdata(retry) ,<890525.1144> >Send file-data packets implicit none include kercom.ftni,NOLIST integer*2 retry,len,num,buffill logical*2 fRetry character*1 ptype,RecPack if ( fRetry(retry) ) then !Exceeded retry limit? sdata = '!' !Yes - give up call SendAbort return endif sdata = state !Assume no change in state call SndPack('D',seq,slen) !Send the data packet ptype = RecPack(len,num) !Get the reply if (ptype .eq. 'T') then !Time-out? return !Just retry else if (ptype .eq. 'E') then !Error packet? ErrMsg = 'Receiver error: ' // RecPkt(5:len+4) sdata = 'E' call SendAbort return else if (ptype .eq. 'N') then !Got a NAK? if (mod(seq+1,64) .eq. num) then return else ptype = 'Y' !A NAK on the 'next' packet is num = num - 1 !...an ACK on this one endif endif if (ptype .eq. 'Y') then !Got an ACK? if (seq .ne. num) return retry = 0 seq = mod(seq+1,64) if (buffill() .lt. 1) then !Did we get EOF? sdata = 'Z' !Yes - change state endif else if (ptype .ne. 'X') then !Something besides checksum? ErrMsg = 'Unknown packet type: ' // ptype sdata = '!' !Abort the transfer call SendAbort endif return end character*1 function sbreak(retry) ,<890525.1144> >Send EOT packet implicit none include kercom.ftni,NOLIST integer*2 retry,len,num logical*2 fRetry character*1 ptype,RecPack if ( fRetry(retry) ) then !Did we exceed the retry limit sbreak = '!' !Yes - abort the transfer call SendAbort return endif sbreak = state !Assume no state change call SndPack('B',seq,0) ptype = RecPack(len,num) if (ptype .eq. 'T') then !timed out? return !just retry else if (ptype .eq. 'E') then !Error packet? ErrMsg = 'Receiver error: ' // RecPkt(5:len+4) sbreak = 'E' call SendAbort return else if (ptype .eq. 'N') then !Were we NAKed? if (mod(seq+1,64).ne.num) then !Yes - is it an old NAK? return !No - do another break else ptype = 'Y' num = num - 1 endif endif if (ptype .eq. 'Y') then !Were we ACKed? if (num .ne. seq) then !Yes - in sequence? return !No - do the break again endif retry = 0 seq = mod(seq+1,64) sbreak = 'C' !Change to Complete status else if (ptype .ne. 'X') then !Anything else but checksum? ErrMsg = 'Unknown packet type: ' // ptype sbreak = '!' !Yes - abort the send call SendAbort endif return end integer*2 function buffill() ,<890525.1144> >Fill transmit buffer implicit none c This routine copies data from the sending disc file to the data c portion of the transmit packet. It is responsible for assuring c that control, 8th-bit, and repeat-count prefixing sequences are c not broken across a packet boundary. include kercom.ftni,NOLIST integer*2 i,j,b,dgetc,ctl,psave,DataMax,TrimLen,xbufL character*20 xBuf !"excess" buffer data xBuf /' '/ !(SegLd always clears this) p = 1 !Reset packet byte pointer DataMax = sPkSiz - (sCheck+1) !(This is last available byte + 1) if (xBuf .ne. ' ') then !Anything in the overflow buffer? pData = xBuf !Yes - put it in front of packet p = xBufL + 1 !...and reset pointer to end of it xBuf = ' ' !(show overflow buffer is clear) endif do while (dgetc(b) .ge. 0) !Read from disc 'til EOF psave = p !In case of buffer overflow if (fRepc) then !Can we do repeat-counts? i = 1 !Yes - find non-match/too many do while (dgetc(j).eq.b .and. i.lt.94) i = i + 1 !Max repeat-count is 94 end do call dPutBack(j) !Put back the non-match if (i .lt. 4) then !Below the repeat threshold? do while (i .gt. 1) !Yes - put 'em all back call dPutBack(b) i = i - 1 end do else call pPutc(sRepc) !Yes - plug in the prefix call pPutc(i + 32) !Make the count printable endif endif if (fBit8 .and. b.gt.127) then !Do 8th-bit prefixing? call pPutc(sBit8) !Yes - output the prefix b = iand(b,127) !...then clear 8th bit endif if (b.lt.32 .or. b.eq.127 .or. b.eq.sQUOTE .or. > (b.eq.sBit8 .and. fBit8) .or. > (b.eq.sRepc .and. fRepc) ) then call pPutc(sQUOTE) !We need to quote a character if (b.lt.32 .or. b.eq.127) b = ctl(b) endif call pPutc(b) if (p .eq. DataMax) then !Packet exactly filled? goto 10 elseif (p .gt. DataMax) then !Packet too full? xBuf = pData(psave:p) !Save part that doesn't fit xbufL = p - psave !Save length of the overflow p = psave !Back up to last char that fits goto 10 !Done with this packet endif end do c Falling thru to here means we hit EOF in the disc file, or the packet c is full. If at EOF and this routine is called again, it will return c zero, and SDATA will know to go to EOF state. 10 slen = p - 1 buffill = slen return end integer*2 function dGetc(b) ,<890525.1144> >Get a disc-file byte implicit none c The RTE file-system doesn't readily accept the notion that a file c could be a "stream" of bytes. This subroutine fills that gap by c doing record unpacking and a limited "push-back" facility. include kercom.ftni,NOLIST include kerfil.ftni,NOLIST include kerdbg.ftni,NOLIST integer*2 dPutBack,b,pbbyt logical*2 EORpend integer*2 pbpt,err,fiBf(128) integer*2 FmpRead character pbbf*20 !Push-back buffer equivalence (fiCh,fiBf) data pbpt /0/ !if > 0, is a push-back pointer data EORpend /.false./ !EOR sequence is not pending if (pbpt .gt. 0) then !Was a byte pushed back? b = ichar(pbbf(pbpt:pbpt)) !Yes - get it pbpt = pbpt - 1 !Back up the push-back pointer goto 20 endif if (EORpend) then !Doing 2nd byte of EOR sequence? EORpend = .false. !Not any more b = 10 !Return the LF character goto 20 endif 10 if (fiPt .lt. 1) then !Need to read a record? fiLn = FmpRead(fiCb,err,fiBf,MAXREC) !Yes - do it if (err .lt. 0) then !File-read error? if (fBnry .and. err.eq.-12) then !EOF during binary mode? fiLn = -1 !Yes - show EOF else call ReportFileError(err,fiNm) !Else report other errors endif endif fiPt = 1 !Point to 1st byte endif if (fiLn .lt. 0) then !EOF? (always returns -1) b = -1 !NOTE: EOF can't be pushed back! goto 20 endif if (fiPt .gt. fiLn) then !EOR? fiPt = 0 !Yes - Arrange to get next record if (fBnry) goto 10 !Don't map EOR to CRLF if binary b = 13 !Else flag with a CR EORpend = .true. !Be sure to do 2nd byte of EOR else b = ichar( fiCh(fiPt:fiPt) ) !Get the current byte fiPt = fiPt + 1 !Point to next byte endif 20 dGetc = b !Return byte as function value return entry dPutBack(pbbyt) if (pbpt .ge. 20) then !Too many pushed back? ErrMsg = 'Too many bytes pushed back!' call kDebug(all,ErrMsg,' ') call SndErr call quit else if (pbbyt .ge. 0) then !(Don't push EOF back!) pbpt = pbpt + 1 !Bump the pointer pbbf(pbpt:pbpt) = char(pbbyt) !"push back" the byte endif return end subroutine BufEmp(len) ,<890525.1144> >Empty receive-buffer implicit none c This routine writes the packet buffer contents to the receiving c disc file. Note that the "LEN" parameter is actually a pointer c to the last data-byte in the packet (type-2/-3 checksums???) include kercom.ftni,NOLIST integer*2 ctl,i,len,b logical*2 f8Set integer*2 rep,j i = 5 !1st data byte is packet byte #5 do while (i .le. len+4) !put (len) bytes in disc file b = ichar(R1cPkt(i)) !Get next packet byte if (fRepc .and. b.eq.Repc) then !Is this my repeat-count char? i = i + 1 !Yes - bump to the count itself rep = ichar(R1cPkt(i))-32 !Get the count i = i + 1 !position to next byte b = ichar(R1cPkt(i)) !Get character to repeat else rep = 1 !Default repeat-count to 1 endif if (fBit8 .and. b.eq.Bit8) then !Do 8th-bit prefixing? f8Set = .true. !Yes - set the bit-8 flag i = i + 1 !...and bump the byte pointer b = ichar(R1cPkt(i)) else f8Set = .false. endif if (b .eq. Quote) then !If this is my quote character i = i + 1 !...bump the byte pointer b = ichar(R1cPkt(i)) !...and get the next byte if (b.ge.63 .and. b.le.95) then !if in range... b = ctl(b) !...de-controllify it (else it is endif !sent literally after a quote) endif if (f8Set) b = ior(b,200b) !Turn on 8th bit as needed do j = 1,rep !Repeat-count processing call dPutc(b) !Put the byte in the file end do i = i + 1 end do return end subroutine dPutc(b) ,<890525.1144> >Write byte in file-buffer implicit none include kerfil.ftni,NOLIST integer*2 b,err,fiBf(129) logical*2 CRpend !True if CR is pending logical*2 fEmpty !True if file-buffer is empty equivalence (fiCh,fiBf) data CRpend /.false./ c This routine is called with a single INTEGER parameter (b) being the c ichar() of the byte to store into the record, except: c b = -2: post the current (non-empty) record c b = -1: post the current record, empty or not c If b is any other negative number, it is not written to the file. if (b.eq.-2 .and. fEmpty) return !This was an un-needed post call fEmpty = .false. if (fBnry) goto 10 !Don't map CRLF to EOR if binary if (CRpend) then !Is a CR pending? CRpend = .false. !Yes - not after this stuff if (b.eq.10 .or. b.lt.0) then !Is this the logical EOR? b = -1 !Yes - flag it else fiPt = fiPt + 1 !Not EOR, so store the CR fiCh(fiPt:fiPt) = char(13) !...into the file endif endif if (b .eq. 13) then !Is this a CR? CRpend = .true. !Yes - flag it for next call return !Don't write it to the file (yet) endif ! Do end-of-record (EOR) processing if requested (b=-1) or if the ! record-buffer gets "full". 10 if (fiPt.ge.MAXREC .or. b.lt.0) then call FmpWrite(fiCb,err,fiBf,fiPt) if (err .lt. 0) then call ReportFileError(err,fiNm) endif fiCh = ' ' !Clear the record buffer fiPt = 0 !Reset char pointer fEmpty = .true. !"buffer is empty" endif if (b .ge. 0) then !Add this byte to the record? fiPt = fiPt + 1 !Yes - bump the pointer fiCh(fiPt:fiPt) = char(b) !...and add the byte endif return end logical*2 function fRetry(try) ,<890525.1144> >OK to retry? implicit none include kercom.ftni,NOLIST integer*2 try,tmax logical*2 IfBrk,fInit,tf logical*2 fRtryI !Alternate entry for initial retry tmax = MaxTry !Set for "normal" retry-limit fInit = .false. !Not doing initial retry limiting goto 10 entry fRtryi(try) tmax = ImxTry !Set for initial retry limit fInit = .true. !Doing initial retry-limiting 10 tf = .true. !Intialize to 'not ok to retry' if (try .gt. tMax) then ErrMsg = 'Retry limit exceeded' if (R .ne. L) call tpFm(ErrMsg) else try = try + 1 tf = .false. endif If (IfBrk()) then !Operator break? tf = .true. ErrMsg = 'Operator break' if (R .ne. L) call tpFm(ErrMsg) endif if ( fInit ) then !Doing Initial or normal? fRtryi = tf else fRetry = tf endif return end character*1 function RecPack(len,num) ,<890525.1144> >Read a packet implicit none include kercom.ftni,NOLIST include kerdbg.ftni,NOLIST include kersta.ftni,NOLIST integer*2 len,num integer*2 unchar,getpak integer*2 RecBuf,i,b,ck,type,numw1(3),numw2(3),check1 character num1*2,num2*2,work*10,rpinfo*256 equivalence (RecBuf,RecPkt),(num1,numw1(3)),(num2,numw2(3)) c By definition, anything I read in will terminate with EOLch (a c carriage-return), so all I need to do is left-justify the SYNC c portion in the packet-buffer. Packet input is always from the c REMOTE lu. The rest of the routine "parses" the packet into c fields by setting appropriate variables. c RECPACK returns the packet-type as its value, or a 'bad-packet' c indicator if the checksum is bad. The data length is returned c in LEN, and the sequence number is returned in NUM. c NOTE: it is assumed that type-ahead has been enabled prior to c calling this routine. RTE's internal I/O processing c makes "true" full-duplex impossible (see the code in c CONNECT for proof of this); type-ahead on the mux card c at least allows us to capture data sent to us before we c are actually ready to receive it. (While testing KERMIT c with two computers of different execution speed, data c losses DID occur because of the time needed to do stuff c between the sending of a packet and receipt of the ACK c or NAK.) 5 i = getpak() !Do system-dependent packet-read if ( btest(i,rtoBit) ) then !Did we time-out? recpack = 'T' !Give'em a time-out return endif if (rlen .lt. 1) goto 5 !Must have been just a rbytes = rbytes + rlen !Count bytes rovrhd = rovrhd + rlen !all are overhead for now RecPkt(rlen+1:) = ' ' !Clear unused part of packet call IBMrd !look for IBM-PROMPT as needed call kdebug(packets,'RecPack: ',RecPkt(:rlen)) rpak = rpak + 1 !Count a received packet p = index(RecPkt,char(Sync)) !Find the sync character if (p .lt. 1) goto 5 !No sync mark; retry read 10 if (p .lt. 1) then !No sync found? RecPack = 'T' !Act as if it timed out return endif if (p .gt. 1) then !Left-justify the sync byte rpinfo = RecPkt(p:) !(Ftn7x can't assign substring to RecPkt = rpinfo ! a variable of the same name) rlen = rlen - (p - 1) !Adjust the packet-length p = 1 !Reset the pointer to the mark endif len = -1 !Clear the field variables to num = -1 ! allow each field to be picked type = -1 ! off in the correct order i = 0 !Clear the data-byte counter do while (p .le. rlen) !Scan the packet p = p + 1 !Go to next byte b = ichar(R1cPkt(p)) !...and get it if (b .eq. Sync) then !Re-sync? goto 10 else if (len .lt. 0) then !Do data-length field len = unchar(b)-2-sCheck !...set data length else if (num .lt. 0) then !Do sequence-number field num = unchar(b) else if (type .lt. 0) then !Do packet-type field type = b else if (i .lt. len) then !Do packet-data field (if any) i = i + 1 !Count a data byte else !Do checksum field ck = check1(R1cPkt,p) !Compute the checksum b = unchar(b) if (ck .ne. b) then !bad checksum? recpack = 'X' !...report it to sender call cnumd(ck,numw1) !computed cksm --> ASCII call cnumd(b,numw2) !actual cksm --> ASCII work = num1 // ', got ' // num2 call kdebug(packets,'Bad Checksum, needed ',work) else recpack = char(type) endif rlen = p !Note the end of the packet rovrhd = rovrhd - len !Adjust overhead for data count return endif end do ErrMsg = 'Illegally formed packet' recpack = '!' !!!!If we got here, we ran out of data return end integer*2 function ctl(b) ,<890525.1144> >Make controls printable implicit none c Toggle the 7th bit of a byte such that CTRL-A <--> A integer*2 b ctl = ixor(b,64) return end subroutine pPutc(b) ,<890525.1144> >Store a packet-data byte implicit none include kercom.ftni,NOLIST integer*2 b p1ata(p) = char(b) !Store the byte p = p + 1 !...and count it return end subroutine recpar(len) ,<890525.1144> >Save other's parameters implicit none include kercom.ftni,NOLIST include kercnf.ftni,NOLIST !Defines fRmx integer*2 len integer*2 pblocksize parameter (pblocksize = 9) integer*2 sdefs(pblocksize) !Remote default parameters integer*2 unchar,ctl,pgetc,i,b,maxp Data sdefs / !Set default remote parameters > 80, !Maximum packet = 80 bytes > 30, !receive timeout = 30 seconds > 0, !no padding required > 0, !(padding uses nulls) > 13, ! terminates a packet > 35, !Control-quoting uses "#" > 32, !No 8th-bit prefixing will be done > 1, !1-byte checksums > 32/ !No repeat-counts will be done call MoveWords(sdefs,sPkSiz,pblocksize) !Set remote defaults call Set_Timeout(R,sTime*100,fRmx) !Preset remote timeout NewChk = 1 !Reset default checksum type p = 5 !Start with the MAXL field fBit8 = .false. !No 8th-bit stuff unless agreed fRepC = .false. !No repeat-count unless agreed maxp = rlen - 1 !Get last param pos (w/ checkt=1) do i = 1,pblocksize !parse each parameter field if (p .gt. maxp) then !Past end of received data? sPcnt = i - 1 !Save # of parameters passed return endif b = ichar(R1cPkt(p)) !Get a parameter byte if (b .eq. 0) return !Done? p = p + 1 !bump the byte pointer if (i .eq. 1) then !Packet size? sPkSiz = min(94,unchar(b)) else if (i .eq. 2) then !Timeout value? b = unchar(b) !Yes - get it as usual sTime = b !Copy it to parameter block call Set_timeout(R,b*100,fRmx) !...and set the timeout up else if (i .eq. 3) then sPad = unchar(b) else if (i .eq. 4) then !Is it the pad character? sPadch = ctl(b) else if (i .eq. 5) then !EOL character? sEOL = unchar(b) else if (i.eq.6) then !Quote character? sQuote = b else if (i.eq.7) then !8th-bit prefix character? call valBquote(b) else if (i.eq.8) then !Checksum type? if (b.gt.48 .and. b.lt.52) NewChk = b-48 !Allow only '1'-'3' ChkTyp = NewChk !>>>1.98c I'll use that checksum-type too else if (i.eq.9) then !Repeat-character prefix? sRepc = b !Yes - save it if (b.eq.Repc .and. b.gt.32) then !If same as mine & not blank fRepc = .true. !...then we'll do it endif endif end do return end subroutine SndPar(ptype,num) ,<890525.1144> >Send my parameters implicit none include kercom.ftni,NOLIST integer*2 num integer*2 i,ctl,toChar,svCheck character*1 ptype toChar(i) = i+32 !Raise controls to printable svCheck = sCheck !Save partner's checksum type sCheck = 1 !Always send params w/ 1-byte check p = 1 !Reset the packet pointer pdata = ' ' !Remove the old data call pPutc(toChar(PakSiz)) !Send my current packet size call pPutc(toChar(Timeout)) !Set my timeout in call pPutc(toChar(nPad)) !I don't need padding call pPutc(ctl(Padch)) !(and my pad-character is NULL) call pPutc(toChar(EOLch)) !My EOL is always 13 call pPutc(Quote) !Give 'em my quote character call pPutc(Bit8) !...and my 8th-bit prefix call pPutc(ChkTyp + 48) !Show which checksum type I want call pPutc(Repc) !Give 'em my repeat character i = min(sPcnt,9) !Don't send too many parameters call SndPack(ptype,num,i) !Now send the packet sCheck = svCheck !Restore partner's checksum type return end integer*2 function unchar(ch) ,<890525.1144> >Undo "TOCHAR" operation implicit none integer*2 ch unchar = ch - 32 return end subroutine fClose ,<890525.1144> >Close current s/r file implicit none include kerfil.ftni,NOLIST integer*2 err integer*4 r,p if (fbnry) then !Need to trim a type-1 transfer? call FmpPosition(fiCb,err,r,p) !Yes - where are we in the file? call FmpTruncate(fiCb,err,r-1) !...truncate at one record less endif call FmpClose(fiCb,err) return end subroutine SendAbort ,<890525.1144> >Kill all send stuff implicit none include kercom.ftni,NOLIST include kerfil.ftni,NOLIST integer*2 err call fClose call FmpEndMask(maCb) c --> More to do??? return end subroutine success(pass) ,<890525.1144> >Print pass/fail if local implicit none include kercom.ftni,NOLIST logical*2 pass if (R .ne. L) then !If we are local... call tpFm('_') !Sound the bell call sleep(100) if (pass) then call tpFm('File transfer(s) completed') else call tpFm('File transfer(s) failed') endif call sleep(100) call tpFm('') !Beep again endif return end subroutine startstats ,<890525.1144> >Start statistics logging implicit none include kersta.ftni,NOLIST integer*4 timenow c Clear all counters associated with the 'last transfer' spak = 0 !Packets sent rpak = 0 !Packets received rtry = 0 !# of retries (sent or received) sbytes = 0 !Bytes (total) sent rbytes = 0 !...and recieved sovrhd = 0 !Overhead bytes sent rovrhd = 0 !...and received startim = timenow() !Start the clock return end subroutine endstats ,<890525.1144> >End statistics logging implicit none include kersta.ftni,NOLIST integer*4 timenow trpak = trpak + rpak !Total the packets received tspak = tspak + spak !Total the packets sent trtry = trtry + rtry !Total the packets retried endtim = timenow() !Stop the clock if (endtim .lt. startim) then !Did we cross midnight? endtim = endtim + 86400J !Yes - add a day's seconds endif return end subroutine ValBQuote(b) ,<890525.1144> >Validate BQuote param implicit none include kercom.ftni,NOLIST integer*2 b,BIGY,AMPERSAND parameter (AMPERSAND = 38) parameter (BIGY = 89) sBit8 = b !Save partner's 8-th bit character fBit8 = .false. !Preset BQuote processing off if (.not. f8OK) return !Don't process if user has it off if (b .eq. BIGY) then !Partner wants to use my byte? fBit8 = .true. !Yes - turn it on if (.not. fSend) then !If I am to receive... Bit8 = AMPERSAND !...need to use default bquote endif sBit8 = Bit8 !Set sender's BQuote to mine return endif if ((b.gt.32 .and. b.lt.63) .or. (b.gt.95 .and. b.lt.127)) then Bit8 = b !Remote: "Do it with this byte" fbit8 = .true. !Flag the agreement endif return end subroutine doIpacket ,<890525.1144> >Process 'I' packet implicit none include kercom.ftni,NOLIST include kerfil.ftni,NOLIST !To define fBnry ! This routine's purpose is to perform all of those ! "set param value" ! on receipt of a server I (initialize) packet. We are currently only ! interested in the quote, bquote, and repeat characters, and the ! checksum type. Note that if b-quoting is disabled and parity isn't ! none, we will not be able transfer binary, so if that flag is on, ! turn it off! Quote = sQuote !Set myself to partner's quote Bit8 = sBit8 !...and partner's bquote f8OK = Bit8 .ne. 32 !Allow binary quoting? ChkTyp = sCheck !Partner wants special checksums? Repc = sRepc !Get partner's repeat character if (fBnry .and. Parity.ne.3 .and. .not.f8OK) fBnry = .false. return end character*1 function seof(retry) ,<890525.1144> >Send the EOF packet implicit none include kercom.ftni,NOLIST include kerfil.ftni,NOLIST integer*2 retry,num,len,err,FmpOpen logical*2 fRetry character*1 ptype,RecPack character*4 openopts if ( fRetry(retry) ) then seof = '!' call SendAbort return endif call SndPack('Z',seq,0) !Send the EOF packet seof = state !Assume no change in state ptype = RecPack(len,num) !Get the response if (ptype .eq. 'T') then !Time-out? return !just retry else if (ptype .eq. 'E') then !Error packet? ErrMsg = 'Receiver error: ' // RecPkt(5:len+4) seof = 'E' call SendAbort return else if (ptype .eq. 'N') then !NAK? if (mod(seq+1,64) .ne. num) then return else ptype = 'Y' num = num - 1 endif endif if (ptype .eq. 'Y') then !ACK? if (num .ne. seq) return retry = 0 call fClose !Close the current file seq = mod(seq+1,64) !Set next sequence number seof = '@' else !Unknown packet type ErrMsg = 'Unknown packet type: ' // ptype seof = '!' !Abort the transfer call SendAbort !Close sending/search files endif return end subroutine SndErr ,<890525.1144> >Send error-packet implicit none include kercom.ftni,NOLIST integer*2 len,TrimLen pdata = ErrMsg len = TrimLen(pdata) if (fPkIO) then call SndPack('E',seq,len) !Send error-packet if (R .ne. L) call tpFm(ErrMsg) !Inform local user else call tpFm(ErrMsg) endif return end subroutine sndpack(type,num,len) ,<890525.1144> >Transmit a packet implicit none c NOTE: it is assumed that asynchronous interrupts on the remote c LU have been disabled prior to this routine. include kercom.ftni,NOLIST include kerdbg.ftni,NOLIST include kersta.ftni,NOLIST character*1 type integer*2 num,len integer*2 i,j,check1,check2,check3 character*1 toChar toChar(i) = char(i+32) !Raise controls to printable range i = sPad + len + 5 + sCheck !Compute length of packet sbytes = sbytes + i !Count 'em sovrhd = sovrhd + i - len !Adjust overhead for data if (sPad .gt. 0) then !Need to do padding? do i = 1,50 !Yes - build a pad-character buffer P1cket(i) = char(sPadCh) end do do i = 1,sPad,50 !Send padding in 50-byte pieces j = min(50,sPad-(i-1)) !Set tx count (don't overdo padding!) call putpak(j) end do endif Packet = char(sSync) !Clear packet/install sync byte P1cket(2) = toChar( len+2+sCheck ) !...and the length byte P1cket(3) = toChar( num ) !...and the sequence number P1cket(4) = type !...and the packet type Packet(5:) = pData !...add the data part p = 5 + len !Adjust the store-pointer P1cket(p) = toChar(check1(P1cket,p))!Perform/store the checksum p = p + 1 !Bump pointer for EOL character if (sCheck .ne. 1) then !Do 2- or 3-byte checks? P1cket(p) = toChar(check2()) !Yes - add the 2nd byte p = p + 1 endif if (sCheck .eq. 3) then !Doing 3-byte CRC? P1cket(p) = toChar(check3()) !Yes - add last byte p = p + 1 endif P1cket(p) = char(sEOL) !Voila - packet is ready to send call kdebug(packets,'SndPack: ',packet(:p)) call putpak(p) !send the packet spak = spak + 1 !Count the packet return end integer*2 function Check1(pack,plen) ,<890525.1144> >Generate checksums implicit none ! When called as Check1, this function calculates the 1- or 2-byte ! checksum or a 3-byte CRC, AS DICTATED BY MY PARTNER'S PARAMETERS! ! The part of the packet which is subject to checking is the length ! field through the current value of "P" (the pointer to the next ! byte of the packet) less 1. It is called either to encode the ! checksum/CRC or to test it on a received packet. The returned ! value of Check1 is the first of a possibly multi-byte checksum or ! CRC. Check2 and Check3 return the remaining bytes of the 2-byte ! checksum or 3-byte CRC as needed. Note that the form of the 1st ! byte of the 1- and 2-byte checksums is NOT the same!. include kercom.ftni,NOLIST character*1 pack(*) integer*2 plen,i,csum,b integer*2 check2,check3 integer*2 x,y,crc1(0:15),crc2(0:15) data crc1 / >000000b,010201b,020402b,030603b,041004b,051205b,061406b,071607b, >102010b,112211b,122412b,132613b,143014b,153215b,163416b,173617b/ data crc2 / >000000b,010611b,021422b,031233b,043044b,053655b,062466b,072277b, >106110b,116701b,127532b,137323b,145154b,155745b,164576b,174367b/ csum = 0 !Clear checksum accumulator do i = 2,plen-1 !Checksum length thru data b = ichar( pack(i) ) !Get a packet byte if (sCheck .ne. 3) then !Doing 1- or 2-byte checks? csum = csum + b else !else doing CCITT-CRC b = ixor(b,csum) x = iand(b,17b) !Get lower nybble y = ibits(b,4,4) !...and upper nybble b = ixor(crc2(x),crc1(y)) !Get CRC factor csum = ibits(csum,8,8) !Shift off byte from previous CRC csum = ixor(csum,b) !and add in new value endif enddo if (sCheck .eq. 1) then !Return proper 1-byte checksum check1 = iand( 63,(csum + (iand(csum,192)/64))) !Form type-1 check elseif (sCheck .eq. 2) then !Return 1st of 2-byte checksum check1 = ibits(csum,6,6) !...as upper 6 of 12-bit checksum else !Return 1st of 3-byte CRC check1 = ibits(csum,12,4) !...as upper 4 of 16-bit CRC endif return entry check2() if (sCheck .eq. 2) then !Return 2nd of 2-byte checksum check2 = iand(csum,77b) !...as lower 6 of 12-bit checksum else !else return 2nd of 3-byte CRC check2 = ibits(csum,6,6) !...as bits 6-11 of 16-bit CRC endif return entry check3() check3 = iand(csum,77b) !Return low 6 bits of CRC return end subroutine get ,<890525.1144> >Get from a server implicit none include kercom.ftni,NOLIST include kercmd.ftni,NOLIST include kerfil.ftni,NOLIST logical*2 succeed,receive,fRetry,fRtryi integer*2 retry,err,len,num,TrimLen,j character*1 ptype,RecPack retry = 0 !Reset the retry-counter 5 if ( fRtryi(retry) ) then !Retry-limit exceeded? call tpFm('Unable to initialize on a Get command') return endif call SndPar('I',seq) !Try to initialize ptype = RecPack(len,num) !Get the response if (ptype .eq. 'Y') then !ACK? if (num .ne. seq) goto 5 !Retry if out of sequence endif seq = 0 !Reset the sequence number retry = 0 !...and retry counter pdata = GetMask !Set 1st param as get's data j = TrimLen(pdata) !Get the name's length 10 if ( fRetry(retry) ) then !Exceeded the retry limit? call tpFm('Unable to GET') return endif call SndPack('R',seq,j) !Send the request for files ptype = RecPack(len,num) !Get the response if (ptype .eq. 'S') then !Correct response is send-init if (num .ne. seq) goto 10 fSend = .false. !Do params as a receive call RecPar(len) !get partner's parameters if (fBnry .and. Parity.ne.3 .and. .not.fBit8) then ErrMsg = 'Can''t receive binary file (parity problem)' call SndErr fBnry = .false. return endif call SndPar('Y',seq) !...and send mine sCheck = NewChk !Change checksum type now seq = mod(seq+1,64) succeed = receive('F') !Try to receive call success(succeed) sCheck = 1 !Revert to 1-byte checksums return else if (ptype .eq. 'E') then !Error packet? call tpCh('Received error packet: -',RecPkt(5:len+4),0) return else if (ptype .eq. 'X') then !Checksum error? call tpFm('Checksum error - retrying') else if (ptype .eq. 'T') then !Time-out? call tpFm('') else call tpCh('Unknown packet type: -',ptype,1) endif goto 10 end subroutine IBMrd ,<890525.1144> >Look for IBM-prompt implicit none include kercom.ftni,NOLIST include kercnf.ftni,NOLIST !To define remote configuration include kersta.ftni,NOLIST integer*2 xr(2),rc equivalence (xr(2),rc) if ( fIBM ) then !Need to wait for PROMPT? xr = R if ( btest(iRmx,0) ) then !D-mux? Rc = 100b !Yes - just set for binary else Rc = 1100b !Binary + keep type-ahead data endif p = 18 !Yes - read at least one byte do while (p .ne. 17) !Look for prompt byte rbytes = rbytes + 1 rovrhd = rovrhd + 1 call xluex(1,xr,p,-1) p = ishft(p,-8) !Move byte for look for IBM-PROMPT end do endif return end subroutine PakIO ,<890525.1144> >Prepare for packet-I/O implicit none include kercom.ftni,NOLIST include kercnf.ftni,NOLIST if (R .eq. L) then !If remote-host mode... call disable(R,fRmx) !...disable scheduling call KillEnqAck !...and handshake endif call control(R,2600b,1) !Clear all input buffers fPkIO = .true. seq = 0 !Reset sequence# return end subroutine NrmIO ,<890525.1144> >Restore from packet-I/O implicit none include kercom.ftni,NOLIST include kercnf.ftni,NOLIST !Defines fRmx sCheck = 1 !Revert to 1-byte checksums fPkIO = .false. if (R .eq. L) then call restore(R) call enable(R,fRmx) endif return end