!-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