home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
kermit.columbia.edu
/
kermit.columbia.edu.tar
/
kermit.columbia.edu
/
hp1000
/
kermit.ftn
< prev
next >
Wrap
Text File
|
2011-08-10
|
172KB
|
4,486 lines
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/ ! <CR> 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,'<transfer-file>')
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 <escape-character>"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 "<esc>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 <file-name>')
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 <file-name> 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 <value from 1 to 30>')
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 <control-character code>')
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 [<logical unit #>]')
else
call tpFm('Usage: SET LINE <logical unit #>')
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 <number from 31 to 94>')
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 <number from 1 to 3>')
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 <number from 33 to 126>')
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 <value (32-62 or 96-126)>')
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 <value (33-62 or 96-126)>')
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 <number from 5 to 30> [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 <number from 1 to 31>')
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 <file-descriptor>')
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 <remote-name> [<local-name>]')
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('<timed out>')
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('<timed out>')
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 <CR>
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, !<CR> 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('<timed out>')
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