home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
d
/
cray.cft
< prev
next >
Wrap
Text File
|
2020-01-01
|
100KB
|
2,618 lines
!-cr.filing-!
subroutine makedata(seq, result)
implicit integer(a-z)
! Function : This routine is called from the SEND state to make
! a new 'D' packet. It gets file data from the character
! buffer, calling the virtual disk read routine BUFIN
! whenever the buffer is empty. Logical Rtne. BUFIN
! evaluates .false. iff a disk read fails; it sets
! its second argument .true. iff the current buffer
! contains the EOF indicator. Makedata converts CTSS
! EOL characters to quoted CR,LF sequences, and other
! embedded file control characters to the standard
! Kermit quoted/controlified sequences.
! Called Procedures : bufin, errorpkt, kctl, kchar
parameter( full = 0, lastpkt = 1, nopkt = 3, err = 4)
parameter( US = 037b, FS = 034b, SOH = 1, CR=13, LF=10)
parameter( px = 1, ok = 0 )
parameter( rpmax = 94, cutoff = 4 )
logical bufin, last, lastbuf, debug, native, quote8, repeat
character *504 buffer
character *104 packet(2)
character cmdstr*80, report*40
character kchar, cksum, quote, kctl, pchar, old
character eolseq*4, pktseq*6
character*9 myparms, hisparms, defaults
common /packets/ packet
common /buffers/ buffer
common /pkstats/ bptr, bufhold, maxpack, lastbuf, rpcount
common /runparms/ myparms, hisparms, defaults
common /strings/ cmdstr, report
common /environ/ debug, native, quote8, repeat
pkptr = 5 ! pt to 1st data char in pkt
quote = myparms(6:6) ! quote char to send
eolseq = quote//kctl(char(CR))
! // quote // kctl(char(LF))
if (rpcount.gt.0) then ! remnant left from last pkt
old = buffer(bptr-1:bptr-1) ! repeated char for comparison
end if
10 continue ! top of packing loop
if (bptr.gt.bufhold) then ! buffer empty
if (rpcount.gt.0) then ! we are in a run
! Truncate run at end of buffer
bptr = bptr - 1 ! index last char of run
go to 100 ! put remnant in pkt first
else if (.not.(lastbuf))then ! there's file data left
! use next test to force evaluation of read fn :
if (.not.(bufin(buffer,last))) then
report = 'file read error.'
result = err
go to 900 ! exit with the bad news
else if (last) then ! this evaluation got last chunk
lastbuf = .true. ! remember this
end if
else if (pkptr.gt.5) then ! final packet a shorty
result = lastpkt
go to 400 ! go polish it off now
else ! starting pkt - no data to pack
result = nopkt
go to 900 ! go return with this news now
end if
end if ! if buffer empty
pchar = buffer(bptr:bptr) ! get next buffer char
if (repeat) then ! we're doing repeat prefixing
if (rpcount.eq.0) then ! start a new scope
old = pchar
rpcount = 1
bptr = bptr + 1
go to 10 ! go get next data character
else if (pchar.eq.old) then ! old scope continues
rpcount = rpcount + 1
if (rpcount.lt.rpmax) then
bptr = bptr + 1
go to 10
end if ! else truncate here
else ! pchar ends old scope
bptr = bptr - 1 ! index last char of run
end if ! if rpcount
else ! we're not doing repeats
old = pchar
rpcount = 1
end if
100 continue
savect = rpcount
! First look for the special cases :
if ((native).and.(old.eq.char(FS))) then
if (pkptr.gt.5) then ! EOF found - truncate pkt
result = lastpkt
go to 400
else ! starting pkt & hit EOF
result = nopkt
go to 900
end if
else ! these are the std cases
j = 1 ! minimum length we need
! Does char need a repeat prefix ?
if ((repeat).and.(rpcount.ge.cutoff)) then
pktseq(j:j+1) = '~' //kchar(rpcount)
j = j+2
rpcount = 1
end if ! if repeat prefixed
if ((quote8).and.(ichar(old).ge.200b)) then
pktseq(j:j) = '&'
old = char(ichar(old).and.177b)
j = j +1
else if ((native).and.(old.eq.char(US))) then
! we have to convert this to std text EOL sequence
pktseq(j:j+3) = eolseq
j = j+3
go to 120
end if ! if 8th bit prefixing
! now encode lo-order 7 bits of the char, if needed
if ((ichar(old).gt.037b).and.(old.ne.char(177b))
! .and.(old.ne.quote)
! .and.((old.ne.'&').or.(.not.(quote8)))
! .and.((old.ne.'~').or.(.not.(repeat))) )
! then ! it needs no quoting
pktseq(j:j) = old
else
pktseq(j:j) = quote
if ((old.ne.quote).and.(old.ne.'&').and.(old.ne.'~'))
! then ! transform the quoted char
old = kctl(old)
end if
j = j + 1
pktseq(j:j) = old
end if
end if ! end of all char cases
120 continue
do 170 i=1,rpcount
seqend = pkptr + j - 1
if (seqend.le.maxpack) then ! there's room
packet(px)(pkptr:seqend) = pktseq(1:j)
pkptr = seqend + 1
else ! coded char wont fit in pkt
if (savect.ge.cutoff) then ! it was repeat prefixed
rpcount = savect - 1
else if (rpcount.gt.1) then ! it was a mini-run
bptr = bptr - (savect-i) ! index first excluded char
rpcount = 0 ! and let it start new scope
else
rpcount = 0
end if
go to 200
end if ! if room
170 continue
rpcount = 0
bptr = bptr + 1
if(pkptr.le.maxpack) go to 10
200 result = full
400 continue
packet(px)(2:2) = kchar(pkptr-2) ! coded count
packet(px)(3:3) = kchar(mod(seq,64))
packet(px)(4:4) = 'D'
packet(px)(pkptr:pkptr) = cksum(packet(px))
900 continue
return
end ! subroutine makedata
subroutine putdata(px,result)
implicit integer(a-z)
! Function : This routine is called in the RECEIVE state to
! process a 'D' packet. It packs the data portion
! of a 'D' pkt into the character buffer, replacing
! quoted and/or prefixed sequences if necessary.
! If file is CTSS native, quoted CR,LF sequences are
! stored as the single ctss EOL character, Ascii US.
! Evaluation of logical function bufout forces transfer
! of contents of character buffer into the sector-sized
! word buffer dkbuf which is managed by bufout.
! Called Procedures : kctl, unchar, bufout
parameter( CR=015b, LF =012b, US = 037b )
parameter( buflen = 504 ) ! bufsize = max char string
parameter( ok=0, error=1 ) ! putdata return codes
character *504 buffer
character*104 packet(2)
character*9 myparms, hisparms, defaults
character kctl, quote, qchar, pchar
logical bufout, eofsw, hibit, debug, native, quote8, repeat
! ,lastbuf, savedcr
common /runparms/ myparms, hisparms, defaults
common /packets/ packet
common /buffers/ buffer
common /pkstats/ bptr, bufleft, maxpack, lastbuf
! , rpcount, savedcr
common /environ/ debug, native, quote8, repeat
quote = hisparms(6:6) ! get partner's quote char
eofsw = .false.
hibit = .false.
pkptr = 5 ! index 1st data char
pkend = unchar(packet(px)(2:2)) + 1 ! index last data char
10 continue ! top of packing loop
if (pkptr.gt.pkend) then ! Reached end of packet
result = ok
go to 800
end if
pchar = packet(px)(pkptr:pkptr) ! Get next packet character
! Check for repeat prefix
if ((repeat).and.(pchar.eq.'~')) then
pkptr = pkptr + 1 ! Index count char
count = unchar(packet(px)(pkptr:pkptr))
pkptr = pkptr + 1
pchar = packet(px)(pkptr:pkptr)
else
count = 1
end if ! if repeat
if ((quote8).and.(pchar.eq.'&')) then
hibit = .true.
pkptr = pkptr + 1 ! Index prefixed character
pchar = packet(px)(pkptr:pkptr)
else
hibit = .false.
end if ! If 8th bit quoting
if (pchar.eq.quote) then ! Character is quoted ctl
pkptr = pkptr + 1 ! Index the quoted character
pchar = packet(px)(pkptr:pkptr)
if ((pchar.ne.quote).and.(pchar.ne.'&').and.(pchar.ne.'~'))
! then
pchar = kctl(pchar) ! Transform quoted character
end if
end if ! If quoted sequence
if (hibit) then ! Char had an 8th bit prefix
pchar = char(ichar(pchar).or.200b)
else if ((native).and.(count.eq.1)) then
! Map incoming CR,LF sequences to CTSS end-of-line char
if ((pchar.eq.char(LF)).and.(savedcr)) then
pchar = char(US) ! Replace by native EOL char
savedcr = .false.
else if (savedcr) then ! Previous CR not in a sequence
pchar = char(CR)
savedcr = .false.
pkptr = pkptr - 1 ! Pick up current char nxt time
else if (pchar.eq.char(CR)) then
savedcr = .true.
end if
end if
if (.not.(savedcr)) then ! Put char into buffer
do 40 i=1,count
if (bptr.gt.buflen) then ! Need to empty buffer first
if (.not.(bufout(buffer,eofsw))) then
result = error
go to 800
end if
end if
buffer(bptr:bptr) = pchar ! Put pkt char into buffer
bptr = bptr + 1
40 continue
end if
pkptr = pkptr + 1
go to 10 ! Bottom of unpacking loop
800 continue
return
end ! subroutine putdata
logical function puteof(usrfil)
implicit integer(a-z)
! Function : This routine is called in the RECEIVE state to
! process a 'Z' packet. It terminates CTSS native but not
! other, files with an Ascii FS character, and
! evaluates the logical function bufout with 2nd arg
! set .true. to force a write of the last sector now.
! If user's filespace has an old copy of the receive file,
! this copy is destroyed before switching receive file's
! name from the interim 'kmtfil' to name in 'F' pkt.
! Called Procedures : bufout, logline, kfdelete, kfswitch
parameter( buflen = 504 ) ! max length character string
character dum1*4 ! debuggery
logical debug, native
character kchar
character *504 buffer
character cmdstr*80
logical oldfile, bufout, kfdelete, kfswitch
parameter( NULL = 0, FS = 034b, US = 037b )
common /buffers/ buffer
common /pkstats/ bptr, bufleft
common /strings/ cmdstr
common /environ/ debug, native
dimension beta(4)
if (native) then ! File needs CTSS EOF terminator
if (bptr.gt.buflen) then ! Buffer already full
if(.not.(bufout(buffer,.false.))) go to 300
end if ! else evaluation emptied buffer
buffer(bptr:bptr) = char(FS)
bptr = bptr + 1
end if
nx = mod(bptr-1,8) ! Index last byte used in final word
if (nx.ne.0) then ! Pad out last word with nulls
wdend = bptr + 7 - nx
do 200 i=bptr,wdend
buffer(i:i) = char(NULL)
200 continue
bptr = wdend + 1
end if
if (bufout(buffer,.true.)) then ! final write succeeeds
! see if we are replacing an existing copy
inquire(iostat=ios,file=cmdstr(1:8),exist=oldfile)
if (ios.eq.0) then
if (oldfile) then
call logline('old file copy exists$$')
if (.not.(kfdelete(usrfil))) go to 300
end if ! if oldfile
if (kfswitch(usrfil)) then ! if std file renemed ok
puteof = .true.
go to 400
end if ! if kfswitch
end if ! if ios
end if ! if bufout
300 puteof = .false.
400 continue
return
end ! logical fn puteof
logical function bufin(string,last)
implicit integer(a-z)
! Function : This is a virtual disk read routine.
! It packs 63 words from the sector-sized buffer dkbuf
! into the buffer used as caller's first argument.
! BUFIN resets the string pointers bptr and bufhold.
! When dkbuf is empty, BUFIN evaluates the logical
! function KFREAD to force a physical disk sector read.
! Upon return from BUFIN, the parameter LAST is true
! iff current string is the last of the file.
! Called Procedures : kfread.
! .
parameter( fs = 034b )
dimension string(63) ! treat 504 char buf as 63 words
dimension dkbuf(512) ! sector-sized buffer
logical dkempty, kfread, last
common /units/ logioc, fioc, dkctr, dkbuf, nsectors
! ,fptr, dkptr, dkhold
common /pkstats/ bptr, bufhold
place = 1 ! Index 1st word of string
10 continue
dkempty = .false.
do 20 i=place,63
if (dkptr.gt.dkhold) then
dkempty = .true.
go to 40
else
string(i) = dkbuf(dkptr) ! put a word into string
dkptr = dkptr + 1 ! Index next sector word
end if
20 continue
40 if (.not.(dkempty)) then ! String is full
sx = 63
else if (dkctr.eq.nsectors) then ! Exhausted last sector
sx = i - 1 ! Index last string word used
else if (.not.(kfread())) then ! Forced sector read failed
bufin = .false.
go to 800
else ! Sector buffer replenished
place = i ! Index next string word
go to 10 ! Go continuing filling string
end if
bptr = 1 ! Point to start of string
bufhold = sx*8 ! Num. bytes in string
! Is this the last string of the file ?
if ((sx.eq.63).and.((dkctr.lt.nsectors).or.(dkptr.le.dkhold)))
!then
last = .false.
else
last = .true.
end if
bufin = .true.
800 continue
return
end ! logical function bufin
logical function bufout(string,eof)
implicit integer(a-z)
! Function : This is a virtual disk write routine that packs the
! contents of the caller's buffer into the 512-word sector
! buffer dkbuf. Caller's buffer is assumed to be at most
! 504 characters long (the maximum CFT string), with bptr
! indexing past the last position used, and is treated as
! an array of 63 words. When dkbuf is full, or if entered
! with eof argument .true., kfwrite is called to do the
! physical disk write.
! Called Procedures : kfwrite, kfprune, logline, tdisp
logical eof, dkfull, kfwrite
parameter( buflen = 504 ) ! max num. chars in string
parameter( sector = 512 )
logical debug
common /pkstats/ bptr, bufhold
common /units/ logioc, fioc, dkctr, dkbuf(sector), nsectors,
! fptr, dkptr, dkhold
common /environ/ debug
character*4 dum1
dimension string(63) ! treat 504 chars as 63 words
nchar = bptr - 1 ! num. chars in string
nwords = nchar/8 ! num. words in string
dkfull = .false.
do 20 i=1,nwords
if(dkptr.gt.sector) then
dkfull = .true.
go to 30
else
dkbuf(dkptr) = string(i)
dkptr = dkptr + 1
end if
20 continue
! see if string fit into dkbuf
30 if (dkfull) then ! it didn't
if (kfwrite(sector)) then ! wrote dkbuf to disk
do 50 j=i,nwords ! put string remnant in new buf
dkbuf(dkptr) = string(j)
dkptr = dkptr + 1
50 continue
else ! if write failed
bufout = .false.
go to 400
end if ! if kfwrite
end if ! if dkfull
bufout = .true. ! Default evaluation
if (.not.(eof)) then
bptr = 1 ! indicate string empty
bufhold = buflen
else ! Write final partial sector
nsiz = dkptr - 1 ! num. words in last sector.
if(kfwrite(nsiz)) then
fwords = (dkctr-1)*sector + nsiz ! real file size in words
call kfprune(fwords) ! make file size exact
if (debug) then
call tdisp(fwords,dum1)
call logline('At EOF - file size is : '//dum1//' words$$')
end if
else
bufout = .false.
end if ! if kfwrite
end if ! if eof
400 continue
return
end ! logical fn bufout
!-cr.kermain-!
! Kermit-CR - LANL Cray Kermit
!
! Author : Leah Miller,
! Computer User Services Group (C-10)
! Los Alamos National Laboratory
! Los Alamos, New Mexico 87545
!
! Arpanet address : lfm@lanl
!
!*******************************************************************
! Copyright, 1984, The Regents of the University of California.
! This software was produced under a U.S. Government contract
! (W-7405-ENG-36) by the Los Alamos National Laboratory, which is
! operated by the University of California for the U.S. Department
! of Energy. The U.S. Government is licensed to use, reproduce and
! distribute this software. Permission is granted to the public to
! copy and use this software without charge, provided that this notice
! and any statement of authorship are reproduced on all copies.
! Neither the Government nor the University makes any warranty,
! express or implied, or assumes any liability or responsibility
! for the use of this software.
!*******************************************************************
! Acknowledgement : The Kermit Protocol was developed by the
! Columbia University Center for Computing
! Activities (CUCCA), N.Y., N.Y., USA
! Kermit-CR runs on the Cray-1 and Cray X-MP computers, under
! the CTSS (Cray Time-Sharing System) Operating System.
! It is written in CFT, the Cray version of Fortran-77.
! All input/output functions are done by invoking CTSS operating
! system functions from low level Fortran subroutines.
!
! Kermit-CR is a remote host Kermit. It has a server
! and can time out. File transfer interrupt packets from
! local Kermits are recognized. Default file transfer
! mode is CTSS native text. In this mode the single character
! CTSS end-of-line indicator (Ascii US) is converted to
! the standard quoted CR,LF sequence on sends, and vice-versa
! on receives. If this option is disabled by user's command
! "set native off", only the standard Kermit quoting of control
! characters is done. Binary files may be transferred via 8th bit
! quoting if the local Kermit also has this capability.
! Data compression via repeat prefixing will be done if the other
! Kermit agrees.
! Wildcard sends are not done, but more than one file may be
! specified on a send command (non-server mode).
! The Kermit-CR server cannot log itself it, so that a local
! Kermit's "finish" or "bye" command will cause exit from
! Kermit-CR and return to the CTSS level.
!
! Installers should note that Cray-1 and Cray X-MP, under CTSS,
! accept line, not character, input. Network line concentrator
! hardware may impose a maximum message length of less than
! the maximum Kermit packet length. This hardware may also perform
! echoback of terminal messages. If the local Kermit does not
! check incoming packet type (and ignore packets of type just sent),
! then the local Kermit may use appropriate PAD and EOL characters
! to disable concentrator echoback.
! Site Dependancy : Some network line concentrators are unable to
! keep up with the data rate of a SENDing local
! Kermit unless echoback is disabled. [lfm 1/85]
program kermit(input=tty,output=tty)
implicit integer(a-z)
! Function : This is the main Kermit-CR program.
! Session initialization is forced via evaluation
! of the logical function KINIT, and the programs enters
! a command loop: user's input command is accepted
! by subroutine READCMD, validated & parsed into tokens
! by KPARSE, and the appropriate command interpreter is
! invoked. Exit from loop occurs when user types the
! exit command, or when the Kermit-CR Server enters exit
! mode in response to local Kermit's 'finish', 'bye' or
! 'logout' packet.
! Called Procedures : kinit, prompt, logline, readcmd, kparse,
! display. Also these cmd interpreters :
! kserv, ktrans, krecv, kset, kstatus,
! khelp and kclose.
character *80 cmdstr
character *40 report
logical kparse, kinit
logical debug, done
common /strings/ cmdstr, report
common /states/ state, retry, ntries, oldtries, seq
! , delay, stdelay,tcpu, tio
common /globals/ runtype, nargs, args(10,2), thisarg
parameter(send=1, receive = 2, help = 3, exitype = 4, server = 5 )
parameter(set = 6, status = 7 )
parameter( init = 1, abort = 6, complete = 7 )
parameter( wait = 0 )
! main proc. rtne.
print *,' LANL Cray Kermit Release 2.1'
! Evaluate initialization function :
if (.not.(kinit())) then
print *,' cant initialize - bye.'
go to 900 ! can't initialize
end if ! else session initialized
done = .false.
120 continue ! Top of command loop
call prompt('Kermit-CR>.') ! prompt user
call readcmd(strad(cmdstr),cmdlen) ! get user's cmd & its length
if (cmdlen.gt.0) then
call logline(cmdstr(1:cmdlen)//'$$')
else ! it's a bare CR
go to 120 ! Ignore it - reissue prompt
end if ! if user typed a command
if (kparse()) then
go to 200 ! valid cmd
else ! kparse provides report
call logline(report)
call display(report)
call display( 'type help for menu.')
go to 120
end if
200 continue ! kparse has parsed a valid cmd
if (runtype .eq. server) then
call kserv ! start Server loop
call kclose ! shut log file
done = .true. ! tell Kermit to exit
else if ( runtype .eq. send ) then
call ktrans
else if (runtype .eq. receive) then
state = init ! initialize non-server xfer
call krecv
else if (runtype .eq. help) then
call khelp
else if (runtype .eq. exitype) then
call kclose
done = .true.
else if (runtype .eq. set) then
call kset
else if (runtype .eq. status) then
call kstatus
else
call logline('cmd parse error.$$')
end if
if (.not.(done)) go to 120 ! Bottom of command loop
900 continue
call exit
end ! kermit main program
logical function kparse()
! scans user's input line in cmdstr for valid cmd type;
! if cmd = (server, status, receive, help, exit) :
! sets runtype, returns .true.
! if cmd = (send, set) : sets runtype, sets nargs <= num.args.,
! args(i,1) <= index of start ith argument
! in input command string,
! args(i,2) <= index last char of ith arg.
! else rturns .false.
! Called Procedures : none
implicit integer(a-z)
character *80 cmdstr
character *40 report
common /strings/ cmdstr, report
common /globals/ runtype, nargs, args(10,2), thisarg
parameter( send=1, receive=2, help=3, exitype=4, server = 5 )
parameter( set = 6, status = 7 )
parameter( cr = 13 )
nargs = 0
! look for cmd type
if ( cmdstr (1:6) .eq. 'server' ) then
runtype = server
go to 800
else if (cmdstr(1:3).eq.'set') then
runtype = set
else if (cmdstr(1:2).eq.'st') then
runtype = status
go to 800
else if (cmdstr (1:1) .eq. 's' ) then
runtype = send
else if ( cmdstr (1:1) .eq. 'r' ) then
runtype = receive
go to 800
else if ( (cmdstr (1:1) .eq. 'h').or.(cmdstr(1:1).eq.'?')) then
runtype = help
go to 800 ! no args to scan
else if ( cmdstr (1:1) .eq. 'e' ) then
runtype = exitype
go to 800
else
report = 'invalid cmd type:' // cmdstr(1:1) //'.'
kparse = .false.
go to 900
end if
! find end of cmd arg
i = 1
20 continue
i = i + 1
if (cmdstr (i:i) .eq. ' ') go to 30
if ( i .ge. 8 ) go to 700 ! error : arg too long
go to 20
! find start of next arg : skip past blanks
30 continue
if ( i .ge. 80 ) go to 780 ! there are no more args
i = i + 1
if ( cmdstr (i:i) .eq. ' ') go to 30 ! loop til nonblank
! else current char marks start of nxt argument
nargs = nargs + 1
if (nargs .gt. 10) go to 600 ! error : too many args
args(nargs,1) = i ! save starting position
! find end of current aerg
40 continue
i = i + 1
if ((cmdstr(i:i) .eq. ' ') .or. (cmdstr(i:i) .eq. char(cr)))
! go to 50
if ( (i-args(nargs,1)) .ge. 8 ) go to 700 ! too long
go to 40 ! loop til term delimiter found
50 continue
args(nargs,2) = i - 1
if (cmdstr (i:i) .eq. ' ') go to 30 ! if blank was delimiter
go to 880 ! if delimiter
600 continue
report = 'more than 10 args.'
kparse = .false.
go to 900
700 continue
report = 'arg length exceeds 8:' // cmdstr(args(nargs,1):i)//'.'
kparse = .false.
go to 900
780 continue
if (nargs .eq. 0) then
report = 'no arguments.'
kparse = .false.
go to 900
end if
800 continue
880 continue
kparse = .true.
900 return
end ! logical function kparse
logical function kinit()
implicit integer(a-z)
! Function : This is the session initialization function. It sets
! session parameters to their default values and creates
! a new session logfile, destroying the previous
! logfile if one exits.
! Called Procedures : kchar, kctl, initlog.
logical logging, debug, native, quote8, repeat, echo
parameter( CR = 13, CTLW = 23, CTLZ = 26, null = 0 )
parameter( soh = 01 )
parameter( ns = 15 )
parameter( LINEBUF = 86 ) ! current length of kbd input buf
parameter( SITEMAX = LINEBUF-4)
character pad, eol, quote, bq8, cktype, repchar
character bufsize,timout, npad
character rpkthead
character *9 myparms, hisparms, dflt
character kchar, kctl
common /units/ logioc, fioc, dkctr, dkbuf(512), nsectors,
! fptr, dkptr, dkhold
common /states/ state, retry, ntries, oldtries, seq, delay
! , stdelay
common /runparms/ myparms, hisparms, dflt
common /environ/ debug, native, quote8, repeat, window, echo
equivalence (bufsize,dflt(1:1)),(timout,dflt(2:2)),
! (npad,dflt(3:3)),(pad,dflt(4:4)),(eol,dflt(5:5)),
! (quote,dflt(6:6)),
! (bq8,dflt(7:7)),(cktype,dflt(8:8)),(repchar,dflt(9:9))
! set default system parameters
bufsize = kchar(SITEMAX) ! His safe max COUNT for pkts
timout = kchar(ns) ! I want ns secs. to respond, by his clock
npad = kchar(0)
pad = kctl(null)
eol = kchar(CR) ! end pkts to me with this kchar
quote = '#'
bq8 = 'N' ! Default filetype is Ascii text
cktype = '1' ! Default is single character checksums
repchar = ' ' ! Default is no data compression
myparms(1:9) = dflt(1:9) ! Initialize to defaults
! Site-dependancy : current line concentrator hardware echoes back
! packets. The following NPAD, PAD and EOL chars
! are used to disable echoback. If echoback isn't
! disabled, then transmissions will fail (even if
! local Kermit detects and ignores echo) because
! local Kermit's packets swamp the concentrator.
myparms(3:5) = kchar(1)//kctl(char(CTLZ))//kchar(CTLW)
myparms(7:7) = '&' ! My 8th bit prefix char
myparms(9:9) = '~' ! My repeat count prefix
! Use this default till we get his params :
hisparms(5:5) = char(CR) ! store the real character
logioc = 8
fioc = 9
delay = 5000000 ! default Cray timeout = 5 secs.
stdelay = delay
retry = 5 ! I'll retry up to 5 times
! Establish default session environment :
debug = .false.
native = .true. ! Default filetype is ctss native text
echo = .true. ! Assume echoback must be disabled
window = 1 ! Default size of floating window
seq = 0
! initialize session log
call initlog(logging)
kinit = logging
900 continue
return
end ! logical function kinit
subroutine kclose()
implicit integer(a-z)
! Function : This is the EXIT command interpreter, but is also
! invoked upon return to main program from server mode.
! It merely closes the session logfile. All data files
! are closed by the appropriate state-switcher when
! the current command (SEND/RECEIVE) completes or aborts.
call endlog()
return
end
!-cr.kfutil-!
! This module contains a collection of bottom-level Fortran
! subroutines, each of which invokes a CTSS operating system
! function via a call to the library routine SYCALL.
! The first SYCALL parameter is a literal index of the CTSS
! function requested. The second SYCALL parameter names the
! array by which request parameters are passed between the
! caller and CTSS. Result codes are returned in the second word
! of this array. Their meaning may be site-dependent. The
! possibility of error recovery is site-dependent.
subroutine readcmd(buffer,cmdlen)
implicit integer(a-z)
! Function : reads user's command from keyboard controller
! into buffer used as 1st argument,
! returns command length in 2nd argument.
! Called Procedures : sycall
parameter (cmdmax=80)
parameter( wait = 0 )
dimension alpha(5)
alpha(3) = buffer ! Address of caller's buffer
alpha(4) = cmdmax
alpha(5) = wait ! Wait until something is typed
call sycall(4l1500,alpha) ! Read msg from kbd controller
cmdlen = alpha(4) ! Number of chars read
return
end ! subroutine readcmd
logical function kfspace(listadr, listmax, numfiles)
implicit integer(a-z)
! Function : gets list of private files in user's filespace
! into buffer addressed by first argument;
! if no error and 0 < number_of_files <= 256, then
! evaluates TRUE with number of files in second argument,
! else evaluates false with numfiles := 0.
! Called Procedures : sycall, logline
dimension beta(5)
beta(3) = listadr
beta(4) = 2*listmax ! num. words is 2*(max no. entries)
beta(5) = 0
call sycall(4l1001,beta) ! Get private file list
if (beta(2).eq.0) then
numfiles = beta(4)/2
kfspace = .true.
else
numfiles = 0
kfspace = .false.
end if
return
end ! logical function kfspace
logical function kfopen(fname)
implicit integer(a-z)
! Function : opens file fname on kermit std. ioc, returns .true.,
! else returns .false.
! Called Procedures : sycall, tdisp, logline
parameter( readacc = 2 )
dimension dkbuf(512)
logical debug
common /units/ logioc, fioc, dkctr, dkbuf,nsectors
! , fptr, dkptr, dkhold
common /environ/ debug
dimension beta(12)
character*4 code, dum1, dum2
beta(3) = fname
beta(4) = fioc
beta(7) = readacc
call sycall(4l0300,beta)
if (beta(2) .eq. 0) then
kfopen = .true.
nx = beta(5)/512 ! get num. full sectors in file
if (nx*512.eq.beta(5)) then ! no remainder
nsectors = nx
else
nsectors = nx + 1
end if
fptr = 0 ! initialize file offset (words)
dkptr = 1
dkhold = 0 ! declare sector buffer empty
dkctr = 0 ! initialize sectors-read counter
if (debug) then ! log system info
call tdisp(nsectors,dum1)
call tdisp(beta(5),dum2)
call logline('opened file has '//dum1//' sectors,'//
! dum2 // ' words$$')
end if ! if debug
else
kfopen = .false.
if (debug) then ! log the cause of failure
call tdisp(beta(2),code) ! make error code printable
call logline('open fails with code:'//code//'$$')
end if ! if debug
end if
return
end ! subroutine kfopen
subroutine kfclose()
implicit integer(a-z)
! Function : close kermit std ioc
! Called Procedures : sycall
parameter( sameacc = 0, samesec = 0, samelen = 0 )
common /units/ logioc, fioc
dimension beta(6)
beta(3) = samesec
beta(4) = fioc
beta(5) = sameacc
beta(6) = samelen
call sycall(4l0400,beta)
return
end
logical function kfcreate()
implicit integer(a-z)
! Function : Destroys old kmt std recv file, if it exists,
! and creates a new one.
common /units/ logioc, fioc, dkctr, dkbuf, nsectors, fptr, dkptr
parameter(sector=512)
dimension beta(9)
dimension dkbuf(sector)
beta(3) = 'kmtfil' ! std recv file name
beta(4) = fioc
beta(5) = sector ! ask for 1 sector initially
beta(6) = 0
beta(7) = 3
call sycall(4l0101,beta) ! create std file & destroy old
if (beta(2).eq.0) then
dkctr = 0 ! initialize sector write ctr
dkptr = 1 ! initialize sector buffer ptr
fptr = 0 ! initialize file offset (words)
kfcreate = .true.
else
kfcreate = .false. ! if error
end if
return
end ! logical fn kfcreate
logical function kfdelete(usrfil)
implicit integer(a-z)
dimension beta(4)
beta(3) = usrfil ! name of file to delete
call sycall(4l0200,beta) ! delete it
if (beta(2).eq.0) then
kfdelete = .true. ! file was deleted
else
kfdelete = .false.
end if
return
end ! logical fn kfdelete
logical function kfswitch(usrfil)
implicit integer(a-z)
dimension beta(4)
call kfclose ! close kmt std i/o file
beta(3) = 'kmtfil' ! old name = std file name
beta(4) = usrfil ! new name = caller's arg.
call sycall(4l0600,beta) ! rename std file to arg name
if (beta(2).eq.0) then
kfswitch = .true. ! file was renamed ok
else
kfswitch = .false.
end if
return
end ! logical fn kfswitch
logical function kfwrite(n)
implicit integer(a-z)
dimension dkbuf(512)
common /units/ logioc, fioc, dkctr, dkbuf, nsectors, fptr
! , dkptr
dimension alpha(3), beta(9)
beta(3) = fioc
beta(6) = loc(dkbuf) ! Word addr of Sector buffer
beta(7) = fptr
beta(8) = n ! number of words to write
beta(9) = 0
call sycall(4l6000,beta) ! start disk write
alpha(3) = fioc
call sycall(4l4001,alpha) ! wait for dk write to complete
if (beta(2).eq.0) then ! dk write was successful
fptr = fptr + beta(4)
dkptr = 1 ! sector buffer now empty
kfwrite = .true.
dkctr = dkctr + 1 ! incr disk write count
if(n.eq.512) then ! wrote full sector, need another
beta(3) = 'kmtfil'
beta(4) = (dkctr+1)*512 ! new file size wanted in wds
call sycall(4l0702,beta) ! request another sector
if (beta(2).ne.0) kfwrite = .false.
end if ! if we filled our sector
else
kfwrite = .false.
end if
return
end ! logical fn kfwrite
logical function kfread()
implicit integer(a-z)
! Function : attempts to read 1 sector from Kermit std file ioc
! into common buffer dkbuf.
! Called Procedures : sycall, logline
dimension dkbuf(512) ! sector-sized buffer
logical debug
common /units/ logioc, fioc, dkctr, dkbuf, nsectors, fptr,
! dkptr, dkhold
common /environ/ debug
dimension alpha(3), beta(9)
character wval*4 ! debuggery
beta(3) = fioc ! device is std Kermit ioc
beta(6) = loc(dkbuf) ! addr of sector buf in common
beta(7) = fptr ! current file offset in words
beta(8) = 512 ! request a whole sector
beta(9) = 0 ! no interrupt rtne - we'll wait
call sycall(4l5000,beta) ! start disk read
alpha(3) = fioc
call sycall(4l4001,alpha) ! wait for read completion
if((beta(2).eq.0).or.(beta(2).eq.020b)) then
if (debug) then
call tdisp(beta(4),wval) ! debuggery
call logline('# wds read is '//wval//'$$') ! debuggery
end if
dkhold = beta(4) ! num. words read
fptr = fptr + beta(4)
dkctr = dkctr + 1 ! incr count of no. sectors read
dkptr = 1
kfread = .true.
else ! trouble with read
kfread = .false.
end if
return
end ! logical function kfread
subroutine kfprune(fsize)
implicit integer(a-z)
! Function : returns unused part of disk allocation
! for std Kermit io file.
! Called Procedures : sycall
dimension beta(4)
beta(3) = 'kmtfil'
beta(4) = fsize
call sycall(4l0702,beta) ! make file size exact
return
end ! subroutine kfprune
subroutine kgetime(tcpu,tio)
implicit integer(a-z)
dimension beta(8)
do 10 i=2,8
10 beta(i) = 0
call sycall(4l1031,beta) ! get real cpu,io times used.
tcpu = beta(3)
tio = beta(4)
return
end ! subroutine kgetime
subroutine displays
implicit integer(a-z)
character *40 string
parameter( cr=13, lf=10 )
logical nl
character cmdstr*80, report*40
common /strings/ cmdstr, report
dimension beta(5)
entry display(string)
nl = .true.
go to 10
entry prompt(string)
nl = .false.
10 continue
strep = strad(report)
if (strad(string) .ne. strep) then
report = string ! if argument is a literal
end if
beta(3) = strep
k = index(report,'.')
if (k.eq.0) k =39
if (nl) then
report(k:k+1) = char(13) // char(10) ! cr lf
beta(4) = k + 1
else
beta(4) = k-1
end if
beta(5) = 1
call sycall(4l1400,beta) ! send msg to tty ctlr
return
end
!-cr.kutcmds-!
subroutine kserv()
implicit integer(a-z)
! Function : This is the Kermit Server cmd interpreter.
! It is a command packet accepting loop, with exit
! to top-level upon receiving a FINISH("GF") or
! BYE/LOGOUT('GL") pkt from other Kermit.
! Note : Cray Kermit does not log itself out.
! Called Procedures : getpkt, unchar, stdname, ktrans, krecv,
! sendack, decode, encode, sendpkt,
! errorpkt, logline.
logical done, ok
character ptype
character *104 packet(2)
character cmdstr*80, report*40
common /globals/ runtype, nargs, args(10,2), thisarg
common /states/ state, retry, ntries, oldtries, seq
! , delay, stdelay
common /packets/ packet
common /strings/ cmdstr, report
parameter( init = 1, hdr = 2, abort = 6 ) ! states
parameter(good = 0, bad = 1, timeout = 2, escape = 3)
parameter( exitype = 4 ) ! runtype on exit
done = .false.
10 continue ! top of Server loop
call getpkt(1,status) ! look for cmd pkt
if (status.eq.good) then ! got a good pkt
ptype = packet(1)(4:4)
if (ptype.eq.'R') then ! they want to receive
! get filename from R pkt
last = unchar(packet(1)(2:2)) + 1
if (last.gt.4) then
nargs = 1
lx = last - 4
cmdstr(1:8) = packet(1)(5:last)
call stdname(cmdstr(1:8)) ! convert name to lower case
args(1,1) = 1
args(1,2) = lx
thisarg = 1
call ktrans ! call send state switcher
else
report = 'Server - no filename.'
done = .true.
end if ! if good file name
else if (ptype.eq.'S') then ! they want to send
call krecv ! call receive state switcher
else if (ptype.eq.'G') then ! Generic Server pkt type
ptype = packet(1)(5:5) ! 1st Data char tells cmd
if ((ptype.ne.'F').and.(ptype.ne.'L')) then
report = 'Server - unknown G code:'//ptype//'.'
else ! It's a valid G pkt code
call sendack(2,' ','Y') ! ACK it
report = 'Server - shut down by Partner.'
end if ! if cmdtype in G pkt
done = .true.
else if (ptype.eq.'I') then
call decode(1,ok) ! Decode their new initial params
if (ok) then ! we can comply
call encode(2,0,'Y') ! make a 'Y' pkt with our params
call sendpkt(2) ! reply with our params
else
report = 'cant comply with params.'
done = .true.
end if
else
report = 'Server - unknown pkt type:'//ptype//'.'
done = .true.
end if ! if good status
else if (status.ne.escape) then ! if bad pkt or timeout
call sendack(2,' ','N') ! NAK it
else
report = 'Server - aborted.'
done = .true.
end if ! if getpkt
if (.not.(done)) then
go to 10 ! go get another server pkt
else ! this is exit from server loop
call errorpkt(report)
call logline(report)
runtype = exitype ! tell Kermit to shut down
end if
return
end
subroutine kstatus()
implicit integer(a-z)
! Function : This is the STATUS command interpreter. It displays
! current Cray settable parameters.
! Called Procedures : tdisp, unchar
character report*40, value*4, kctl
character*9 myparms, hisparms, defaults
logical debug, native, quote8, repeat, echo
common /states/ state, retry, ntries, oldtries, seq
! , delay, stdelay
common /runparms/ myparms, hisparms, defaults
common /environ/ debug, native, quote8, repeat, window, echo
call tdisp(stdelay/1000000,value) ! convert stdelay to ascii secs.
report = 'timeout delay is ' //value //'.'
print *,report
call tdisp(retry,value)
report = 'max num tries is ' //value(3:4) // '.'
print *,report
if (debug) then
value = 'on'
else
value = 'off'
end if
report = 'debug '//value//'.'
print *,report
call tdisp(unchar(myparms(1:1)),value) ! convert coded char
report = 'Cray receiving bufsize is '//value(3:4)//' chars.'
print *,report
if (native) then
value = 'on'
else
value = 'off'
end if
report = 'ctss native text mode '//value//'.'
print *,report
! Site dependancy: see comments in KSET interpreter.
! This param is not yet made SETable.
!if (echo) then
! value = 'on'
!else
! value = 'off'
!end if
!report = 'echoback disable '//value//'.'
!print *, report
! Floating Window option not yet implemented
! call tdisp(window,value)
! report = 'window width is '//value//'.'
! print *, report
return
end ! subroutine kstatus
subroutine kset()
implicit integer(a-z)
! Function : This is is the SET command interpreter. It changes
! the Cray delay time, retry, debug, bufsize or
! filetype parameters for current session.
! Called Procedures : kchar, kctl, unchar, sethelp
parameter( MINPKT = 20, MAXPKT = 94 )
parameter( CTLZ = 26, CTLW = 23)
parameter( microsec = 1000000 )
character *80 cmdstr
character *40 report
character type*3, opt*2, numstr*2, lim1*4, lim2*4
character*9 myparms, hisparms, defaults
logical debug, turnon, native, quote8, repeat, echo
logical code
character kchar, kctl
common /strings/ cmdstr, report
common /states/ state, retry, ntries, oldtries, seq
! , delay, stdelay
common /globals/ runtype, nargs, args(10,2)
common /runparms/ myparms, hisparms, defaults
common /environ/ debug, native, quote8, repeat, window, echo
if (nargs.eq.1) then
if ( (cmdstr(args(1,1):args(1,1)).eq.'?')
! .or. (cmdstr(args(1,1):args(1,1)+3).eq.'help')) then
call sethelp()
return
end if ! If user requested help
end if
if (nargs.lt.2) then
print *, ' set <option> <value>.'
else
type = cmdstr(args(1,1):args(1,1)+2)
if ((type.eq.'deb').or.(type.eq.'nat').or.(type.eq.'ech'))
! then ! These are the ON | OFF options
opt = cmdstr(args(2,1):args(2,1)+1)
if ((opt.eq.'on').or.(opt.eq.'ON')) then
turnon = .true.
else if ((opt.eq.'of').or.(opt.eq.'OF')) then
turnon = .false.
else
print *, ' option values: on | off.'
go to 800
end if ! if option value
if (type.eq.'deb') then
debug = turnon
! Site dependancy: defer implementation of the SET ECHO <ON|OFF>
! cmd because current KCC's (network line
! concentrators) cannot keep up with a SENDing
! local Kermit's data rate, if echoback is
! enabled.
!else if (type.eq.'ech') then
!echo = turnon
!if (echo) then
! myparms(3:5) = kchar(1)//kctl(char(CTLZ))//kchar(CTLW)
! myparms(1:1) = kchar(unchar(defaults(1:1))-2)
!else
! myparms(3:5) = defaults(3:5)
! myparms(1:1) = defaults(1:1)
!end if
else
native = turnon
end if
else if ((type.eq.'tim').or.(type.eq.'ret').or.(type.eq.'buf'))
! then
vlen = args(2,2) - args(2,1) + 1
if (vlen.gt.2) then
print *, ': value is 1 or 2 decimal digits.'
go to 800
else if (vlen.eq.1) then
numstr = '0'//cmdstr(args(2,1):args(2,1))
else
numstr = cmdstr(args(2,1):args(2,2))
end if
call undisp(numstr,value,code)
if (.not.(code)) then
print *, ': use decimal characters for value.'
go to 800
end if
if (type.eq.'tim') then
stdelay = value * microsec
else if (type.eq.'ret') then
retry = value
else if (type.eq.'buf') then
if ((value.ge.MINPKT).and.(value.le.MAXPKT)) then
myparms(1:1) = kchar(value)
else
call tdisp(MINPKT,lim1)
call tdisp(MAXPKT,lim2)
report = 'Use buffer size between '//lim1
! //' and '//lim2//'.'
print *, report
end if
end if
else
print *, ':not a valid set option.'
end if
end if
800 continue
return
end ! subroutine kset
subroutine sethelp()
implicit integer(a-z)
! Function : This subroutine displays the settable parameters.
! Called procedures : none.
print *, 'Set options are :'
print *,' '
print *,' timeout <decimal value>'
print *,' retry <decimal value>'
print *,' debug <on | off>'
print *,' bufsize <decimal value>'
print *,' native <on | off>'
! Defer implementation of the SET ECHO option [lfm 1/85]
!print *,' echo <on | off>'
return
end ! subroutine sethelp
subroutine khelp()
! Function : This is the HELP command interpreter.
print *,' LANL Cray Kermit Commands :'
print *,' '
print *,' server'
print *,' (Enter Server mode : all transmission info will'
print *,' come from Partner Kermit, as packets.)'
print *,' s[end] <list of 1-10 file names>'
print *,' (Send files to a partner in receive mode)'
print *,' r[eceive]'
print *,' (receive files from non-server partner)'
print *,' e[xit]'
print *,' (exit from non-server Kermit, return to Cray OS)'
print *,' st[atus]'
print *,' (display status of settable Cray Kermit parameters)'
print *,' set <option> <value>'
print *,' (set value of a parameter)'
print *,' h[elp]'
print *,' (display this menu)'
return
end
!-cr.pktio-!
subroutine sendpkt(pindex)
implicit integer(a-z)
! Function : This is the physical packet send routine. Packets
! are sent as messages to the keyboard controller.
! If pad or EOL characters have been requested by
! the other Kermit, they are added here.
! Called Procedures : strad, unchar, kctl, sycall, logpkt
character kctl, pad
character *104 packet(2)
character *9 myparms, hisparms
logical debug
parameter( wait = 1 )
parameter( SOH = 01 )
common /packets/ packet
common /runparms/ myparms, hisparms
common /environ/ debug
dimension beta(5)
packet(pindex)(1:1) = char(SOH)
beta(3) = strad(packet(pindex))
beta(4) = unchar(packet(pindex) (2:2)) + 3 ! pt past chksum
packet (pindex) (beta(4):beta(4)) = hisparms(5:5) !append his eol
npad = unchar(hisparms(3:3)) ! get num pads if any
if (npad.gt.0) then ! he wants pad char prefix
pad = kctl(hisparms(4:4)) ! uncontrolify - true pad char
packet(pindex)(npad+1:beta(4)+npad)
! = packet(pindex)(1:beta(4)) ! shift data right
do 10 i=1,npad
packet(pindex)(i:i) = pad
10 continue
beta(4) = beta(4) + npad ! revise length to include pads
end if
beta(5) = wait
call sycall(4l1400,beta) ! send packet as msg to kbd controller
if (debug) call logpkt(pindex) ! show the pkt sent
!f ( beta(2) .eq. 0 ) then ... what ?
return
end ! subr sendpkt
subroutine sendack(pindex,theirseq,ok)
implicit integer(a-z)
! Function : This is a virtual packet send routine called
! in the RECEIVE states. It invokes SENDPKT and
! if ok = 'Y', ACK's pkt no. theirseq, else NAK's it.
! Called Procedures : cksum, sendpkt
character theirseq, ok, cksum
character *104 packet(2)
common /packets/ packet
packet(pindex)(2:2) = '#' ! count is coded 3
packet(pindex) (3:3) = theirseq
packet(pindex) (4:4) = ok
packet(pindex)(5:5) = cksum(packet(pindex))
call sendpkt(pindex)
return
end ! subroutine sendack
subroutine getpkt(px,status)
implicit integer(a-z)
! Function : This is the packet read routine. Packets are read as
! messages from the Keyboard Controller. When entered,
! getpkt suspends itself until arrival of a message
! or elapse of timeout interval. If a message is there
! at entry, suspension does not occur (i.e., an
! immediate return occurs from the delay sycall).
! If awakened by timeout, getpkt returns staus=timeout,
! if by msg arrival then staus=good IFF msg is
! a correctly checksumed packet, else status=bad.
! Called Procedures : sycall, logline, unchar, cksum, logpkt,
! tdisp.
character kchar, cksum, nval*4
character *9 myparms
character *104 packet(2)
logical debug
common /states/ state, retry, ntries, oldtries, seq,
! delay, stdelay
common /runparms/ myparms
common /packets/ packet
common /environ/ debug
parameter( good = 0, bad = 1, timeout = 2, escape = 3 )
parameter( abort = 6 )
parameter( MAXMSG = 104, MINLEN = 5, wait =0, nowait = 1 )
! MAXMSG 104 allows up to 96 pkt chars + eol(stripped by ctss),
! plus up to 8 pad/noise char prefix.
parameter( kccmax = 86 ) ! max len of kcc read, alas.
parameter( soh = 1, esc = 033b )
dimension alpha(3), beta(5)
beta(3) = strad(packet(px)) ! get addr of packet
beta(5) = nowait
10 continue
alpha(3) = delay
call sycall(4l3000,alpha) ! sleep dt or till msg comes
beta(4) = MAXMSG
call sycall(4l1500,beta) ! see which event occurred
if (beta(2) .ne. 0) then ! time elapsed without msg
status = timeout
if (debug) call logline('timed out$$')
else if (beta(4).eq.0) then ! got lone EOL char - ignore it
if (debug) call logline('null pkt$$')
go to 10 ! go back to sleep
else if (packet(px)(1:1).eq.char(esc))
!then ! someone hit ESC key
call logline('escaped$$')
status = escape
else ! is msg a real packet ?
if (debug) then
call tdisp(beta(4),nval)
call logline('Got '//nval//' msg chars$$')
end if
sx = index(packet(px),char(soh)) ! look for SOH in msg
if ((sx.eq.0).and.(beta(4).lt.MINLEN))
! then ! Headless blip - treat as noise
if (debug) call logline('noise pkt ignored$$')
go to 10
else if ((sx.eq.0).or.(beta(4).lt.MINLEN)) then
status = bad ! Let it be NAK'ed
go to 100
else ! it looks like a pkt
30 continue
nx = index(packet(px)(sx+1:sx+1), char(soh))
if (nx.ne.0) then ! found another SOH
sx = sx + nx ! get its absolute index
if (sx.le.MAXMSG-MINLEN) then
go to 30 ! go see if it's the last one
else
status = bad
go to 100
end if
end if
pklen = unchar(packet(px)(sx+1:sx+1)) + 2
if (sx .gt. 1) then ! need to left-adjust
packet(px) (1:pklen) = packet(px)(sx:sx+pklen-1)
end if ! if there were pad chars
end if ! if sx
if (debug) call logpkt(px) ! Show their packet
if (cksum(packet(px)) .eq. packet(px)(pklen:pklen)) then
status = good
else
if (debug) call logline('bad checksum$$')
status = bad
end if ! if checksum
end if ! if beta(2)
100 return
end ! subroutine getpkt
logical function gotack(px,seq)
implicit integer(a-z)
! Function : This is a virtual packet read routine called from
! the SEND state. Evaluation of GOTACK forces a
! call to GETPKT, the physical pkt read rtne.
! GOTACK is .true. iff a valid ACK for current pkt
! or valid NAK for next is rec'd. Receipt of good
! discard-type ACK for current pkt causes signal
! variable to be set to action character in pkt.
! Called Procedures : getpkt, kchar, unchar, logline
parameter( good=0, bad=1, timeout=2 ) ! getpkt return codes
character kchar, pseq, ptype, expect, next, signal
character *104 packet(2)
common /packets/ packet, signal
call getpkt(px,status) ! look for partners response
if (status.eq.good) then ! got a valid pkt
pcount = unchar(packet(px)(2:2))
pseq = packet(px)(3:3)
ptype = packet(px)(4:4)
expect = kchar(mod(seq,64))
next = kchar(mod(seq+1,64))
if (((ptype.eq.'Y').and.(pseq.eq.expect)) .or.
! ((ptype.eq.'N').and.(pseq.eq.next)))
! then ! ACK for this or NAK for next
gotack = .true.
! was it a discard-type ACK ?
if ((ptype.eq.'Y').and.(pcount.gt.3)) then
signal = packet(px)(5:5) ! save discard action field
call logline('Interrupt request, type '//signal//'$$')
end if
else ! Good pkt, wrong type or seq
gotack = .false.
end if ! If ptype
else ! Bad pkt or timeout
gotack = .false.
end if ! If getpkt status
return
end ! logical function gotack
!-cr.receive-!
subroutine krecv()
implicit integer(a-z)
! Function : RECEIVE state switcher
! Called Procedures : getinit, gethdr, getfile, logline,
! kfclose, kgetime, tdisp.
parameter( init = 1, hdr = 2, data = 3, feof = 4, complete = 7,
! abort = 6 )
parameter( seconds = 1000000, ms = 1000 )
character*4 cpr,tpr
character cmdstr*80, report*40
logical rpcount, savedcr
common /states/ state, retry, ntries, oldtries, seq, delay
! , stdelay, tcpu, tio
common /pkstats/ bptr, bufleft, maxpack, lastbuf
! , rpcount, savedcr
common /strings/ cmdstr, report
ntries = 0
delay = stdelay
state = init
call kgetime(tcpu,tio) ! Get initial times
100 if ( state .ne. complete) then
if (state .eq. init) then
call getinit
else if (state .eq. hdr) then
call gethdr
else if (state .eq. data) then
call getfile
else if (state .eq. abort) then
call kfclose ! make sure recv file closed
call logline(report) ! log reported cause of failure
call errorpkt(report)
state = complete
end if ! end of non-complete cases
go to 100
end if ! else state is complete
call tdisp(seq,tpr)
call logline('num pkts received = '//tpr//'$$')
call kgetime(tcx,tix)
call tdisp((tcx-tcpu)/ms, cpr)
call tdisp((tix-tio)/seconds,tpr) ! get printable io usage in seconds
call logline('Transaction time = '//cpr//' cpu ms, '//
! tpr//' io sec$$' )
return
end ! subroutine krecv
subroutine getinit()
implicit integer(a-z)
! Function : This routine gets the other Kermit's parameters in
! an 'S' packet, checks them, and ACK's with ours
! IFF we can comply with other Kermit's requests.
parameter( init=1, hdr=2, abort=6)
parameter( good=0, bad=1, timeout=2, escape=3 )
parameter( thispkt = 1, nxtpkt = 2 )
parameter( initry = 20 ) ! allow more tries for S pkt
character *104 packet(2)
character cmdstr*80, report*40
common /states/ state, retry, ntries, oldtries, seq
! , delay, stdelay
common /packets/ packet
common /strings/ cmdstr, report
logical nakit, resolve
if (ntries .ge. initry) then
report = 'getinit - too many.'
state = abort
else
ntries = ntries + 1
nakit = .false.
if (ntries .eq. 1) delay = stdelay * 2 ! wait longer for S & F
call getpkt(thispkt, status)
if (status .eq. good) then
if (packet(thispkt)(4:4) .eq. 'S') then ! got a good S pkt
call decode(thispkt,resolve) ! decode his parms
if (resolve) then
seq = unchar(packet(thispkt)(3:3)) ! synchronize seq nos.
call encode(nxtpkt,seq,'Y') ! format our params
call sendpkt(nxtpkt) ! send him ours
state = hdr
seq = seq + 1
oldtries = ntries
ntries = 0
else
report = 'cant resolve params.'
state = abort
end if ! if resolve
else ! wrong pkt type
nakit = .true.
end if
else if (status.eq.escape) then
state = abort
report = 'Host User Escape Request.'
nakit = .false.
else ! bad pkt or timeout
nakit = .true.
end if ! if status
if (nakit) call sendack(ack,' ','N') ! send NAK
end if ! if ntries
return
end ! subroutine GETINIT
subroutine gethdr()
implicit integer(a-z)
! Function : This routine gets an 'F' (header) packet from the
! other Kermit, saves file name, opens a workfile
! 'kmtfil' to receive the incoming file, and ACK's
! the 'F' pkt. Workfile name will be switched to header
! name when transmission completes.
parameter( hdr = 2, data = 3, abort = 6, complete = 7 )
parameter( good = 0, bad = 1, timeout = 2 )
parameter( thispkt = 1, ack = 2 )
parameter( buflen = 504 )
character *104 packet(2)
character cmdstr*80, report*40
dimension dkbuf(512)
common /states/ state, retry, ntries, oldtries, seq
! , delay, stdelay
common /packets/ packet
common /pkstats/ bptr, bufleft, maxpack, lastbuf, rpcount, savedcr
common /strings/ cmdstr, report
common /environ/ debug, native
logical ackit, oldfile, kfopen, kfcreate, lastbuf, savedcr
logical debug, native
character ptype, kchar
dimension beta(9)
if (ntries .ge. retry) then
report = 'gethdr - too many.'
state = abort
else
ntries = ntries + 1
call getpkt(thispkt, status)
if (status .eq. good) then
ptype = packet(thispkt) (4:4)
if (ptype .eq. 'F') then
! save pkt file name in command string
namend = unchar(packet(thispkt)(2:2)) + 1
cmdstr(1:8) = packet(thispkt) (5:namend)
call stdname(cmdstr(1:8)) ! Convert to std name
if (kfcreate()) then ! if opened std recv file
report = 'Opened std file for:'//cmdstr(1:8)
call logline(report)
bptr = 1 ! initialize buffer ptr
bufleft = buflen
savedcr = .false.
else
report = 'gethdr - cant open std file.'
state = abort
go to 700
end if
state = data
seq = seq + 1
oldtries = ntries
ntries = 0
ackit = .true.
else if (ptype .eq. 'S') then
! they lost our ACK
ackit = .false. ! not a regular ACK
if (oldtries.lt.retry) then
call encode(nxtpkt,1,'Y') ! send it again
call sendpkt(ack) ! ACK it again
oldtries = oldtries + 1
else
report = 'gethdr - aborting after too many S pkts.'
state = abort
end if
else if (ptype .eq. 'Z') then
! lost ACK for previous file on list
ackit = .true.
ntries = 0
else if (ptype .eq. 'B') then
state = complete
ackit = .true.
else
report = 'gethdr - aborting on unknown pkt type.'
state = abort
ackit = .false.
end if ! if ptype
if (ackit) call sendack(ack,packet(thispkt)(3:3),'Y')
else if (state .ne. abort) then ! if bad pkt or timeout
call sendack(ack,kchar(mod(seq,64)),'N') ! NAK expected pkt
end if ! if status
end if ! if ntries
700 continue
if (state.gt.hdr) delay = stdelay ! restore std delay
return
end ! subroutine gethdr
subroutine getfile()
implicit integer(a-z)
! Function : This routine gets a 'D' (data) packet from the other
! Kermit, ACK's it, and invokes the pkt-unpacking
! rtne PUTDATA to buffer received data. End of file
! is detected in this state when a 'Z' pkt arrives.
! Discard-type 'Z' pkts are recognized.
! send states :
parameter( hdr = 2, data = 3, abort = 6 )
! getpkt status codes :
parameter( good = 0, bad = 1, timeout = 2 )
parameter( px = 1, ack = 2 )
parameter( ok= 0, err = 1 ) ! putdata result codes
character kchar, ptype, pseq, expect, last
character cmdstr*80, report*40
logical puteof
character *104 packet(2)
common /states/ state, retry, ntries, oldtries, seq
! , delay, stdelay
common /packets/ packet
common /strings/ cmdstr, report
if (ntries .ge. retry) then
report = 'getfile - too many.'
state = abort
else
ntries = ntries + 1
call getpkt(px,status) ! look for expected data pkt
expect = kchar(mod(seq,64))
last = kchar(mod(seq-1,64))
if (status.eq.good) then ! got a pkt
pseq = packet(px)(3:3)
ptype = packet(px)(4:4)
if (ptype.eq.'D') then ! type is Data
if ((pseq.eq.expect).or.(pseq.eq.last)) then
call sendack(ack,pseq,'Y') ! ACK if it's nth or (n-1)st
end if ! if pseq
if (pseq.eq.expect) then
call putdata(px,result) ! store data from nth pkt
if (result.ne.ok) then
report = 'file write error.'
state = abort
else
seq = seq + 1
oldtries = ntries
ntries = 0
end if
end if ! if pseq in 'D' pkt
else if (ptype.eq.'Z') then ! received eof
if(unchar(packet(px)(2:2)).eq.3) then ! Normal EOF pkt
! evaluate puteof to terminate file, switch name
if(.not.(puteof(cmdstr(1:8)))) then
report = 'can''t save file.'
state = abort
end if
else if (packet(px)(5:5).eq.'D') then
call kfclose() ! This file to be Discarded.
call logline('Incoming copy discarded by request$$')
end if
if (state.ne.abort) then
state = hdr
seq = seq + 1
ntries = 0
call sendack(ack,pseq,'Y')
end if
else if (ptype .eq.'F') then ! they lost our ACK
call sendack(ack,pseq,'Y') ! ACK again
ntries = 0
else ! probably 'E' or 'B' pkt
state = abort
if(ptype.eq.'E') call logpkt(px)
end if ! if ptype
else ! timeout or bad pkt
call sendack(ack,expect,'N') ! NAK it
end if ! if status
end if ! if ntries
return
end ! subroutine getfile
!-cr.send-!
subroutine ktrans()
implicit integer(a-z)
! Function : State-switcher for shipping files out.
! Called Procedures change the state. Complete state
! occurs after sendeof finds arg list empty, or after
! a called procedure signals abort state.
! Called Procedures : sendinit, sendhdr, sendfile, sendeof,
! sendbrk, errorpkt, logline, kfclose, kgetime,
! tdisp
parameter( init = 1, hdr = 2, data = 3, feof = 4, break = 5,
! abort = 6, complete = 7 )
parameter( seconds = 1000000, ms = 1000)
character cmdstr*80, report*40
logical lastbuf, savedcr
common /states/ state, retry, ntries, oldtries, seq
! , delay, stdelay, tcpu, tio
common /pkstats/ bptr, bufhold, maxpack, lastbuf
! , rpcount, savedcr
common /strings/ cmdstr, report
character*4 cpr, tpr
character *4 dval
ntries = 0
delay = stdelay
call kgetime(tcpu,tio) ! get initial trans. times
state = init
100 if ( state .ne. complete ) then
if (state .eq. init) then
call sendinit
else if (state .eq. hdr) then
call sendhdr
else if (state .eq. data) then
call sendfile
else if (state .eq. feof) then
call sendeof
else if (state .eq. break) then
call sendbrk
else if (state .eq. abort) then
call errorpkt(report)
call logline(report)
call kfclose() ! close send file
state = complete
else
report = 'unrecognized state.'
state = abort
end if
go to 100
end if ! if not complete
call tdisp(seq+1,tpr)
call logline('Number of packets sent = '//tpr//'$$')
! log elapsed times for trans.
call kgetime(tcx,tix) ! get times used till now
call tdisp((tcx-tcpu)/ms,cpr) ! printable cpu time in ms
call tdisp((tix-tio)/seconds,tpr)
call logline('Tr time : cpu='//cpr
! //' ms, io='//tpr//' sec$$')
return
end ! subroutine ktrans
subroutine sendinit()
implicit integer(a-z)
! Function : This routine sends an 'S' pkt with our params
! and looks for partner's params in his ACK.
! If valid ACK is rec'd and we can comply with
! partner's specs., then state <== hdr; else if
! we cant resolve params or we dont receive ACK in
! requisite num. tries, state <== abort.
! Called Procedures : encode,sendpkt, getpkt, decode
parameter( hdr = 2, break = 5, abort = 6 )
parameter( good = 0, bad = 1, timeout = 2, escape = 3 )
parameter( thispkt = 1, nxtpkt = 2 )
parameter( initry = 20 ) ! allow more tries for S pkt
logical resolve
character ptype, kchar
character cmdstr*80, report*40
character *104 packet(2)
character *4 dval
common /states/ state, retry, ntries, oldtries, seq,
! delay, stdelay
common /globals/ runtype, nargs, args(10,2), thisarg
common /strings/ cmdstr, report
common/packets/packet
if (ntries .ge. initry) then
delay = stdelay ! restore std delay
report = 'can''t get ACK for S pkt.'
state = abort
else
ntries = ntries + 1
if (ntries .eq. 1) then ! if 1st try, prepare
delay = delay * 2 ! allow longer for S & F
call encode(thispkt,0,'S') ! make an S pkt
end if
call sendpkt(thispkt) ! send our S pkt
call getpkt(nxtpkt,status) ! look for his ACK
if (status .eq. good) then ! got a good pkt
if ((packet(nxtpkt) (4:4) .eq. 'Y') .and.
! (packet(nxtpkt) (3:3) .eq. ' ')) then
call decode(nxtpkt,resolve) ! decode his params
if (resolve) then
state = hdr
else
state = abort
report = 'cant resolve initial parameters.'
end if
else if((packet(nxtpkt)(4:4).eq.'N')
! .and.(packet(nxtpkt)(3:3).eq.'!'))
! then ! we lost their previous ACK
state = hdr
end if
if (state.eq.hdr) then
seq = 1
ntries = 0
thisarg = 1
end if ! if state
else if (status.eq.escape) then
state = abort
report = 'User Escape Request.'
end if ! if status - else dont change
end if ! if ntries ok
return
end ! subroutine sendinit
subroutine sendhdr()
implicit integer(a-z)
! Function : This routine sends a 'F' (file header) pkt,
! and accepts its ACK from the other Kermit.
! The send file is opened and buffers initialized
! before the first attempt to send the pkt.
! If a valid ACK is received in the requisite number
! of tries, state <== data, else state <== abort.
! Discard-type ACK's are recognized in this state.
! Called Procedures : logline, kfopen, errorpkt, makehdr,
! unchar, sendpkt, gotack
character *104 packet(2)
character cmdstr*80, report*40
character *8 fname
character *9 myparms,hisparms
character kchar, signal
logical lastbuf
common /runparms/ myparms, hisparms
common /states/ state, retry, ntries, oldtries, seq,
! delay, stdelay
common /globals/ runtype, nargs, args(10,2), thisarg
common /strings/ cmdstr, report
common /packets/ packet, signal
common /pkstats/ bptr, bufhold, maxpack, lastbuf, rpcount
parameter( hdr = 2, data = 3, abort = 6 )
parameter( thispkt = 1, ack = 2 )
logical kfopen, gotack
if (ntries .ge. retry) then
report = 'can''t get ACK for F pkt.'
state = abort
else
ntries = ntries + 1
if (ntries .eq. 1) then
! Do file xfer initialization once,
! before sending 1st 'F' pkt :
fname = cmdstr (args(thisarg,1):args(thisarg,2))
if (.not.(kfopen(fname))) then
report = 'cant open:' // fname // '.'
state = abort
go to 800
else
report = 'Opened send file: '//fname
call logline(report)
call makehdr(thispkt,seq) ! prepare the 'F' pkt
bufhold = 0 ! declare char buffer empty
bptr = 1
maxpack = unchar(hisparms(1:1)) + 1 ! last data pos
if (myparms(3:3).ne.' ') then
! Site Dependency : use pkt length 2 less than Partner's
! bufsize, lest echoback of his pad & EOL chars overflow
! his input buffer
maxpack = maxpack - 2
end if
signal = ' ' ! set discard signal off
lastbuf = .false. ! set EOF indicator off
rpcount = 0 ! initialize repeat count
end if
end if ! if 1st try
call sendpkt(thispkt) ! send an F pkt
if (gotack(ack,seq)) then ! if partner acknowledges
seq = seq + 1
ntries = 0
if (signal.eq.' ') then ! no complications
state = data ! hdr ACKed, go to data state
else ! The ACK was a discard signal
state = feof ! Go directly to EOF state
end if ! If signal
end if ! If gotack - else no change
end if ! if ntries
800 continue
if (state .ne. hdr) delay = stdelay ! restore std. delay
return
end ! subroutine sendhdr
subroutine sendfile()
implicit integer(a-z)
! Function : This routine sends a 'D' (data) packet and
! looks for an ACK. End of file is detected
! upon report from MAKEDATA, the data packet
! preparation rtne. Discard-type ACK's are
! recognized in this state.
! Called Procedures : makedata, sendpkt, gotack
parameter( thispkt = 1, ack = 2 )
parameter( data = 3, feof = 4, abort = 6 )
parameter( ok = 0, lastpkt = 1, nopkt=3, err = 4 )
logical gotack
character *104 packet(2)
character signal
character kchar, cksum
character cmdstr*80, report*40
common /states/ state, retry, ntries, oldtries, seq
! , delay, stdelay
common /packets/ packet, signal
common /strings/ cmdstr, report
if (ntries.ge.retry) then
report = 'can''t get ACK for data pkt.'
state = abort
else
ntries = ntries + 1
if (ntries.eq.1) then ! set up packet 1st time
call makedata(seq,result) ! get packetfull
if (result.eq.nopkt) then
state = feof
ntries = 0
go to 400
else if (result.eq.err) then
state = abort
go to 400
end if ! if nthg to send
end if ! if 1st try
call sendpkt(thispkt) ! send data packet(n)
if (gotack(ack,seq)) then ! if partner acknowledges
seq = seq + 1
ntries = 0
if ((signal.ne.' ').or.(result.eq.lastpkt)) then
state = feof
end if ! if signal - else dont change
end if ! if gotack - else dont change
end if ! if ntries
400 continue
return
end ! subroutine sendfile
subroutine sendeof()
implicit integer(a-z)
! Function : Sends a 'Z' pkt indicating end-of-file.
! If this state was entered in response to an
! interrupt-request (other Kermit's discard-type
! ACK for a previous pkt) or if no more files to
! send, then state <== break, else state <== hdr.
! Discard-type ACK's are recognized in this state.
! Called Procedures : logline, sendpkt, gotack, kfclose
parameter( hdr = 2, break = 5, abort = 6, complete = 7 )
parameter( thispkt=1, ack=2 )
parameter( good = 0, bad = 1, timeout = 2 )
logical gotack, debug
character *104 packet(2)
character signal
character cmdstr*80, report*40
common /states/ state, retry, ntries, oldtries, seq
! , delay, stdelay
common /globals/ runtype, nargs, args(10,2), thisarg
common /packets/ packet, signal
common /strings/ cmdstr, report
common /environ/ debug
if (ntries .ge. retry) then
report = 'can''t get ACK for Z pkt.'
state = abort
else
ntries = ntries + 1
if (ntries .eq. 1) call makeof(thispkt,seq)
call sendpkt(thispkt)
if (gotack(ack,seq)) then
ntries = 0
call kfclose ! close the file just sent
if (debug) call logline('close send file$$')
seq = seq + 1
if ((thisarg .lt. nargs).and.(signal.ne.'Z')) then
thisarg = thisarg + 1 ! index next fname
state = hdr
else ! no more files to send
state = break
end if
end if ! if gotack
end if
return
end ! subroutine sendeof
subroutine sendbrk()
implicit integer(a-z)
! Function : Sends a 'B' (break) packet indicating completion
! of current transmission. If valid ACK is received
! state <== complete, else state <== abort.
! Called Procedures : kchar, sendpkt, getpkt
character kchar, myseq
character *104 packet(2)
character cmdstr*80, report*40
common /states/ state, retry, ntries, oldtries, seq
! , delay, stdelay
common /packets/ packet
common /strings/ cmdstr, report
parameter( abort = 6, complete = 7 )
parameter( thispkt = 1, ack = 2)
parameter( good = 0, bad = 1, timeout = 2 )
if (ntries .eq. retry) then
report = 'can''t get ACK for Break pkt.'
state = abort
else
ntries = ntries + 1
if (ntries .eq. 1) call makebrk(thispkt,seq)
call sendpkt(thispkt)
call getpkt(ack,status)
if (status .eq. good) then
myseq = kchar(mod(seq,64))
if ((packet(ack) (4:4) .eq. 'Y') .and.
! (packet(ack) (3:3) .eq. myseq))
! then
state = complete
end if ! else NAK, wrong ACK - dont change
end if ! if status ... else dont change state
end if
return
end ! subroutine sendbrk
subroutine encode(pindex, seq,type)
implicit integer(a-z)
! Function : puts current cray parameters into an 'S' packet
! (if called in SEND state) or a 'Y' packet
! (if called from RECEIVE state).
! Called Procedures : kchar, cksum
character kchar, cksum, type
character *104 packet(2)
character *9 myparms, hisparms
common /packets/ packet
common /runparms/ myparms, hisparms
parameter( soh = 1, cr = 13, numparm = 9 )
packet(pindex) (2:2) = kchar( numparm + 3 ) ! set count
packet(pindex) (3:3) = kchar(mod(seq,64))
packet(pindex) (4:4) = type ! set type
packet(pindex) (5:13) = myparms(1:9)
packet(pindex)(14:14) = cksum(packet(pindex))
return
end ! subroutine encode
subroutine makehdr(pindex,seq)
implicit integer(a-z)
! Function : Makes an 'F' (header) packet, getting file name
! from user's input line, saved in cmdstr.
! Called Procedures : kchar, cksum
character *80 cmdstr
character *104 packet(2)
common /strings/ cmdstr
common /globals/ rtype,n, args(10,2), thisarg
common /packets/ packet
character kchar,cksum
arglen = args(thisarg,2) - args(thisarg,1) + 1
packet (pindex) (2:2) = kchar(arglen+3)
packet (pindex) (3:3) = kchar(mod(seq,64))
packet (pindex) (4:4) = 'F'
packet(pindex)(5:4+arglen) =
! cmdstr (args(thisarg,1) : args(thisarg,2))
packet(pindex) (5+arglen:5+arglen) = cksum(packet(pindex))
return
end ! subroutine makehdr
subroutine makeof(pindex,seq)
implicit integer(a-z)
! Function : If signal is the normal blank, makes a std
! 'Z' pkt indicating normal EOF, else
! makes a discard-type 'Z' packet.
! Called Procedures : kchar, cksum
character *104 packet(2)
character signal, cx
common /packets/ packet, signal
character kchar,cksum
if (signal.eq.' ') then ! Normal EOF - no data field.
packet (pindex) (2:2) = kchar(3)
else ! Interrupt signal - need data fld
packet(pindex)(2:2) = kchar(4)
end if
packet (pindex) (3:3) = kchar(mod(seq,64))
packet (pindex) (4:4) = 'Z'
if (signal.eq.' ') then ! It's a normal EOF
packet(pindex)(5:5) = cksum(packet(pindex))
else ! We've received interrupt signal
packet(pindex)(5:5) = 'D' ! Tell them to close and Discard
packet(pindex)(6:6) = cksum(packet(pindex))
end if
return
end ! subroutine makeof
subroutine makebrk(pindex,seq)
implicit integer(a-z)
character *104 packet(2)
common /packets/ packet
character kchar,cksum
packet (pindex) (2:2) = kchar(3)
packet (pindex) (3:3) = kchar(mod(seq,64))
packet (pindex) (4:4) = 'B'
packet(pindex)(5:5) = cksum(packet(pindex))
return
end ! subroutine makebrk
subroutine decode(pindex,ok)
implicit integer(a-z)
! Function : Saves partner's params & resolves with ours.
! Returns ok = .true. iff we can comply with
! partner's parameters, else ok = .false.
! Called Procedures : kchar, unchar, logline
logical ok, debug, native, quote8, repeat
character kchar
character *104 packet(2)
character cmdstr*80, report*40
character *9 myparms, hisparms, default
common /runparms/ myparms, hisparms, default
common /environ/ debug, native, quote8, repeat
common /packets/ packet
common /strings/ cmdstr, report
hislast = unchar(packet(pindex)(2:2)) + 1 ! index last data char
if (hislast .gt. 4) then
if (debug) then
report = 'Partner''s params received: '//
! packet(pindex)(5:hislast) //'$$'
call logline(report)
end if
do 50 i=5, hislast
j = i-4
if (packet(pindex)(i:i) .ne. ' ') then
hisparms(j:j) = packet(pindex)(i:i) ! save char he asks for
else
hisparms(j:j) = default(j:j)
end if
50 continue
end if
! Use standard defaults for his omissions :
if (hislast .lt. 13) then ! if he didnt specify all
hisparms(hislast-3:9) = default(hislast-3:9)
end if
ok = .true. ! start optimistically
! Treat Partner's BUFSIZE param as max count he wants :
hisbuf = unchar(hisparms(1:1)) + 2 ! packet length he wants
hisnpad = unchar(hisparms(3:3)) ! no. pad chars he wants
! now make sure we agree on things ..
if ((hisparms(7:7).eq.'&').or.(hisparms(7:7).eq.'Y'))
!then
quote8 = .true.
else
quote8 = .false.
end if
hisparms(8:8) = '1' ! I only do 1-char checks
if ((hisparms(9:9).eq.'~').and.(myparms(9:9).eq.'~')) then
repeat = .true. ! We both agree to do 8th bits
else
repeat = .false.
end if
if (hisbuf .lt. 6) then ! call that a packet?
ok = .false.
else if (hisbuf+hisnpad .gt. 104) then
ok = .false.
end if
! decode his eol
hisparms(5:5) = char(unchar(hisparms(5:5))) ! save true eol char
return
end ! subroutine decode
subroutine errorpkt(msg)
implicit integer(a-z)
! Function : formats an error packet w/msg arg text
! Called Procedures : kchar, cksum
parameter (thispkt = 1, soh=01 )
character *40 msg
character *104 packet(2)
character kchar, cksum
common /states/ state, retry, ntries, oldtries, seq
common /packets/ packet
k = index(msg,'.') ! look for a delimiter
if (k.eq.0) k = 40 ! if none - xfer max
packet(thispkt)(2:2) = kchar(k+3)
packet(thispkt)(3:3) = ' ' ! no seq.
packet(thispkt)(4:4) = 'E' ! type is Error
packet(thispkt)(5:4+k) = msg(1:k)
packet(thispkt)(5+k:5+k) = cksum(packet(thispkt))
call sendpkt(thispkt)
return
end ! subroutine errorpkt
!-cr.stdutils-!
character function kchar(n)
! maps an integer n=(0,136)octal onto the nth character
! in the ascii printable range : 40,176 octal
kchar = char( n + 040b )
return
end
character function kctl(n)
! Function : maps true ctl char (ascii 000 - 037) onto unique
! printable representation.
character n
kctl = char( ichar(n) .xor. 100b)
return
end
integer function unchar(n)
! Function : maps print char onto decoded octal
character n
unchar = ichar(n) - 40b
return
end
character function cksum(cpkt)
implicit integer(a-z)
!Function : computes Type 1 checksum for argument pkt
! Called Rtnes : unchar, kchar
character kchar
character *104 cpkt
count = unchar(cpkt(2:2)) ! decode to true count
sum = 0 ! initialize
do 100 i=2,count + 1
sum = sum + ichar(cpkt(i:i)) ! add coded char value
100 continue
sum = (sum + shiftr(sum .and. 300b , 6)) .and. 077b
cksum = kchar(sum)
return
end
integer function strad(x)
! returns word addr of string argument
parameter( strmask = 77700000000000b )
itemp = loc(x)
strad = ( itemp .and. strmask ) .xor. itemp
return
end
logical function member(word,pattern)
implicit integer(a-z)
character word*8, pattern*1
if (index(word,pattern).eq.0) then
member = .false.
else
member = .true.
end if
return
end ! logical fn member
subroutine stdname(string)
implicit integer(a-z)
! Function : Converts incoming file name from uppercase to lower,
! and if there is a trailing dot, but no suffix, blanks
! out the dot.
character*8 string
parameter(dot=056b)
do 10 i=1,8
cval = ichar(string(i:i))
if ((cval.ge.101b).and.(cval.le.132b)) then
string(i:i) = char(cval+40b) ! Convert to lower case
end if
10 continue
dx = index(string(1:8),char(dot))
if (dx.gt.0) then ! file name has a dot
! See if the dot is followed by a Suffix :
if (dx.eq.8) then
string(dx:dx) = ' ' ! blank out the dot
else if (string(dx+1:dx+1).eq.' ') then
string(dx:dx) = ' '
end if ! if no suffix follows the dot
! else leave dot and suffix in file name
end if ! if file name has embedded dot
return
end
subroutine tdisp(value,pval)
implicit integer(a-z)
! Function : converts integer value to Ascii equivalent
character*4 pval
if (value.gt.9999) then
pval(1:4) = ' big'
else
p2 = value/10
p3 = p2/10
p4 = p3/10
pval(1:4) = char(p4+48)//char(mod(p3,10)+48) //
! char(mod(mod(p2,100),10)+48) //
! char(mod(mod(mod(value,1000),100),10)+48)
end if
70 return
end ! subroutine tdisp
subroutine undisp(str,val,code)
implicit integer(a-z)
! Function : converts 2-digit Ascii string to numeric value
character *2 str
logical code
if ((str(1:1).ge.'0').and.(str(1:1).le.'9').and.
! (str(2:2).ge.'0').and.(str(2:2).le.'9')) then
val = 10*(ichar(str(1:1))-48) + ichar(str(2:2)) - 48
code = .true.
else
val = 0
code = .false.
end if
return
end ! subroutine undisp
subroutine logger
implicit integer(a-z)
character *104 packet(2)
character *80 logit
logical status, fexist, fopen
common /units/ logioc, fioc
common /packets/ packet
entry initlog(status)
inquire(iostat=ios,exist=fexist,opened=fopen,file='kmtlog')
if ((ios.ne.0).or.( fexist.and.fopen)) then
status = .false.
go to 100
else
if (fexist) then
call destroy(logioc,'kmtlog',0,dstat)
if (dstat.ne.0) then
status = .false.
go to 100
end if
end if
open(unit=logioc,iostat=ios,file='kmtlog',status='new')
if (ios.ne.0) then
status = .false.
go to 100
else
status = .true.
end if
end if
go to 100
entry logline(logit)
! Function : writes calling string argument onto std logfile.
! Uses 1st 40 chars if no '$$' terminator in string.
k = index(logit,'$')
if ((k.eq.0).or.(logit(k+1:k+1).ne.'$'))
!then ! no terminator, use default
k = 40
else
k = k-1
end if
write(unit=logioc,fmt=*) logit(1:k)
go to 100
entry logpkt(px)
! Function : writes the packet indexed in calling argument
! onto std logfile. This routine is called from
! the SENDPKT and GETPKT routines if the debug
! option is on.
k = unchar(packet(px)(2:2)) + 2 ! number of chars. to log
write(unit=logioc,fmt=*) packet(px)(1:k)
go to 100
entry endlog
close(unit=logioc,iostat=ios,status='keep')
100 continue
return
end ! subroutine logger
