home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
cdccyber.tar.gz
/
cdccyber.tar
/
cdcker.for
< prev
next >
Wrap
Text File
|
1988-08-16
|
186KB
|
6,006 lines
*comdeck comcker
cc comcker - kermit symbol definitions.
c
c this comdeck contains all symbol definitions needed by kermit. it
c contains items found in several different areas in the texas
c version of kermit, and cleans up usage conflicts among the various
c parameter values. this comdeck should be *called into every
c kermit module.
c
implicit integer (a - z)
cc kermit site definitions.
c
c character set information.
c
c ipc641 = ip.c64.1 (from iptext).
c ipc642 = ip.c64.2 (from iptext).
c ipc63 = ip.c63 (from iptext).
c ipcset = ip.cset = character set in use at your site.
c n.b. ipcset is ignored if ut2d = 1.
c
parameter (ipc641=0, ipc642=1, ipc63=2)
*if def,63cset,1
parameter (ipcset=ipc63)
*if def,641cset,1
parameter (ipcset=ipc641)
*if def,642cset,1
parameter (ipcset=ipc642)
cc o.s. definitions. set your o.s. to 1, all others to 0.
c
*if def,nos,1
parameter (ut2d=0, nos=1, nosbe=0, scope=0)
*if def,nosbe,1
parameter (ut2d=0, nos=0, nosbe=1, scope=0)
*if def,scope,1
parameter (ut2d=0, nos=0, nosbe=0, scope=1)
*if def,ut2d,1
parameter (ut2d=1, nos=0, nosbe=0, scope=0)
cc site definitions. used for sites with non-standard opsys.
c
*if def,uariz,1
parameter (utexas=0, uariz=1)
*if def,utexas,1
parameter (utexas=1, uariz=0)
*if def,other,1
parameter (utexas=0, uariz=0)
cc nos definitions. used for nos sites.
c
c nosver = version number (14, 20, 21, etc).
c noslvl = psr level.
parameter (nosver = 22, noslvl=602)
cc file i/o definitions.
c
parameter (stdin=1, stdout=2)
cc ascii character definitions.
c
parameter (soh=1, tab=9, lf=10, cr=13, blank=32, minus=45)
parameter (qmark=63, del=127, nel=o"0205", null=o"4000", eof=-1)
cc miscellaneous.
c
parameter (ok=1, error=-2, on=1, off=0, yes=1, no=0)
cc protocol definitions.
c
parameter (unknown=0, fulldup=1, halfdup=2)
parameter (none=0, even=1, odd=2, mark=3, space=4)
parameter (maxinit=20, maxtry=5)
parameter (maxpack=94, mytime=10, mypad=0, mypadch=0)
parameter (myeol=13, myquote=35, quot8ch=78, mycktyp=49)
parameter (prefxch=126)
cc packet types.
c
parameter (a=65, b=66, c=67, d=68, e=69, f=70, g=71, l=76, n=78)
parameter (r=82, s=83, y=89, z=90)
cc packet error definitions
c
parameter (toomany=o"1000", invalid=o"2000", seqerr=o"4000")
parameter (lclfile=o"10000", notlcl=o"20000", invfn=o"40000")
parameter (srvcmd=o"100000")
parameter (sending=o"100", reading=o"200")
parameter (initerr=1, filerr=2, dataerr=4, eoferr=o"10")
parameter (brkerr=o"20")
cccc kermit saved common block header
c
c all common blocks to be saved when executing monitor
c commands must be placed between /header/ and /trailer/
c
common /header/ header
cccc kermit command processor common block.
c
common /kermcmd/ autoret, dskcset, rdelay
cccc kermit packet description common block.
c
c do not allocate any storage between packsiz and sndsync!
c allocate storage for what i want.
common /packet/ packsiz, timeout, npad, padch, eolch, quotech,
+ quote8, chktyp, rprefix, reserve(2), sync,
c allocate storage for what partner wants.
+ spksiz, stimout, spad, spadch, speol, spquote,
+ s8quote, schktyp, srepeat, unused(2), sndsync
cccc kermit protocol common block.
c
common /proto/ packet(maxpack), recpack(maxpack),
+ filestr(maxpack),
+ psize, packnum, numtry, maxrtry, maxrini, state, ifd, ofd, ffd,
+ delayfp, savedpx,
c storage for statistics.
+ abortyp, startim, endtim, schcnt, rchcnt, schovrh, rchovrh
cccc debug common block.
c
parameter (dbgoff=0, dbgstat=1, dbgpack=2, dbgall=3)
common /debug/ debug, debugfd, debugfn(8)
cccc ascii string message common block defintions.
c
integer errmsg(maxpack)
common /msg/ errmsg
cccc kermit saved common block trailer
c
common /trailer/ trailer
cccc file i/o common block definitions.
c
parameter (maxfile=5)
c cio related parameters.
c
c ciord = cio read function code.
c ciowt = cio write function code.
c ciobufl = cio buffer length (must be .gt. pru size of device).
c fetl = fet length in words.
c maxwd = line size in words; must be an even number.
c normal = flag to exitpgm that this is a normal exit.
boolean ciord, ciowt
parameter (ciord = o"10", ciowt = o"14")
parameter (asciiio = 43, nosbit = 42, cioodd = o"2")
parameter (ciobufl=129, fetl=6, maxwd=32)
parameter (closed=0, rd=1, wr=2, create=3)
parameter (nopar=0, evepar=1, oddpar=2, mrkpar=3, spcpar=4)
parameter (dskdpc=0, dsknos8=1, dskut8=2, dskimag=4)
parameter (dskasci = dsknos8 .or. dskut8)
character*10 fname(maxfile)
common /fileioc/ fname
boolean fchbuf(maxwd,maxfile)
boolean fets(0:fetl - 1,maxfile), ciobuff(ciobufl,maxfile)
integer fmode(maxfile), fnwds(maxfile), fwptr(maxfile),
+ fwshft(maxfile)
logical feof(maxfile), ctdev(maxfile), rawmode, binmode
logical normal
common /fileio/ fmode, fwptr, fnwds, feof, fwshft,
+ ctdev, rawmode, binmode, parity, duplex, normal
common /fetcom/ fets, ciobuff, fchbuf
c common // ciobuff, fchbuf
cccc message common block.
c
character*37 version
character*15 ambig
character*38 nomatch
character*24 follow
character*53 nodigit
character*31 missing
character*33 confmsg
character*19 notconf
character*42 hlpdlfp
character*37 hlpdbfn
character*24 hlpplen
character*34 hlppadl
character*74 hlpasch
character*29 hlpiprc
character*21 hlpprtr
character*43 hlptimo
character*19 hlpsnfn
character*41 hlprdel
common /message/ version, ambig, nomatch, follow, nodigit,
+ missing, confmsg, notconf,
+ hlpasch, hlpdlfp, hlpdbfn, hlpplen, hlppadl, hlpiprc, hlpprtr,
+ hlptimo, hlpsnfn, hlprdel
cccc character conversion tables.
c
c dpctbl = ascii to display code table.
c lascii = display code to lower case ascii.
c uascii = display code to upper case ascii.
boolean dpctbl(0:127), lascii(0:63), uascii(0:63)
common /charcom/ dpctbl, lascii, uascii
*comdeck kermcom same as comcker, but turns off listing.
c$ list(s=0)
c
c the following c$ lines are here instead of comcker because
c ftn5 flags them as errors in a block data module (grrrr).
c
c$ collate(fixed)
c$ do(ot=0)
*call comcker
c$ list(s=1)
*deck kermit
*if def,ovcap
ident kermit
lcc overlay(0,0,ov=8)
ldset lib
ldset lib=kermlib/azlib/ftn5lib
ldset omit=syserr. saves 2000b+ words
entry kermit
syscom b1
kermit title kermit - micro computer file exchange/kermit protocol.
comment micro computer file exchange/kermit protocol.
kermit space 4,10
***** kermit - micro computer file exchange/kermit protocol.
*
* kermit is a file shipping program used by micro computers to
* transfer files to/from another computer. it was originally
* developed by columbia university for their decsystem-20, and
* adapted by the university of texas for their cyber and ut2d
* operating system.
kermit space 4,10
*** micro computer file interchange/kermit protocol.
*
* this version is for use under nos/be. in case you are
* wondering, kermit stands for (k)l10 (e)rror-free (r)eciprocal
* (m)icroprocessor (i)nterchange over (t)ty lines. (x)
* indicates a letter in the acronym. a kl-10 (aka kl-20) is a
* digital equipment corporation 36 bit cpu.
kermit space 4,10
** internal documentation.
*
* due to the nasty habit intercom has of swapping out jobs that
* go into terminal input wait, kermit's field length must be
* kept to a minimum. since kermit does ascii i/o, it cannot
* use fortran read and write statements. thus, an easy way to
* save memory is to kick out most ftn5lib modules. this is
* complicated by some needed modules calling 'syserr.', which
* in turn drags in about 3000b words of other stuff. for this
* reason, i have included an 'ldset omit=syserr.' in this
* module. thus, should some error condition arise that
* would cause ichar, char, xovcap, or whoever to call 'syserr.',
* an error mode 1 at will happen in the routine making the
* call. since this should not occur, i am willing to live
* with the user hostile diagnostic. for debugging purposes,
* the ldset may be commented out so you get the ftn5 error
* diagnostic.
*
* i also used ovcaps instead of segmenting kermit so the core
* image can be installed in nucleus, with the ovcaps in sysovl.
* cdc has not yet answered a psr we submitted regarding fdl.ocr
* not looking in sysovl for caps for nucleus programs. thus,
* without our suggested code, ovcaps will need to be in nucleus
* also.
*
* each ovcap has a compass front-end so that the comment field
* of the binary has useful information in it. this is useful
* when you itemize a deadstart tape. also, making the main
* be in compass gets rid of a call to 'q5ntry=' which also
* saves some memory.
kermit title main program.
** main program.
kermit sb1 1
if def,actr,1
sa1 actr get control card parameter count
if def,ra.act,1
sa1 ra.act get control card parameter count
sx1 x1
zr x1,kermit1 if no parameters
message (=c* kermit - too many parameters.*),,rcl
abort ,nd,s
kermit1 rj =xkermain call the real workhorse
endrun
end kermit
*if def,nos
ident nostuff
title nostuuf - nos version 2 *kermit* assist.
*comment nostuuf - nos version 2 *kermit* assist.
entry memstat
entry nosinit
entry nosexit
entry nosetlf
entry nosctab
entry noswait
ldset lib=srvlib/symlib
sst
syscom b1
nostuff space 4,10
*** nostuuf - nos version 2 *kermit* assist.
* bill russell. 84/07/01.
nostuff space 4,10
*** nostuff contains various subroutines that interface
* kermit to nos version 2.
title nosinit - initialize *kermit* in a nos system.
nosinit space 4,10
*** nosinit - initialize *kermit* in a nos system.
*
* entry none.
*
* exit the following will be true:
* all nos/iaf prompts will be *off*
* the terminal will be in *ascii* mode
nosinit subr
sb1 1
prompt off
cset ascii
eq nosinit
title nosexit - terminate *kermit* in a nos system.
nosexit space 4,10
*** nosexit - terminate *kermit* in a nos system.
*
* entry none.
*
* exit final status message will be issued.
nosexit subr
sb1 1
move endcl,endc,endb
sx6 3
sa6 mema
rj memstat
endrun
title memstat - issue *b display* kermit memory status.
memstat space 4,10
*** memstat - issue *b display* kermit memory status.
*
* entry none.
*
* exit kermit status message will be displayed on the
* *b display*.
*
* calls cmm.gss (in nos system library symlib).
* cmm.op4 (to shrink memory).
memstat subr
sb1 1
rj =xcmm.op4 shrink at end of memory
rj =xcmm.gss fetch memory stats
sa1 x1+b1
rj =xcod=
sa1 endb+2
mx0 42
lx6 18
bx6 x0*x6
bx7 -x0*x1
bx6 x6+x7
sa6 a1
sa4 mema
message endb,x4,r
eq memstat
mema con 1 only line 1 of the display
enda con 0
endb data c* kermit running. xxxxxxb cm used.*
endc data c* kermit complete. xxxxxxb cm used.*
* 1234567890123456789012345678901234567890
endcl equ *-endc
title nosetlf - set the list-of-files.
nosetlf space 4,10
*** nosetlf - set the list-of-files.
*
* entry arg1 = fet pointer.
* arg2 = fet ordinal.
*
* exit (ra+arg2) = 42/ file name, 18/ fet address
nosetlf subr
sb1 1
mx0 42
sa3 x1
bx3 x0*x3 file name only
sa4 a1+b1
sa4 x4 file ordinal
sx6 x4-3 check if special name
pl x6,slf1 if not a special name
sa3 slfa+x4 fetch special nos name
slf1 sx6 x1
bx6 x6+x3 file name + pointer to fet
sa6 x4+b1 set name in lof
eq nosetlf
slfa bss 0 special list of files filenames
vfd 60/0 for *nothing*
vfd 42/0linput,18/0 for *stdin*
vfd 42/0loutput,18/0 for *stdout*
title nosctab - check type-ahead buffer in a nos system.
nosctab space 4,10
*** nosctab - check type-ahead buffer in a nos system.
*
* entry none.
*
* exit (x6) = 0 = if no characters in the type-ahead buffer.
nosctab subr
sb1 1
system tlx,r,ctab,1600b *check* type-ahead buffer
sa1 ctab
bx6 x1
eq nosctab return
ctab bssz 1 type-ahead present flag
title noswait - wait at a control point for 24 milli-seconds.
noswait space 4,10
*** noswait - wait at a control point for 24 milli-seconds.
*
* entry none.
noswait subr
sb1 1
wait 24 ** current nos 2.2 system default **
eq noswait
end
*endif
*if def,ovcap
subroutine kermain
*endif
*if -def,ovcap
program kermit
*endif
ccc kermit - a cyber file transfer program using the kermit protocol
c
c this program may not be sold for profit.
c
c modifications:
c
c 2.2 8/22/84 ric anderson, university of arizona at tuscon
c add update ifdefs for character set, operating system, and site
c selection. fix execmd to work under nos/be. fix cfe for use
c under nos/be. correct spelling errors.
c
c 2.1 8/16/84 bill russell, new york university
c added nos 2.2 support (up through level 602). add
c timeout during reads (nos 2.2 level 602 or above only).
c problems with the nos version should be directed to:
c
c bill russell
c new york university
c courant institute of mathematical sciences
c 251 mercer street
c ny, ny 10012
c
c arpa: russell@nyu.arpa
c uucp: ...!allegra!cmcl2!russell
c
c 2.0 4/17/84 jim knutson, university of texas at austin
c fix filename packet to send uppercase file names only.
c cleanup error packet handling (added to state table handlers).
c fix retry counts to use proper number. modify character tables.
c merge ric anderson's nos/be code. try to organize the
c source a little better. added push and ! commands.
c add read delay for performance tuning. changed nel back to
c 205b. the binary data-mode ignores nel though.
c ut2d requires the nel be a 205b. changed character tables
c to use octal constants for non-representable characters.
c
c 1.1 01/21/84 ric anderson, university of arizona at tuscon
c add ovcaps for installation in nucleus. add display code
c support. remove gobs and gobs of field length. changed
c nel to 4012b to avoid confusion with data byte. updated
c character tables for 63 and 64 character sets. changed
c percents in fprintfs to at-signs since 63 character set has
c no percent sign.
c
c 1.0 10/14/83 jim knutson, university of texas at austin
c original implementation.
c
c jim knutson
c computation center room 1
c univerisity of texas
c austin, tx 78712
c
c aprpanet address: knutson@ut-ngp
c
c special thanks to king ables for his contribution.
c
c modified for nos/be by ric anderson
c university of arizona
c computer center
c tucson, arizona 85721
c
c
c future enhancements:
c 8th bit quoting
c repeat counts
c wild card sends
c conditional code generation for i/o checks
c
c
c build sequence:
c build an update oplpl from the source file.
c create the compile file, changing the site parameter in the
c common deck comcker. also use *defines for ovcaps vs.
c segload version and site dependent compass. see
c implementation notes.
c for the ovcap version:
c ftn5,i,opt=2.
c ftn5,i,opt=2,b=librel.
c libgen,p=kermlib,f=librel.
c load,lgo.
c nogo,kermit.
c for the segload version:
c ftn5,i,opt=2.
c segload,i=segdef,b=kermit.
c load,lgo.
c nogo.
c load it with the following segload directives:
c tree kermit-(set,hlpcmd,execmd,server-(receive,send))
c set include show,status,match,setval
c receive include rinit,rfile,rdata
c send include sinit,sfile,sdata,seof,sbreak
c kermit global proto,packet,debug,message,fileio,fileioc
c end kermit
c
c implementation notes:
c
c there are now two versions available for kermit. one uses
c segload the other uses ovcaps. only the ovcap version may
c be installed on the system nucleus (cld for you ut2d fans).
c the default version you get from update is for segload.
c the ovcap version may be obtained by using the update
c directive *define,ovcap.
c the following defines have also been setup to select character
c set, operating system, and site. nos sites still need to
c modify the nosver and noslvl parameter in deck comcker.
c
c *define cset (63cset, 641cset, 642cset)
c *define opsys (ut2d, nos, nosbe, scope)
c *define site (utexas, uariz, other)
c
c this version of kermit should be portable to other cdc sites
c except for the above mentioned conditional updates and the
c following cases.
c
c the delay subroutine uses subroutine rtime to return the system
c real time clock (number of jifs since deadstart). nos and
c nos/be rtime macros allegedly return slightly different
c formats of data, so nos sites may need to modify delay().
c
c the server knows how to logout on ut2d and nos/be sites.
c ut2d uses a local funtion called bellc to perform this. nos/be
c and nos sites use a function to essentially pcc a logout
c control command. for nos sites, only those running level
c 596 or above may logout. see subroutine logout().
c
c the ascii i/o is also probably not portable since
c cdc does not really support ascii i/o yet.
c ascii i/o on ut2d (univ. of texas op. sys.) is done by
c setting bit 2**43 in fet+1. the ascii character set that
c is used is "8 in 12". this is 8 bits of an ascii character
c stored in a 12 bit byte. nulls are represented as 4000b,
c and the newline character (nel) is 205b. this is slightly
c different from the cdc end-of-line which is 0000b in the
c low order byte of the word. currently, 0000b bytes are ignored
c since nulls are guarded.
c
c the display code character mappings for ut2d are different
c than the 64 and 63 character set (sigh). these should
c already be taken care of in the conditional compilation.
c
c sites that modify kermit to run on their system should
c modify the appropriate parameter definition to allow
c conditional compilation for their site. try to be
c as general as you can when making mods.
c
c ****** above all send your mods back to ut *******
c
c kermit i/o considerations:
c
c kermit uses two modes of i/o. it does coded i/o when reading
c from the terminal to get commands. this causes the front
c end to map the cr/lf pair into a single nel character.
c normal cyber sites will have the nel character added for
c them by the subroutine findeol.
c command editing (backspace and cancel) and parity is taken
c careof by the front-end. binary i/o is used when reading
c and sending packets. this allows kermit to control the
c parity bit. other nos sites may have to set transparent mode
c to do this. binary i/o also causes no command editing to be
c done (backspaces are treated as regular ascii characters) and
c cr/lf is not mapped to nel. rawmode is a mode internal
c to kermit that causes no cr/lf <-> nel mapping.
c
c kermit opens two files (stdin and stdout) and connects
c them to the terminal for doing the ascii i/o. this was
c done to prevent problems with trying to buffer reads and
c writes to the same file. when reading/writing disk files,
c kermit will try to buffer 2 disk sectors (128 words) worth
c of data per read/write. this was changed from the 8 disk
c sectors (512 words) since this reduced wasted space for
c the terminal files and helped reduce field length.
c all i/o is done through interface routines to the compass
c i/o macros.
c
c the only implementation dependent i/o routines should be
c the compass i/o interface routines, stty() and perhaps
c the rtime() subroutine.
c see these routines for more info on what they do.
c
c subroutine ordering:
c main program and initialization
c kermit
c blkdat.
c exitpgm
c abtp
c kermit command subroutines
c execmd
c hlpcmd
c rcvfile
c sndfile
c set
c show
c status
c server
c
c kermlib routines:
c
c dmodcmd
c dbugcmd
c setpack
c dplxcmd
c parcmd
c command parsing subroutines
c match
c outtbl
c setval
c confirm
c server subroutines
c logout
c kermit receive state protocol subroutines
c receive
c rinit
c rfile
c rdata
c kermit send state protocol subroutines
c send
c sinit
c sfile
c sdata
c seof
c sbreak
c packet i/o subroutines
c sndpack
c rdpack
c buffill
c bufemp
c standard i/o subroutines
c fopen
c fclose
c fflush
c getc
c ungetc
c getword
c putc
c fread
c fwrite
c putstr
c putint
c putday
c putmnth
c fprintf
c sprintf
c doprnt
c stty
c gtty
c utility subroutines
c as2dpc
c asc
c dpc2as
c ctoi
c itos
c getemsg
c creat
c getnow
c filchk
c rdparam
c remove
c strcpy
c slen
c sndpar
c sleep
c delay
c nos/be utility modules.
c echoplx
c getrec
c findeol
c edl
c cfe
c getrec
c nos utility routines
c conbuff
c
*call kermcom
logical cfe
external exitpgm
parameter (tsize=11)
character*10 cmd(tsize)
data cmd / 'exit', 'help', 'push', 'quit', 'receive', 'send',
+ 'server', 'set', 'show', 'status', '!' /
c
c insure we are an interactive job.
c
c$ if (nosbe .eq. 1) then
call xgjo(ipriv,iorig)
if(iorig .ne. 3) then
call remark(' kermit - incorrect job origin.')
call abtp("nd,s")
endif
c$ endif
c$ if (ut2d .eq. 1)
call jobinfo(11,iorig)
if ((iorig.and.4) .ne. 4) then
call remark(' kermit - incorrect job origin.')
call abtp("nd,s")
endif
c$ endif
c
c if running from a system library, set infinite cpu
c time limit for this job step.
c
c$ if (nosbe .eq. 1) then
if(ipriv .eq. -1) call entl(o"77777")
c$ endif
c
c if running under nos - initialize kermit.
c
c$ if (nos .eq. 1)
call nosinit
c$ endif
c
c open the i/o files
c
if (fopen('stdin',rd) .ne. stdin) then
call displa(' cannot open standard input')
call abtp("nd")
else if (fopen('stdout',wr) .ne. stdout) then
call displa(' cannot open standard output')
call abtp("nd")
endif
c
c read in environment if needed
c
if (cfe('zzzzken')) then
cfd = fopen('zzzzken',rd)
if (cfd .eq. error) then
call displa(' cannot open temp file')
else
call fread(cfd,header,locf(trailer)-locf(header))
call fclose(cfd)
endif
call retfile('zzzzken')
endif
c
c make sure things get fixed during aborts
c
c$ if (nos .eq. 1)
call recovr(exitpgm,o"277",0)
c$ else
call recovr(exitpgm,o"77",0)
c$ endif
c
c parse and execute any commands
c
5 call fprintf(stdout,'^kermit-170>',0,0,0,0)
call fflush(stdout)
c$ if (nos .eq. 1)
c
c if running under nos - issue memory status message.
c
call writer(fets(0,stdout))
call memstat
c$ endif
call fflush(stdin)
indx = match(cmd,tsize,.true.)
if (indx .eq. error .or. indx .eq. 0) go to 5
if (indx .eq. eof) then
normal = .true.
call exitpgm
endif
go to (10, 20, 30, 10, 40, 50, 60, 70, 80, 90, 100), indx
c
c thats all folks
c
10 normal = .true.
call exitpgm
c
c give some help
c
*if def,ovcap
20 call xovcap('kermhlp')
call uovcap('kermhlp')
*endif
*if -def,ovcap
20 call hlpcmd
*endif
go to 5
c
c same as exit and quit but allows you to reenter with
c the same environment as before
c
30 autoret = no
*if def,ovcap
call xovcap('kermxcc')
call uovcap('kermxcc')
*endif
*if -def,ovcap
call execmd
*endif
go to 5
c
c receive a file
c
*if def,ovcap
40 call xovcap('kermrcv')
call uovcap('kermrcv')
*endif
*if -def,ovcap
40 call rcvfile
*endif
go to 5
c
c send a file
c
*if def,ovcap
50 call xovcap('kermsnd')
call uovcap('kermsnd')
*endif
*if -def,ovcap
50 call sndfile
*endif
go to 5
c
c enter server mode
c
*if def,ovcap
60 call xovcap('kermsrv')
call uovcap('kermsrv')
*endif
*if -def,ovcap
60 call server
*endif
go to 5
c
c set some attributes
c
*if def,ovcap
70 call xovcap('kermset')
call uovcap('kermset')
*endif
*if -def,ovcap
70 call set
*endif
go to 5
c
c show current settings
c
*if def,ovcap
80 call xovcap('kermsho')
call uovcap('kermsho')
*endif
*if -def,ovcap
80 call show
*endif
go to 5
c
c give the status of last transfer
c
*if def,ovcap
90 call xovcap('kermsta')
call uovcap('kermsta')
*endif
*if -def,ovcap
90 call status
*endif
go to 5
c
c exec a control command
c
100 autoret = yes
*if def,ovcap
call xovcap('kermxcc')
call uovcap('kermxcc')
*endif
*if -def,ovcap
call execmd
*endif
go to 5
end
block data
*call comcker
data fmode / maxfile*closed /
data fwptr,fnwds / maxfile*0, maxfile*0 /
data rawmode, binmode / 2*.false. /
data parity, duplex / nopar, fulldup /
data dskcset / dskdpc /
data normal / .false. /
data ifd, ofd / stdin, stdout /
data ffd / 0 /
data maxrtry, maxrini / maxtry, maxinit /
data packnum / 0 /
data startim, endtim / 2*0 /
data schcnt , rchcnt / 2*0 /
data schovrh, rchovrh / 2*0 /
data state / c /
data delayfp / 5 /
data rdelay / 100 /
data sync , sndsync / 2*soh /
data packsiz, spksiz / 2*maxpack /
data timeout, stimout / 2*mytime /
data npad , spad / 2*mypad /
data padch , spadch / 2*mypadch /
data eolch , speol / 2*myeol /
data quotech, spquote / 2*myquote /
data quote8 , s8quote / 2*quot8ch /
data chktyp , schktyp / 2*mycktyp /
data rprefix, srepeat / 2*prefxch /
data debug , debugfd / dbgoff, 0 /
data debugfn / 75, 69, 82, 77, 76, 79, 71, 0 /
c k e r m l o g
data (errmsg(i),i=1,14) / 63, 75, 101, 114, 109, 105, 116, 45, 49,
c ? k e r m i t - 1
+ 55, 48, 58, 2*32 /
c 7 0 :
data version / '^cyber-170 ^k^e^r^m^i^t version 2.2\n' /
data ambig / '?^ambiguous - "' /
data nomatch / '?^does not match switch or keyword - "' /
data follow / '^one of the following:\n' /
data nodigit /
+ '?^invalid, ^first nonspace character is not a digit\n' /
data missing / '?^invalid, ^missing parameter\n' /
data confmsg / '^confirm with a carriage return\n' /
data notconf / '?^not confirmed - "' /
data hlpasch / '^decimal, octal (^b), or hexidecimal (^h) code for
+ ^a^s^c^i^i character \n' /
data hlpdlfp / '^number of seconds to delay first packet\n' /
data hlpdbfn / '^debug output logfile specification\n' /
data hlpplen / '^maximum packet length\n' /
data hlppadl / '^number of pad characters to use\n' /
data hlpiprc / '^initial packet retry count\n' /
data hlpprtr / '^packet retry count\n' /
data hlptimo / '^number of seconds to wait before timeout\n' /
data hlpsnfn / '^filename to send\n' /
data hlprdel / '^milliseconds to delay each ^t^t^y read\n' /
c$ if (ut2d .eq. 1)
data dpctbl/r" ",31*r" ",r" ",r"!",r"""",o"65",r"$",o"71",r"&",
+ o"64",r"(",r")",r"*",r"+",r",",r"-",r".",r"/",r"0",
+ r"1",r"2",r"3",r"4",r"5",r"6",r"7",r"8",r"9",
+ o"63",r";",r"<",r"=",r">",o"75",r"@",
+ r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i",
+ r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r",
+ r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z",
+ r"[",o"76",r"]",o"70",r" ",r" ",
+ r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i",
+ r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r",
+ r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z",
+ 5*r" "/
data lascii/0,97,98,99,100,101,102,103,104,105,106,107,108,109,
c a b c d e f g h i j k l m
+ 110,111,112,113,114,115,116,117,118,119,120,121,122,
c n o p q r s t u v w x y z
+ 48,49,50,51,52,53,54,55,56,57,
c 0 1 2 3 4 5 6 7 8 9
+ 43,45,42,47,40,41,36,61,32,44,46,34,91,93,58,
c + - * / ( ) $ = , . " [ ] :
+ 39,35,33,38,94,37,60,62,64,63,92,59/
c ' # ! & ^ <pct> < > @ ? \ ;
data uascii/0,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,
c a b c d e f g h i j k l m n o p q
+ 82,83,84,85,86,87,88,89,90,48,49,50,51,52,53,54,55,
c r s t u v w x y z 0 1 2 3 4 5 6 7
+ 56,57,43,45,42,47,40,41,36,61,32,44,46,34,91,93,58,
c 8 9 + - * / ( ) $ = , . " [ ] :
+ 39,35,33,38,94,37,60,62,64,63,92,59/
c ' # ! & ^ <pct> < > @ ? \ ;
c$ else
c$ if(ipcset .eq. ipc63)
data dpctbl/r" ",31*r" ",r" ",r"!",r"""",o"60",r"$",r" ",r"&",
+ o"70",r"(",r")",r"*",r"+",r",",r"-",r".",r"/",r"0",
+ r"1",r"2",r"3",r"4",r"5",r"6",r"7",r"8",r"9",
+ o"63",r";",r"<",r"=",r">",o"71",r"@",
+ r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i",
+ r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r",
+ r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z",
+ r"[",o"75",r"]",o"76",o"65",r"@",
+ r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i",
+ r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r",
+ r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z",
+ r"[",r"\",r"]",r"^",r" "/
data lascii/32,97,98,99,100,101,102,103,104,105,106,107,108,109,
c a b c d e f g h i j k l m
+ 110,111,112,113,114,115,116,117,118,119,120,121,122,
c n o p q r s t u v w x y z
+ 48,49,50,51,52,53,54,55,56,57,
c 0 1 2 3 4 5 6 7 8 9
+ 43,45,42,47,40,41,36,61,32,44,46,35,91,93,58,
c + - * / ( ) $ = , . % [ ] :
+ 34,95,33,38,39,63,60,62,64,92,94,59/
c " # ! & ' ? < > @ \ ^ ;
data uascii/32,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,
c a b c d e f g h i j k l m n o p
+ 81,82,83,84,85,86,87,88,89,90,48,49,50,51,52,53,54,
c q r s t u v w x y z 0 1 2 3 4 5 6
+ 55,56,57,43,45,42,47,40,41,36,61,32,44,46,35,91,93,
c 7 8 9 + - * / ( ) $ = , . % [ ]
+ 58,34,95,33,38,39,63,60,62,64,92,94,59/
c : " # ! & ' ? < > @ \ ^ ;
c$ else
data dpctbl/r" ",31*r" ",r" ",r"!",r"""",o"60",r"$",o"63",r"&",
+ o"70",r"(",r")",r"*",r"+",r",",r"-",r".",r"/",r"0",
+ r"1",r"2",r"3",r"4",r"5",r"6",r"7",r"8",r"9",
+ o"0",r";",r"<",r"=",r">",o"71",r"@",
+ r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i",
+ r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r",
+ r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z",
+ r"[",o"75",r"]",o"76",o"65",r"@",
+ r"a",r"b",r"c",r"d",r"e",r"f",r"g",r"h",r"i",
+ r"j",r"k",r"l",r"m",r"n",r"o",r"p",r"q",r"r",
+ r"s",r"t",r"u",r"v",r"w",r"x",r"y",r"z",
+ r"[",r"\",r"]",r"^",r" "/
data lascii/58,97,98,99,100,101,102,103,104,105,106,107,108,109,
c : a b c d e f g h i j k l m
+ 110,111,112,113,114,115,116,117,118,119,120,121,122,
c n o p q r s t u v w x y z
+ 48,49,50,51,52,53,54,55,56,57,
c 0 1 2 3 4 5 6 7 8 9
+ 43,45,42,47,40,41,36,61,32,44,46,35,91,93,37,
c + - * / ( ) $ = , . % [ ] <pct>
+ 34,95,33,38,39,63,60,62,64,92,94,59/
c " # ! & ' ? < > @ \ ^ ;
data uascii/58,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,
c : a b c d e f g h i j k l m n o p
+ 81,82,83,84,85,86,87,88,89,90,48,49,50,51,52,53,54,
c q r s t u v w x y z 0 1 2 3 4 5 6
+ 55,56,57,43,45,42,47,40,41,36,61,32,44,46,35,91,93,
c 7 8 9 + - * / ( ) $ = , . % [ ]
+ 37,34,95,33,38,39,63,60,62,64,92,94,59/
c <pct> " # ! & ' ? < > @ \ ^ ;
c$ endif
c$ endif
end
subroutine exitpgm
ccc exitpgm - exit the program
c
*call kermcom
c
c set complete bit in all fets, in case we died in mid-cio call.
c
if(.not. normal) then
call remark (' kermit aborted.')
do 10 i = 1, maxfile
fets(0,i) = or(fets(0,i),1)
10 continue
endif
call fflush(stdout)
call stty('raw',off)
call stty('binary',off)
if (savedpx .ne. halfdup) call stty('duplex',fulldup)
call fclose(stdin)
call fclose(stdout)
if (debugfd.ne.0) call fclose(debugfd)
c
c if running under nos - issue memory status message.
c
c$ if (nos .eq. 1)
call nosexit
c$ else
call endrun
c$ endif
end
subroutine abtp(type)
cc abtp - abort program.
c
c this subroutine should not return.
c
*call kermcom
boolean type
c$ if (ut2d .eq. 1) then
call abort
c$ else
call abort(type)
c$ endif
return
end
*if def,ovcap
ident kermxcc
entry kermxcc
lcc ovcap.
ldset noept=unlfile
kermxcc title kermxcc - kermit execute control command processor.
comment kermxcc - kermit execute control command processor.
kermxcc space 4,10
** kermxcc - kermit execute control command processor.
*
kermxcc subr entry/exit
rj =xexecmd call the real workhorse
eq kermxccx return
end
*endif
subroutine execmd
ccc execmd - execute a control command
c
c execute a control command and return to command mode or
c exit to the operating system. next execution of kermit
c will return with current environment. this subroutine
c does not return.
c
*call kermcom
logical confirm, eatline
c$ if (nos .eq. 1)
c
c if running under nos - issue memory status message.
c
call memstat
c$ endif
c
c before we do anything rash
c
if (autoret .eq. no) then
if (.not. confirm(stdin)) return
endif
c
c write out the current environment
c
call retfile('zzzzken')
cfd = fopen('zzzzken',wr)
if (cfd .eq. error) then
call remark(' cannot create environment file.')
return
endif
call fwrite(cfd,header,locf(trailer)-locf(header))
call fclose(cfd)
c
c if only exit to the operating system
c
if (autoret .eq. no) then
normal = .true.
call exitpgm
endif
c
c write the control command file
c
dskcset = dskdpc
call retfile('zzzzkcc')
fd = fopen('zzzzkcc',create)
if (fd .eq. error) then
call remark(' cannot create ccl file.')
fd = closed
return
endif
c$ if (nos .eq. 1 .or. nosbe .eq. 1)
call fprintf(fd, '.proc,zzzzkcc.\n',0,0,0,0)
c$ endif
c
c copy command to command file
c
eatline = .false.
10 if (getc(stdin,ch) .eq. blank) then
go to 10
else
if (ch .eq. qmark) then
eatline = .true.
call fprintf(stdout,'^monitor command to execute\n',0,0,0,0)
c$ if (nos .eq. 1)
call fflush(stdout)
call writer(fets(0,stdout))
c$ endif
else
call putc(ch,fd)
endif
endif
20 ch = getc(stdin,ch)
if (.not. eatline) call putc(ch,fd)
if (ch .ne. nel) go to 20
c
c copy cleanup commands to command file
c
c$ if (nosbe .eq. 1) then
call fprintf(fd,'skip(ok)\nexit(s)\nendif(ok)\n' //
+ 'return(zzzzkcc)\nkermit.\n',0,0,0,0)
c$ endif
c$ if (ut2d .eq. 1)
call fprintf(fd,'.skipcc\n.exit\n.return zzzzkcc\n.kermit\n',
+ 0,0,0,0)
c$ endif
c$ if (nos .eq. 1)
call fprintf(fd, 'return(zzzzkcc)\nrevert,ex.kermit.\n',
+ 0,0,0,0)
call fprintf(fd, 'exit.\nreturn(zzzzkcc)\nrevert,ex.kermit.\n',
+ 0,0,0,0)
c$ endif
call fclose(fd)
c
c execute the command file
c
c$ if (nosbe .eq. 1) then
call excst('begin,,zzzzkcc.')
c$ endif
c$ if (ut2d .eq. 1)
call excst('.cntrl,zzzzkcc')
c$ endif
c$ if (nos .eq. 1)
call excst('zzzzkcc.')
c$ endif
end
*if def,ovcap
ident kermhlp
entry kermhlp
lcc ovcap.
ldset noept=unlfile
kermhlp title kermhlp - kermit help command processor.
comment kermit help command processor.
kermhlp space 4,10
** kermhlp - kermit help command processor.
kermhlp subr entry/exit
rj =xhlpcmd call the real workhorse
eq kermhlpx return
end
*endif
subroutine hlpcmd
ccc hlpcmd - process the help command.
c
*call kermcom
parameter (tsize=12)
character*10 hlptyp(tsize)
logical confirm
data hlptyp / 'exit', 'help', 'kermit', 'push', 'quit', 'receive',
+ 'send', 'server', 'set', 'show', 'status', '!' /
c$ if (nos .eq. 1)
c
c if running under nos - issue memory status message.
c
call memstat
c$ endif
indx = match(hlptyp,tsize,.true.)
if (indx .eq. eof .or. indx .eq. error) return
if (indx .eq. 0) go to 30
if (.not. confirm(stdin)) return
go to (10, 20, 30, 40, 10, 50, 60, 70, 80, 90, 100, 110), indx
c
c help exit
c
10 call fprintf(stdout,'^exit from ^kermit-170\n')
return
c
c help help
c
20 call fprintf(stdout,'\n^h^e^l^p [topic]\n\n^typing ^h^e^l^p alone
+prints a brief summary of ^kermit-170 and its commands.\n^you can
+also type\n\n ^h^e^l^p command\n\nfor any ^kermit-170 command, e
+.g. "help send", to get more detailed information\nabout a specifi
+c command. ^type\n\n ^h^e^l^p ?\n\nto see a list of all the ava
+ilable help commands, or consult the ^kermit ^users\n^guide.\n\n')
return
c
c help kermit
c
30 call fprintf(stdout,'\n^kermit is a file transfer protocol for use
+ over an asynchronous serial\ntelecommunication line. ^files are
+broken up into "packets" with checksums and\nother control informa
+tion to ensure (with high probability) error-free and\ncomplete tr
+ansmission.\n\n^kermit-170 is the implementation for the ^cyber 17
+0/730 and is\nrun "remotely" from another computer (e.g. a microco
+mputer).\n\n^you can run ^kermit interactively by typing repeated
+commands in response to\nits "^kermit-170>" prompt, or you can run
+ it as a remote server.\n\n^kermit-170 command summary -- optional
+ parts are in [brackets]:\n\n')
call fprintf(stdout,'* ^for exchanging files: ^s^e^n^d fil
+e\n')
call fprintf(stdout,' ^r^e^c^e^i^v^
+e\n\n')
call fprintf(stdout,'* ^for acting as a server: ^s^e^r^v^e^r
+\n\n')
call fprintf(stdout,'* ^setting nonstandard transmission and file
+parameters:\n ^s^e^t ^d^e^b^u^g, ^d^e^l^a^y, ^d^u^p^l^e^x,
+^p^a^r^i^t^y, ^i^n^i^t-^r^e^t^r^y, ^r^e^t^r^y\n')
call fprintf(stdout,' ^s^e^t ^s^e^n^d (or ^r^e^c^e^i^v^e) ^
+end-of-^line, ^packet-length, ^pad-^character,\n ^p
+ad-^length, ^quote-^character, ^sync-^character, ^time-^out\n')
call fprintf(stdout,'* ^getting information: ^h^e^l^p [to
+pic], ^s^t^a^t^u^s, ^s^h^o^w\n\n')
call fprintf(stdout,'* ^leaving the program: ^e^x^i^t, ^q
+^u^i^t\n\n')
call fprintf(stdout,'^for further information, type "help" for any
+ of the above, e.g. "help set",\nor see the "^kermit ^users ^guide
+" and the "^kermit ^protocol ^manual" for complete\ndetails.\n\n')
return
c
c help push
c
40 call fprintf(stdout,'\n^p^u^s^h\n\n^exit from ^kermit-170 saving t
+he current environment. ^the environment will be\nrestored upon r
+eentering ^kermit-170.\n')
return
c
c help receive
c
50 call fprintf(stdout,'\n^r^e^c^e^i^v^e\n\n^receive a file or group
+of files from the other host. ^if the name in the\n')
call fprintf(stdout,'header packet is not a legal ^cyber file name
+, the first 7 legal characters\n')
call fprintf(stdout,'will be used.\n\n^if the file already exits a
+s a local file, ^kermit will abort the transfer.\n')
call fprintf(stdout,'^if an error occurs during transfer, the file
+ being received will be\nremoved from the local file list to allow
+ the transfer to be retried.\n')
call fprintf(stdout,'^you should escape back to your local ^kermit
+ after entering ^r^e^c^e^i^v^e\nmode and give the ^s^e^n^d command
+.\n\n')
return
c
c help send
c
60 call fprintf(stdout,'\n^s^e^n^d filename\n\n')
call fprintf(stdout,'^send a file to the other host. ^the name of
+ the file is passed\nto the other host in a file header packet, so
+ that the file can be\nstored there with the same name.\n\n')
call fprintf(stdout,'^you should escape back to your local ^kermit
+ and give the ^r^e^c^e^i^v^e\ncommand. ^if you don''t do this fas
+t enough the "send-init" packet may\narrive prematurely. ^to prev
+ent this, use ^s^e^t ^d^e^l^a^y or hit the ^r^e^t^u^r^n key\non yo
+ur microcomputer if it does not timeout.\n\n')
return
c
c help server
c
70 call fprintf(stdout,'\n^s^e^r^v^e^r\n\n')
c$ if(ut2d .eq. 1)
call fprintf(stdout,'^act as a server for another ^kermit. ^take
+all further commands only from\nthe other ^kermit. ^after issuing
+ this command, escape back to your local\nsystem and issue ^s^e^n^
+d, ^r^e^c^e^i^v^e or ^g^e^t, ^b^y^e, or other server-oriented\ncom
+mands from there. ^if your local ^kermit does not have a ^b^y^e c
+ommand,\nit does not have the full ability to communicate with a ^
+kermit server (in\nwhich case you can only use the ^s^e^n^d comman
+d). ^if your local ^kermit\ndoes have a ^b^y^e command, use it to
+ shut down and log out the ^kermit\nserver when you are done with
+it; otherwise, connect back to the ^cyber, type\nseveral ^control-
+^c''s to stop the server, and logout.\n\n')
c$ else
c$ if(nosbe .eq. 1 .or. scope .eq. 1)
call fprintf(stdout,'^act as a server for another ^kermit. ^take
+all further commands only from\nthe other ^kermit. ^after issuing
+ this command, escape back to your local\nsystem and issue ^s^e^n^
+d, ^r^e^c^e^i^v^e or ^g^e^t, ^b^y^e, or other server-oriented\ncom
+mands from there. ^if your local ^kermit does not have a ^b^y^e c
+ommand,\nit does not have the full ability to communicate with a ^
+kermit server (in\nwhich case you can only use the ^s^e^n^d comman
+d). ^if your local ^kermit\ndoes have a ^b^y^e command, use it to
+ shut down and log out the ^kermit\nserver when you are done with
+it; otherwise, connect back to the ^cyber, type\nseveral ^percent-
+^a''s to stop the server, and logout.\n\n')
c$ else
call fprintf(stdout,'^act as a server for another ^kermit. ^take
+all further commands only from\nthe other ^kermit. ^after issuing
+ this command, escape back to your local\nsystem and issue ^s^e^n^
+d, ^r^e^c^e^i^v^e or ^g^e^t, ^b^y^e, or other server-oriented\ncom
+mands from there. ^if your local ^kermit does not have a ^b^y^e c
+ommand,\nit does not have the full ability to communicate with a ^
+kermit server (in\nwhich case you can only use the ^s^e^n^d comman
+d). ^if your local ^kermit\ndoes have a ^b^y^e command, use it to
+ shut down and log out the ^kermit\nserver when you are done with
+it; otherwise, connect back to the ^cyber, type\nseveral ^control-
+^t''s to stop the server, and logout.\n\n')
c$ endif
c$ endif
return
c
c help set
c
80 call fprintf(stdout,'\n^s^e^t\n')
call fprintf(stdout,' ^establish system-dependent parameters. ^y
+ou can examine their values with the\n ^s^h^o^w command. ^numeri
+c values may be decimal, octal (postfixed with a ^b),\n or hexade
+cimal (postfixed by an ^h). ^the following may be ^s^e^t:\n\n')
call fprintf(stdout,' ^d^a^t^a-^m^o^d^e keyword\n')
call fprintf(stdout,' ^declares the data mode to be used while p
+rocessing disk files. ^the choices\n are ^a^s^c^i^i, ^d^i^s^p^l
+^a^y, and ^image-^a^s^c^i^i. ^a^s^c^i^i means the disk file conta
+ins\n ^a^s^c^i^i data, ^d^i^s^p^l^a^y means the file contains ^d
+isplay ^code data, and ^image-\n ^a^s^c^i^i means the file conta
+ins 8-bit ^a^s^c^i^i data. ^the default is ^d^i^s^p^l^a^y.\n\n')
call fprintf(stdout,' ^d^e^b^u^g options\n ^show packet traffic
+explicitly. ^options are:\n')
call fprintf(stdout,' ^a^l^l ^set all debug options.\n')
call fprintf(stdout,' ^l^o^g-^f^i^l^e ^log states and packets to
+ the specified file. ^the default\n log-file is file ^
+k^e^r^m^l^o^g.\n')
call fprintf(stdout,' ^o^f^f ^don''t display debugging info
+rmation (this is the default). ^if\n debugging was in
+effect, turn it off and close any log file.\n')
call fprintf(stdout,' ^p^a^c^k^e^t^s ^display each incoming and
+ outgoing packet (lengthy).\n')
call fprintf(stdout,' ^s^t^a^t^e^s ^show kermit state transiti
+ons and packet numbers (brief).\n\n')
call fprintf(stdout,' ^d^e^l^a^y decimal-number\n')
call fprintf(stdout,' ^how many seconds to wait before sending t
+he first packet. ^this gives you\n time to "escape" back and is
+sue a ^r^e^c^e^i^v^e command.\n\n')
call fprintf(stdout,' ^d^u^p^l^e^x keyword\n')
call fprintf(stdout,' ^changes the method of echoing characters
+when being prompted for commands.\n ^the choices are ^f^u^l^l an
+d ^h^a^l^f. ^full means the ^cyber will echo the\n characters y
+ou type. ^half means the local systems echos them. ^full is\n
+the default, and is used by most hosts.\n\n')
call fprintf(stdout,' ^i^n^i^t-^r^e^t^r^y decimal-number\n')
call fprintf(stdout,' ^set the maximum number of retries allowed
+ for the initial connection\n before giving up.\n\n')
call fprintf(stdout,' ^p^a^r^i^t^y keyword\n')
call fprintf(stdout,' ^if the other computer is using parity on
+the communication line, you must\n inform ^kermit-170, so it can
+ send the desired parity on outgoing characters,\n and strip it
+from incoming ones.\n')
call fprintf(stdout,'\n ^this must be set in ^kermit and the fro
+nt-end. ^see a system manual for\n setting parity in the front-
+end.\n')
call fprintf(stdout,'\n ^choices are ^n^o^n^e (the default), ^e^
+v^e^n, ^o^d^d, ^m^a^r^k, and ^s^p^a^c^e.\n ^n^o^n^e means no par
+ity processing is done, and the 8th bit of each character\n can
+be used for data when transmitting binary files.\n\n')
call fprintf(stdout,' ^r^d^e^l^a^y decimal-number\n')
call fprintf(stdout,' ^set the number of milliseconds of delay b
+efore issuing a read to the\n terminal. ^this may be used to tu
+ne reads so that data is ready\n when the read function is issue
+d and swapping does not take place.\n\n')
call fprintf(stdout,' ^r^e^t^r^y decimal-number\n')
call fprintf(stdout,' ^set the maximum number of retries allowed
+ for sending a particular packet.\n\n')
call fprintf(stdout,' ^s^e^n^d parameter\n ^parameters for outgo
+ing packets as follows:\n\n')
call fprintf(stdout,' ^end-of-^line octal-number\n')
call fprintf(stdout,' ^the octal value of the ^a^s^c^i^i chara
+cter to be used as a line terminator\n for packets, if one is
+required by the other system. ^carriage\n return (15^b) by de
+fault.\n\n')
call fprintf(stdout,' ^packet-^length decimal-number\n')
call fprintf(stdout,' ^maximum packet length to send, decimal
+number, between 20 and 94,\n 94 by default.\n\n')
call fprintf(stdout,' ^pad-^character octal-number\n')
call fprintf(stdout,' ^character to use for padding. ^default
+ is ^n^u^l.\n\n')
call fprintf(stdout,' ^pad-^length decimal-number\n')
call fprintf(stdout,' ^how much padding to send before a packe
+t. ^default is no padding.\n\n')
call fprintf(stdout,' ^quote-^character octal-number\n')
call fprintf(stdout,' ^what printable character to use for quo
+ting of control characters.\n ^the default is "#" (43^b). ^th
+ere should be no reason to change this.\n\n')
call fprintf(stdout,' ^sync-^character octal-number\n')
call fprintf(stdout,' ^the control character that marks the be
+ginning of the packet. ^normally\n ^s^o^h (^control-^a, ^a^s^
+c^i^i 1). ^there should be no reason to change this.\n\n')
call fprintf(stdout,' ^time-^out decimal-number\n')
call fprintf(stdout,' ^how many seconds the other ^kermit want
+s before being asked\n for retransmission. ^unfortunately, th
+e ^cyber has no way of timing\n out so this parameter is ignor
+ed.\n\n')
call fprintf(stdout,' ^r^e^c^e^i^v^e parameter\n ^parameters to
+request or expect for incoming packets, as follows:\n\n')
call fprintf(stdout,' ^end-of-^line octal-number\n')
call fprintf(stdout,' ^the octal value of the ^a^s^c^i^i chara
+cter to be used as a line terminator\n for packets, if one is
+required by the other system. ^carriage\n return (15^b) by de
+fault.\n\n')
call fprintf(stdout,' ^packet-^length decimal-number\n')
call fprintf(stdout,' ^maximum packet length to send, decimal
+number, between 20 and 94,\n 94 by default.\n\n')
call fprintf(stdout,' ^pad-^character octal-number\n')
call fprintf(stdout,' ^character to use for padding. ^default
+ is ^n^u^l.\n\n')
call fprintf(stdout,' ^pad-^length decimal-number\n')
call fprintf(stdout,' ^how much padding to send before a packe
+t. ^default is no padding.\n\n')
call fprintf(stdout,' ^quote-^character octal-number\n')
call fprintf(stdout,' ^what printable character to use for quo
+ting of control characters.\n ^the default is "#" (43^b). the
+re should be no reason to change this.\n\n')
call fprintf(stdout,' ^sync-^character octal-number\n')
call fprintf(stdout,' ^the control character that marks the be
+ginning of the packet. ^normally\n ^s^o^h (^control-^a, ^a^s^
+c^i^i 1). ^there should be no reason to change this.\n\n')
call fprintf(stdout,' ^time-^out decimal-number\n')
call fprintf(stdout,' ^how many seconds the other ^kermit shou
+ld wait for a packet before\n asking for retransmission.\n\n')
return
c
c help show
c
90 call fprintf(stdout,'^display current ^s^e^t parameters, version o
+f ^kermit-170, and other info.\n')
return
c
c help status
c
100 call fprintf(stdout,'^give statistics about the most recent file t
+ransfer.\n')
return
c
c help !
c
110 call fprintf(stdout,'\n! ^monitor-^command\n\n^execute a monitor c
+ommand from within ^kermit-170. ^the current settings\nwill be pr
+eserved.\n')
c$ if (nos .eq. 1)
call fprintf(stdout,'\n^note: ^the command must be formmated corre
+ctly with a ^n^o^s terminator [. or )].\n')
c$ endif
return
end
*if def,ovcap
ident kermrcv
entry kermrcv
lcc ovcap.
ldset noept=unlfile
kermrcv title kermrcv - kermit receive file processor.
comment kermit receive file processor.
kermrcv space 4,10
** kermrcv - kermit receive file processor.
kermrcv subr entry/exit
rj =xrcvfile call the real workhorse
eq kermrcvx return
end
*endif
subroutine rcvfile
ccc rcvfile - top level subroutine to start receive state.
c
*call kermcom
logical confirm
c$ if (nos .eq. 1)
c
c if running under nos - issue memory status message.
c
call memstat
c$ endif
c
c confirm the command
c
if (.not. confirm(stdin)) return
c
c insure their is no junk in the file array. this keeps remove
c happy, in the event we blow off before we get a file spec.
c
do 10 i = 1, maxpack
filestr(i) = 0
10 continue
call stty('binary',on)
if(dskcset .eq. dskimag) call stty('raw',on)
savedpx = gtty('duplex')
call stty('duplex',halfdup)
if (receive(r) .eq. ok) then
call fprintf(stdout,'^receive complete.\n',0,0,0,0)
else
call fprintf(stdout,'^receive failed.\n',0,0,0,0)
endif
if(dskcset .eq. dskimag) call stty('raw',off)
call stty('binary',off)
if (savedpx .ne. halfdup) call stty('duplex',fulldup)
return
end
*if def,ovcap
ident kermsnd
entry kermsnd
lcc ovcap.
ldset noept=unlfile
kermsnd title kermsnd - kermit send file processor.
comment kermit send file processor.
kermsnd space 4,10
** kermsnd - kermit send file processor.
kermsnd subr entry/exit
rj =xsndfile call the real workhorse
eq kermsndx return
end
*endif
subroutine sndfile
ccc sndfile - send a file to other kermit.
c
*call kermcom
logical cfe
character*10 lfn
c$ if (nos .eq. 1)
c
c if running under nos - issue memory status message.
c
call memstat
c$ endif
c
c pick up the file name and save it for opening later
c
call setval(filestr,'s',iret,7,0,0,hlpsnfn,.true.)
if (iret .eq. error) return
c
c make sure the name is legal.
c
call as2dpc(filestr,lfn)
if (xvfn(lfn) .ne. 0) then
call fprintf(stdout,'?^illegal file name: @s.\n',filestr,0,0,0)
return
endif
c
c map it to upper-case
c
call dpc2as(lfn,filestr,slen(filestr))
c
c check to make sure it's there to send
c
if (.not. cfe(lfn)) then
call fprintf(stdout,'?^file @s is not local.\n',filestr,0,0,0)
return
endif
c
c delay the first packet
c
if (delayfp .gt. 0) call sleep(delayfp)
call stty('binary',on)
if(dskcset .eq. dskimag) call stty('raw',on)
savedpx = gtty('duplex')
call stty('duplex',halfdup)
c
c start sending packets
c
packnum = 0
if (send() .eq. ok) then
call fprintf(stdout,'^send complete.\n',0,0,0,0)
else
call fprintf(stdout,'^send failed.\n',0,0,0,0)
endif
if(dskcset .eq. dskimag) call stty('raw',off)
call stty('binary',off)
if (savedpx .ne. halfdup) call stty('duplex',fulldup)
return
end
*if def,ovcap
ident kermset
entry kermset
lcc ovcap.
ldset noept=unlfile
kermset title kermset - kermit set command processor.
comment kermit set command processor.
kermset space 4,10
** kermset - kermit set command processor.
kermset subr entry/exit
rj =xset call the real workhorse
eq kermsetx return
end
*endif
subroutine set
ccc set - set some attributes.
c
*call kermcom
parameter (tsize=10)
character*10 settyp(tsize)
data settyp / 'data-mode', 'debug', 'delay', 'duplex',
+ 'init-retry', 'parity', 'receive', 'rdelay',
+ 'retry', 'send' /
c$ if (nos .eq. 1)
c
c if running under nos - issue memory status message.
c
call memstat
c$ endif
indx = match(settyp,tsize,.false.)
if (indx .le. 0) return
go to (10, 20, 30, 40, 50, 60, 70, 75, 80, 90), indx
c
c set character set
c
10 call dmodcmd
return
c
c set debugging modes
c
20 call dbugcmd
return
c
c set first packet delay
c
30 call setval(delayfp,'i',0,30,0,30,hlpdlfp,.true.)
return
c
c set the duplex
c
40 call dplxcmd
return
c
c set intial packet retry count
c
50 call setval(maxrini,'i',1,50,1,50,hlpiprc,.true.)
return
c
c set parity
c
60 call parcmd
return
c
c set receive packet attributes
c
70 call setpack(packsiz)
return
c
c set read data delay
c
75 call setval(rdelay,'i',0,2000,0,2000,hlprdel,.true.)
return
c
c set packet retry count
c
80 call setval(maxrtry,'i',1,50,1,50,hlpprtr,.true.)
return
c
c set send packet attributes
c
90 call setpack(spksiz)
return
end
*if def,ovcap
ident kermsho
entry kermsho
lcc ovcap.
ldset noept=unlfile
kermsho title kermsho - kermit show command processor.
comment kermit show command processor.
kermsho space 4,10
** kermsho - kermit show command processor.
kermsho subr entry/exit
rj =xshow call the real workhorse
eq kermshox return
end
*endif
subroutine show
ccc show the current program settings
c
*call kermcom
logical confirm
c$ if (nos .eq. 1)
c
c if running under nos - issue memory status message.
c
call memstat
c$ endif
c
c confirm the command
c
if (.not. confirm(stdin)) return
call fprintf(stdout,version,0,0,0,0)
c$ if (nos .eq. 1)
call fprintf(stdout,'^n^o^s ^version @d.@d - ^level @d ',
+ nosver/10, (nosver-((nosver/10)*10)), noslvl, 0, 0)
c$ endif
c
c display the current date and time
c
call getnow(mm,dd,yy,hr,min,sec)
call putday(stdout,mm,dd,yy)
call fprintf(stdout,', ',0,0,0,0)
call putmnth(stdout,mm)
call fprintf(stdout,' @d, @d ',dd,yy,0,0)
if (hr .lt. 10) call putc(asc('0'),stdout)
call fprintf(stdout,'@d:',hr,0,0,0)
if (min .lt. 10) call putc(asc('0'),stdout)
call fprintf(stdout,'@d:',min,0,0,0)
if (sec .lt. 10) call putc(asc('0'),stdout)
call fprintf(stdout,'@d\n\n',sec,0,0,0)
c
c display disk character set
c
call fprintf(stdout,' ^data-mode: ',0,0,0,0)
if(dskcset .eq. dsknos8) then
call fprintf(stdout,'^n^o^s 812 ^a^s^c^i^i\n',0,0,0,0)
elseif(dskcset .eq. dskut8) then
call fprintf(stdout,'^u^t 812 ^a^s^c^i^i\n',0,0,0,0)
elseif(dskcset .eq. dskdpc) then
call fprintf(stdout,'^display-^code\n',0,0,0,0)
elseif(dskcset .eq. dskimag) then
call fprintf(stdout,'^image-^a^s^c^i^i\n',0,0,0,0)
else
call fprintf(stdout,'^unknown',0,0,0,0)
endif
c
c display known parity
c
call fprintf(stdout,' ^parity: ',0,0,0,0)
parity = gtty('parity')
if (parity .eq. none) then
call fprintf(stdout,'^none\n',0,0,0,0)
else if (parity .eq. even) then
call fprintf(stdout,'^even\n',0,0,0,0)
else if (parity .eq. odd) then
call fprintf(stdout,'^odd\n',0,0,0,0)
else if (parity .eq. mark) then
call fprintf(stdout,'^mark\n',0,0,0,0)
else if (parity .eq. space) then
call fprintf(stdout,'^space\n',0,0,0,0)
else
call fprintf(stdout,'^unknown\n',0,0,0,0)
endif
c
c display the current duplex
c
call fprintf(stdout,' ^duplex: ',0,0,0,0)
duplex = gtty('duplex')
if (duplex .eq. fulldup) then
call fprintf(stdout,'^full\n',0,0,0,0)
else if (duplex .eq. halfdup) then
call fprintf(stdout,'^half\n',0,0,0,0)
else
call fprintf(stdout,'^unknown\n',0,0,0,0)
endif
c
c display current debug modes
c
call fprintf(stdout,' ^debugging: ',0,0,0,0)
if ((debug.and.dbgstat).ne.0) call fprintf(stdout,'^states ',
+ 0,0,0,0)
if ((debug.and.dbgpack).ne.0) call fprintf(stdout,'^packets',
+ 0,0,0,0)
if (debug.eq.dbgoff) call fprintf(stdout,'^off',0,0,0,0)
call putc(nel,stdout)
if (debug .ne. dbgoff) then
call fprintf(stdout,' ^log file: @s\n',debugfn,0,0,0)
endif
c
c display packet settings
c
call fprintf(stdout,'\n^packet ^parameters\n',0,0,0,0)
call fprintf(stdout,
+ ' ^receive ^send\n',0,0,0,0)
call fprintf(stdout,' ^size: @d @d\n',
+ packsiz,spksiz,0,0)
call fprintf(stdout,' ^timeout: @d @d\n',
+ timeout,stimout,0,0)
call fprintf(stdout,' ^padding: @d',npad,0,0,0)
if (npad .lt. 10) call putc(blank,stdout)
call fprintf(stdout,' @d\n',spad,0,0,0)
call fprintf(stdout,' ^pad character: \^@c \^@c\n',
+ o"100".xor.(padch),o"100".xor.(spadch),0,0)
call fprintf(stdout,' ^end-of-^line: \^@c \^@c\n',
+ o"100".xor.(eolch),o"100".xor.(speol),0,0)
call fprintf(stdout,' ^control quote: @c @c\n',
+ quotech,spquote,0,0)
call fprintf(stdout,' ^start-of-^packet: \^@c \^@c\n',
+ o"100".xor.(sync),o"100".xor.(sndsync),0,0)
c
c display protocol stuff
c
call fprintf(stdout,'\n^delay before sending first packet: @d\n',
+ delayfp,0,0,0)
call fprintf(stdout,
+ '^delay @d milliseconds before each ^t^t^y read\n',rdelay,0,0,0)
call fprintf(stdout,'^init packet retry count: @d\n',maxrini,0,0,
+ 0)
call fprintf(stdout,'^packet retry count: @d\n\n',maxrtry,0,0,0)
return
end
*if def,ovcap
ident kermsta
entry kermsta
lcc ovcap.
ldset noept=unlfile
kermsta title kermsta - kermit status command processor.
comment kermit status command processor.
kermsta space 4,10
** kermsta - kermit status command processor.
kermsta subr entry/exit
rj =xstatus call the real workhorse
eq kermstax return
end
*endif
subroutine status
ccc status - tell how long last transfer took.
c
*call kermcom
logical confirm
c$ if (nos .eq. 1)
c
c if running under nos - issue memory status message.
c
call memstat
c$ endif
c
c confirm the command
c
if (.not. confirm(stdin)) return
call fprintf(stdout,
+ '^max characters in packet: @d received; @d sent\n',packsiz,
+ spksiz,0,0)
if (endtim .lt. startim) endtim = endtim + 86400
nsec = endtim - startim
hr = nsec / 3600
nsec = nsec - (hr * 3600)
min = nsec / 60
nsec = nsec - (min * 60)
call fprintf(stdout,'^number of characters transmitted in ',
+ 0,0,0,0)
if (hr .gt. 0) call fprintf(stdout,'@d hours ',hr,0,0,0)
if (min .gt. 0) call fprintf(stdout,'@d minutes ',min,0,0,0)
call fprintf(stdout,'@d seconds\n\n',nsec,0,0,0)
call fprintf(stdout,' ^sent: @20d',schcnt,0,0,0)
call fprintf(stdout,' ^overhead: @d\n',schovrh,0,0,0)
call fprintf(stdout,' ^received: @20d',rchcnt,0,0,0)
call fprintf(stdout,' ^overhead: @d\n',rchovrh,0,0,0)
call fprintf(stdout,'^total transmitted: @20d',schcnt+rchcnt,0,0,
+ 0)
call fprintf(stdout,' ^overhead: @d\n',schovrh+rchovrh,0,0,0)
call fprintf(stdout,
+ '^total characters transmitted per sec: @d\n',
+ (schcnt+rchcnt) / (endtim-startim),0,0,0)
call fprintf(stdout,
+ '^effective data rate: @d baud\n', ((schcnt+rchcnt) -
+ (schovrh+rchovrh)) / (endtim-startim) * 10,0,0,0)
if (state .ne. c) then
call getemsg(packet)
call fprintf(stdout,'?^kermit: @s\n',packet,0,0,0)
endif
return
end
*if def,ovcap
ident kermsrv
entry kermsrv
lcc ovcap.
ldset noept=unlfile
kermsrv title kermsrv - kermit server-mode processor.
comment kermit server-mode processor.
kermsrv space 4,10
** kermsrv - kermit server-mode processor.
kermsrv subr entry/exit
rj =xserver call the real workhorse
eq kermsrvx return
end
*endif
subroutine server
ccc server - start kermit server
c
c the server currently knows about the send and receive packets
c and also the generic kermit packets logout and finish. using
c logout can cause problem due to files not being made permanent
c before leaving. i suppose implementing system command packets
c would allow files to be saved but what other kermit allows
c system command packets and is there a standard what to
c checkpoint programs on the cyber?
c
*call kermcom
character*10 lfn
logical confirm, cfe
c$ if (nos .eq. 1)
c
c if running under nos - issue memory status message.
c
call memstat
c$ endif
c
c confirm the command
c
if (.not. confirm(stdin)) return
c
c initialize msg #, say no tries yet
c
packnum = 0
numtry = 0
call fprintf(stdout,'[^kermit server running on ^cyber host. ^ple
+ase type your escape sequence to\n return to your local machine. ^
+shut down the server by typing the ^kermit ^b^y^e \n command on yo
+ur local machine.]\n',0,0,0,0)
c$ if (nos .eq. 1)
call fflush(stdout)
c$ endif
call stty('binary',on)
savedpx = gtty('duplex')
call stty('duplex',halfdup)
1 ptyp = rdpack(len,num,recpack)
if (ptyp .eq. s) then
packnum = num
call rdparam(recpack)
i = sndpar(packet)
call sndpack(y,packnum,i,packet)
numtry = 0
packnum = mod(packnum+1,64)
recstat = receive(f)
if (debug .ne. 0) then
if (recstat .eq. error) then
call fprintf(debugfd,'^receive failed.\n',0,0,0,0)
else
call fprintf(debugfd,'^receive completed.\n',0,0,0,0)
endif
endif
else if (ptyp .eq. r) then
i = 0
call strcpy(recpack,filestr)
call as2dpc(filestr,lfn)
if (xvfn(lfn) .ne. 0) then
abortyp = invfn
call getemsg(errmsg(15))
call sndpack(e,packnum,slen(errmsg),errmsg)
else if (.not. cfe(lfn)) then
abortyp = notlcl
call getemsg(errmsg(15))
call sndpack(e,packnum,slen(errmsg),errmsg)
else
sndstat = send()
packnum = 0
if (debug .ne. 0) then
if (sndstat .eq. error) then
call fprintf(debugfd,'^send failed.\n',0,0,0,0)
else
call fprintf(debugfd,'^send completed.\n',0,0,0,0)
endif
endif
endif
else if (ptyp .eq. g) then
if (recpack(1) .eq. l) then
call sndpack(y,num,0,0)
call logout
else if (recpack(1) .eq. f) then
call sndpack(y,num,0,0)
normal = .true.
call exitpgm
else
abortyp = srvcmd
call getemsg(errmsg(15))
call sndpack(e,packnum,slen(errmsg),errmsg)
endif
else
if (debug .ne. 0) call fprintf
+ (debugfd,'server: invalid packet type: @d\n',ptyp,0,0,0)
abortyp = invalid.or.reading.or.srvcmd
call getemsg(errmsg(15))
call sndpack(e,packnum,slen(errmsg),errmsg)
endif
go to 1
end
*if def,ovcap
*cweor
*endif
*deck kermlib
subroutine dmodcmd
ccc dmodcmd - perform a set data-mode xxxx command.
c
*call kermcom
logical confirm
c$ if (ut2d .eq. 1)
parameter (tsize=4)
c$ endif
c$ if (ut2d .ne. 1)
parameter (tsize=3)
c$ endif
character*15 datatyp(tsize)
c$ if (ut2d .eq. 1)
data datatyp /'ascii', 'display-code', 'image-ascii', 'nos-ascii'/
c$ endif
c$ if (ut2d .ne. 1)
data datatyp / 'ascii', 'display-code', 'image-ascii' /
c$ endif
c
c match the parameter.
c
indx = match(datatyp,tsize,.false.)
if (indx .le. 0) return
if (.not. confirm(stdin)) return
c
c take the appropriate action.
c
c$ if (ut2d .eq. 1)
go to (10, 20, 30, 40), indx
c$ endif
c$ if (ut2d .ne. 1)
go to (10, 20, 30), indx
c$ endif
c
c set ascii character set.
c
c$ if (ut2d .eq. 1)
10 dskcset = dskut8
c$ endif
c$ if (ut2d .ne. 1)
10 dskcset = dsknos8
c$ endif
return
c
c set display character set.
c
20 dskcset = dskdpc
return
c
c set image data mode.
c
30 dskcset = dskimag
return
c$ if (ut2d .eq. 1)
c
c set nos 812 ascii
c
40 dskcset = dsknos8
return
c$ endif
end
subroutine dbugcmd
ccc dbugcmd - set the debugging modes.
c
*call kermcom
character*10 fn
logical confirm
parameter (tsize=5)
character*10 dbgtyp(tsize)
data dbgtyp / 'all', 'log-file', 'off', 'packets', 'states' /
indx = match(dbgtyp,tsize,.false.)
if (indx .le. 0) return
go to (10, 20, 30, 40, 50), indx
c
c set all debug modes
c
10 if (.not. confirm(stdin)) return
debug = dbgall
go to 100
c
c set debug logfile
c
20 call setval(debugfn,'s',iret,7,0,0,hlpdbfn,.true.)
if (iret .eq. ok) then
if (debugfd .ne. 0) then
call fclose(debugfd)
debugfd = 0
endif
go to 100
endif
return
c
c turn off all debugging
c
30 if (.not. confirm(stdin)) return
debug = dbgoff
if (debugfd .ne. 0) then
call fclose(debugfd)
debugfd = 0
endif
return
c
c toggle debug packets
c
40 if (.not. confirm(stdin)) return
debug = debug .xor. dbgpack
go to 100
c
c toggle debug states
c
50 if (.not. confirm(stdin)) return
debug = debug .xor. dbgstat
go to 100
c
c open the debug file if not done already
c
100 if (debugfd .eq. 0) then
call as2dpc(debugfn,fn)
debugfd = fopen(fn,wr)
endif
return
end
subroutine setpack(attr)
ccc set packet send or receive attributes.
c
c setpack will wet the attributes of the passed attribute
c list. this subroutine will set the appropriate packet
c parameter. the parameter to set is passed in an array
c and is very order dependent. see common block /packet/
c for the ordering. note that send and receive parameter
c ordering and storage size in the common block are
c identical. keep it that way!
c
*call kermcom
integer attr(12)
parameter (tsize=7)
character*15 attrtyp(tsize)
data attrtyp / 'end-of-line', 'packet-length', 'pad-character',
+ 'pad-length', 'quote-character', 'sync-character',
+ 'time-out' /
indx = match(attrtyp,tsize,.false.)
if (indx .le. 0) return
go to (10, 20, 30, 40, 50, 60, 70), indx
c
c set eol character
c
10 call setval(attr(5),'i',1,31,127,127,hlpasch,.true.)
return
c
c set maximum packet length
c
20 call setval(attr(1),'i',20,94,20,94,hlpplen,.true.)
return
c
c set pad character
c
30 call setval(attr(4),'i',0,31,127,127,hlpasch,.true.)
return
c
c set pad length
c
40 call setval(attr(3),'i',0,94,0,94,hlppadl,.true.)
return
c
c set quote character
c
50 call setval(attr(6),'i',33,62,96,126,hlpasch,.true.)
return
c
c set sync character
c
60 call setval(attr(12),'i',0,127,0,127,hlpasch,.true.)
return
c
c set timeout value
c
70 call setval(attr(2),'i',0,94,0,94,hlptimo,.true.)
return
end
subroutine dplxcmd
ccc dplxcmd - perform a set duplex xxxx command
c
*call kermcom
logical confirm
parameter (tsize=2)
character*10 duptyp(tsize)
data duptyp / 'full', 'half' /
c
c match the parameter
c
indx = match(duptyp,tsize,.false.)
if (indx .le. 0) return
if (.not. confirm(stdin)) return
c
c take the appropriate action
c
go to (10, 20), indx
c
c set full duplex
c
10 call stty('duplex',fulldup)
return
c
c set half duplex
c
20 call stty('duplex',halfdup)
return
end
subroutine parcmd
ccc parcmd - set the parity for terminal i/o.
c
*call kermcom
logical confirm
parameter (tsize=5)
character*10 partyp(tsize)
data partyp / 'even', 'mark', 'none', 'odd', 'space' /
c
c match the parameter
c
indx = match(partyp,tsize,.false.)
if (indx .le. 0) return
if (.not. confirm(stdin)) return
c
c set the proper parity
c
go to (10, 20, 30, 40, 50), indx
10 call stty('parity',even)
return
20 call stty('parity',mark)
return
30 call stty('parity',none)
return
40 call stty('parity',odd)
return
50 call stty('parity',space)
return
end
integer function match(table,tablen,nelok)
ccc match - match input with a table of possibilities.
c
c table should be an array of character strings defining what
c is reasonable input. match will read input and return the
c index of the table entry that matches or "error" if a proper
c match couldn't be made. matchs will fail if the input match
c is ambiguous or doesn't match at all. a question mark in the
c input will output the possible matches according to the input
c previously read and then return as if no match was made.
c
*call kermcom
character*(*) table(tablen)
logical nelok
character*40 word
integer astr(41)
c
c get the word to match
c
len = getword(stdin,astr,40)
if (len .eq. 0 .or. len .eq. eof) then
match = len
if (len .eq. 0 .and. .not. nelok) then
match = error
call fprintf(stdout,'?^null switch or keyword given\n',0,0,
+ 0,0)
endif
call fflush(stdin)
return
endif
call as2dpc(astr,word)
c
c begin the matching here; tables must be in alphabetical order
c
t1 = 1
t2 = tablen
chp = 1
10 if (chp .le. len) then
c
c if we find a "?", then give the possibilities
c
if (word(chp:chp) .eq. '?') then
call fprintf(stdout,follow,0,0,0,0)
call outtbl(table,t1,t2)
call fflush(stdin)
match = error
return
endif
c
c while word is less than lower table entry
c
20 if (word(chp:chp) .gt. table(t1)(chp:chp) .and.
+ t1 .le. t2) then
t1 = t1 + 1
go to 20
endif
c
c while word is greater than upper table entry
c
30 if (word(chp:chp) .lt. table(t2)(chp:chp) .and.
+ t2 .ge. t1) then
t2 = t2 - 1
go to 30
endif
c
c if we know we have a mismatch
c
if (t2 .lt. t1) then
call fprintf(stdout,nomatch,0,0,0,0)
call putstr(stdout,astr)
call fprintf(stdout,'"\n',0,0,0,0)
call fflush(stdin)
match = error
return
endif
chp = chp + 1
go to 10
endif
c
c after looking at the whole word, is it still ambiguous?
c
if (t1 .ne. t2) then
call fprintf(stdout,ambig,0,0,0,0)
call putstr(stdout,astr)
call fprintf(stdout,'"\n',0,0,0,0)
call fflush(stdin)
match = error
else
match = t1
endif
return
end
subroutine outtbl(table,start,fin)
ccc outtbl - output a string array in tabular format.
c
*call kermcom
character*(*) table(fin)
integer start, fin
character*80 line
integer astr(81)
integer colwid, ncols
colwid = len(table(1)) + 2
ncols = 80 / colwid
line = ' '
icol = 1
do 100 i = start,fin
ipos = (icol-1)*colwid + 1
line(ipos:) = table(i)
icol = icol + 1
if (icol .gt. ncols .or. i .eq. fin) then
call dpc2as(line,astr,len(line))
c
c delete trailing blanks
c
j = len(line)
10 if (line(j:j) .eq. ' ') then
astr(j) = 0
j = j - 1
go to 10
endif
call putstr(stdout,astr)
call putc(nel,stdout)
line = ' '
icol = 1
endif
100 continue
return
end
subroutine setval(var,vtyp,mn1,mx1,mn2,mx2,hlpmsg,confrm)
ccc setval - set a variable value.
c
c setval will read a token from input and set a variable to
c that value. if the token is a question mark then the
c help message will be displayed and setval will return
c without setting a value.
c
c entry: (vtyp) = character 's' for string variable.
c = character 'i' for integer variable.
c (mn1-mx1) = range #1 for var to fit in if integer.
c = mn1 is return code for error and mx1 is
c max size of string if string var.
c (mn2-mx2) = secondary range for var to fit in if
c integer var.
c = unused for string var.
c (hlpmsg) = fprintf message format to display if
c a question mark is read.
c
c exit: (var) = int value read if integer var. or string
c value read if string var.
c
*call kermcom
character*(*) vtyp, hlpmsg
integer var(41), str(41)
logical confrm, confirm
c
c check var type
c
if (vtyp .ne. 's' .and. vtyp .ne. 'i') then
call fprintf(stdout,'setval - invalid var type @c\n',asc(vtyp),
+ 0,0,0)
return
endif
if (vtyp .eq. 's' .and. mx1 .gt. 40) then
call fprintf(stdout,'setval - string max of @d is too large\n',
+ mx1,0,0,0)
return
endif
len = getword(stdin,str,mx1)
if (len .eq. 0 .or. len .eq. eof) then
if (vtyp .eq. 'i') then
call fprintf(stdout,nodigit,0,0,0,0)
else
call fprintf(stdout,missing,0,0,0,0)
mn1 = error
endif
return
endif
if (str(1) .eq. qmark) then
call fprintf(stdout,hlpmsg,0,0,0,0)
call fflush(stdin)
if (vtyp .eq. 's') mn1 = error
return
endif
c
c confirm the request if necessary
c
if (confrm) then
if (.not. confirm(stdin)) then
if (vtyp .eq. 's') mn1 = error
return
endif
endif
c
c go ahead and set the variable
c
if (vtyp .eq. 'i') then
i = ctoi(str)
if (i .ge. mn1 .and. i .le. mx1) then
var(1) = i
else if (i .ge. mn2 .and. i .le. mx2) then
var(2) = i
else
call fprintf(stdout,
+ '?^value is not within range of @d - @d',
+ mn1,mx1,0,0)
if (mn1 .ne. mn2 .or. mx1 .ne. mx2) call fprintf(stdout,
+ ' or @d - @d',mn2,mx2,0,0)
call putc(nel,stdout)
endif
else
do 100 i = 1,len
var(i) = str(i)
100 continue
var(len+1) = 0
mn1 = ok
endif
return
end
logical function confirm(fd)
ccc confirm - look for a newline.
c
c confirm will expect that the next token of input be a
c newline for confirmation to be true. if the next token
c is a question mark, then confirmation is false and
c a "confirm with a carriage return" message will be displayed.
c any other text will cause a 'not confirmed "text"' message
c to be displayed and confirm will return false.
c
*call kermcom
c
c get leading blanks til a token is found
c
confirm = .false.
10 if (getc(fd,ch) .eq. nel) then
confirm = .true.
else if (ch .eq. eof) then
return
else if (ch .eq. blank .or. ch .eq. tab) then
go to 10
else if (ch .eq. qmark) then
call fprintf(stdout,confmsg,0,0,0,0)
else
call fprintf(stdout,notconf,0,0,0,0)
20 call putc(ch,stdout)
ch = getc(fd,ch)
if (ch .ne. nel .and. ch .ne. eof) go to 20
call fprintf(stdout,'"\n',0,0,0,0)
endif
return
end
subroutine logout
ccc logout - log out the job
c
c this is site dependent.
*call kermcom
iret = error
c$ if (ut2d .eq. 1)
call bellc(l"logout",0,iret)
c$ endif
c$ if(nosbe .eq. 1)
if(savedpx .ne. halfdup) call stty('duplex',fulldup)
call excst('logout.')
c$ endif
c$ if(nos .eq. 1)
c$ if(noslvl .ge. 596)
if(savedpx .ne. halfdup) call stty('duplex',fulldup)
call excst('logout.')
c$ endif
c$ endif
if (iret .ne. 0) call displa('logout error',iret)
return
end
integer function receive(istate)
ccc receive - receive file state switching routine.
c
*call kermcom
c
c initialize statistics variables
c
call getnow(mm,dd,yy,hr,min,sec)
startim = hr * 3600 + min * 60 + sec
schcnt = 0
rchcnt = 0
schovrh = 0
rchovrh = 0
c
c set packet retry count & current state
c
numtry = 0
state = istate
c
c take appropriate action for the current state
c
10 if (state .eq. d) then
state = rdata()
else if (state .eq. f) then
state = rfile()
else if (state .eq. r) then
state = rinit()
else if (state .eq. c) then
call getnow(mm,dd,yy,hr,min,sec)
endtim = hr * 3600 + min * 60 + sec
receive = ok
return
else if (state .eq. e) then
receive = error
if (ffd .ne. closed) then
call fclose(ffd)
call remove(filestr)
endif
return
else if (state .eq. a) then
call getnow(mm,dd,yy,hr,min,sec)
endtim = hr * 3600 + min * 60 + sec
receive = error
if (ffd .ne. closed) then
call fclose(ffd)
call remove(filestr)
endif
call getemsg(errmsg(15))
call sndpack(e,packnum,slen(errmsg),errmsg)
return
else
call displa(' receive - state error = ',state)
if (ffd .ne. closed) call fclose(ffd)
receive = error
return
endif
if ((debug.and.dbgstat).ne.0) then
call fprintf(debugfd,'@c@2d ',state,packnum,0,0)
if (mod(packnum+1,16) .eq. 0) call putc(nel,debugfd)
endif
go to 10
end
integer function rinit()
ccc rinit - receive a send-init packet.
c
*call kermcom
c
c clean out filestr array so remove does not do dire things
c to the previously received file if we die before we get
c the new file specification.
c
do 10 i = 1, maxpack
filestr(i) = 0
10 continue
c
c check retry count
c
if (numtry .gt. maxrini) then
rinit = a
abortyp = toomany.or.reading.or.initerr
return
endif
numtry = numtry + 1
c
c read a packet and hope for the best
c
ptyp = rdpack(len,num,packet)
c
c is it a valid packet type?
c
if (ptyp .eq. s) then
packnum = num
call rdparam(packet)
len = sndpar(packet)
call sndpack(y,num,len,packet)
numtry = 0
packnum = mod(packnum+1,64)
rinit = f
c
c did we get a checksum error
c
else if (ptyp .eq. error) then
rinit = state
call sndpack(n,num,0,0)
else
rinit = a
abortyp = invalid.or.reading.or.initerr
endif
return
end
integer function rfile()
ccc rfile read a filename packet.
c
c rfile expects to see a filename (type f) packet. however, it may
c find a send-init retry, end-of-file retry or break packet.
c
*call kermcom
if (numtry .gt. maxrtry) then
rfile = a
abortyp = toomany.or.reading.or.filerr
return
endif
numtry = numtry + 1
c
c read a packet
c
ptyp = rdpack(len,num,packet)
c
c is it a filename packet?
c
if (ptyp .eq. f) then
if (num .ne. packnum) then
rfile = a
abortyp = seqerr.or.reading.or.filerr
return
endif
ffd = creat(packet)
if (ffd .eq. error) then
ffd = closed
rfile = a
abortyp = lclfile.or.reading.or.filerr
else
if (debug .ne. 0) call fprintf(debugfd,
+ '^receiving file @s\n',packet,0,0,0)
call strcpy(packet,filestr)
call sndpack(y,num,0,0)
numtry = 0
packnum = mod(packnum+1,64)
rfile = d
endif
c
c is it an old send-init packet
c
else if (ptyp .eq. s) then
if (mod(num+1,64) .eq. packnum) then
len = sndpar(packet)
call sndpack(y,num,len,packet)
numtry = 0
rfile = state
else
rfile = a
abortyp = seqerr.or.reading.or.initerr
endif
c
c is it an old eof packet?
c
else if (ptyp .eq. z) then
if (mod(num+1,64) .eq. packnum) then
call sndpack(y,num,0,0)
numtry = 0
rfile = state
else
rfile = a
abortyp = seqerr.or.reading.or.eoferr
endif
c
c is it a break packet?
c
else if (ptyp .eq. b) then
if (num .ne. packnum) then
rfile = a
abortyp = seqerr.or.reading.or.brkerr
else
call sndpack(y,packnum,0,0)
rfile = c
endif
c
c did we get an error packet?
c
else if (ptyp .eq. e) then
rfile = e
return
c
c did we get a checksum error?
c
else if (ptyp .eq. error) then
rfile = state
call sndpack(n,num,0,0)
c
c invalid packet type, so abort
c
else
rfile = a
abortyp = invalid.or.reading.or.filerr
endif
return
end
integer function rdata()
ccc rdata - read a data packet.
c
*call kermcom
c
c check retry count
c
if (numtry .gt. maxrtry) then
rdata = a
abortyp = toomany.or.reading.or.dataerr
return
endif
numtry = numtry + 1
c
c read a packet
c
ptyp = rdpack(len,num,packet)
c
c did we get a data packet?
c
if (ptyp .eq. d) then
if (num .ne. packnum) then
if (mod(num+1,64) .eq. packnum) then
call sndpack(y,num,0,0)
rdata = state
else
rdata = a
abortyp = seqerr.or.reading.or.dataerr
endif
else
call bufemp(packet,ffd,len)
call sndpack(y,packnum,0,0)
numtry = 0
packnum = mod(packnum+1,64)
rdata = state
endif
c
c is it an old filename packet?
c
else if (ptyp .eq. f) then
if (mod(num+1,64) .eq. packnum) then
call sndpack(y,num,0,0)
numtry = 0
rdata = state
else
rdata = a
abortyp = seqerr.or.reading.or.filerr
endif
c
c is it an eof packet?
c
else if (ptyp .eq. z) then
if (num .ne. packnum) then
rdata = a
abortyp = seqerr.or.reading.or.eoferr
else
call sndpack(y,packnum,0,0)
call fclose(ffd)
ffd = 0
packnum = mod(packnum+1,64)
rdata = f
endif
c
c did we get an error packet?
c
else if (ptyp .eq. e) then
rdata = e
return
else if (ptyp .eq. error) then
rdata = state
call sndpack(n,num,0,0)
else
rdata = a
abortyp = invalid.or.reading.or.dataerr
endif
return
end
integer function send()
ccc send - send file state switching routine
c
c the filename to send is assumed to have already been
c obtained and set in ascii string buffer filestr.
c
*call kermcom
c
c initialize statics variables
c
call getnow(mm,dd,yy,hr,min,sec)
startim = hr * 3600 + min * 60 + sec
schcnt = 0
rchcnt = 0
schovrh = 0
rchovrh = 0
state = s
numtry = 0
c
c take appropriate action for the current state
c
10 if (state .eq. d) then
state = sdata()
else if (state .eq. f) then
state = sfile()
else if (state .eq. z) then
state = seof()
else if (state .eq. s) then
state = sinit()
else if (state .eq. b) then
state = sbreak()
else if (state .eq. c) then
call getnow(mm,dd,yy,hr,min,sec)
endtim = hr * 3600 + min * 60 + sec
send = ok
return
else if (state .eq. e) then
call getnow(mm,dd,yy,hr,min,sec)
endtim = hr * 3600 + min * 60 + sec
send = error
if (ffd .ne. closed) call fclose(ffd)
return
else if (state .eq. a) then
call getnow(mm,dd,yy,hr,min,sec)
endtim = hr * 3600 + min * 60 + sec
send = error
if (ffd .ne. closed) call fclose(ffd)
call getemsg(errmsg(15))
call sndpack(e,packnum,slen(errmsg),errmsg)
return
else
call displa(' send - state error = ',state)
send = error
if (ffd .ne. closed) call fclose(ffd)
return
endif
if ((debug.and.dbgstat).ne.0) then
call fprintf(debugfd,'@c@2d ',state,packnum,0,0)
if (mod(packnum+1,16) .eq. 0) call putc(nel,debugfd)
endif
go to 10
end
integer function sinit()
ccc sinit - send the send-init packet and wait for reply.
c
c assumes filestr has already been checked for legal filename
c and being local.
c
*call kermcom
character*10 filenam
c
c check number of retries
c
if (numtry .gt. maxrini) then
sinit = a
abortyp = toomany.or.sending.or.initerr
return
endif
numtry = numtry + 1
c
c send the send-init packet with the right info
c
len = sndpar(packet)
call sndpack(s,packnum,len,packet)
c
c pick up and process the reply
c
ptyp = rdpack(len,num,recpack)
if (ptyp .eq. n) then
sinit = state
return
else if (ptyp .eq. y) then
if (packnum .ne. num) then
sinit = state
return
endif
call rdparam(recpack)
numtry = 0
packnum = mod(packnum+1,64)
call as2dpc(filestr,filenam)
ffd = fopen(filenam,rd)
if (ffd .eq. error) then
sinit = a
ffd = closed
else
sinit = f
endif
c
c did we get an error packet?
c
else if (ptyp .eq. e) then
sinit = e
return
else if (ptyp .eq. error) then
sinit = state
else
sinit = a
abortyp = invalid.or.sending.or.initerr
endif
return
end
integer function sfile()
ccc sfile - send a filename packet and wait for reply.
c
c the filename is assumed to have been previously obtained
c and stored in the ascii string buffer filestr in upper case.
c
*call kermcom
c
c have we tried this too many times?
c
if (numtry .gt. maxrtry) then
sfile = a
abortyp = toomany.or.sending.or.filerr
return
endif
numtry = numtry + 1
c
c send the filename packet
c
call sndpack(f,packnum,slen(filestr),filestr)
c
c check on the reply
c
ptyp = rdpack(len,num,recpack)
if (ptyp .eq. n) then
if (mod(packnum+1,64) .ne. num) then
sfile = state
return
else
ptyp = y
num = num - 1
endif
endif
if (ptyp .eq. y) then
if (packnum .ne. num) then
sfile = state
return
endif
numtry = 0
packnum = mod(packnum+1,64)
c
c get first packet of data from the file
c
psize = buffill(ffd,packet)
sfile = d
c
c did we get an error packet?
c
else if (ptyp .eq. e) then
sfile = e
return
else if (ptyp .eq. error) then
sfile = state
else
sfile = a
abortyp = invalid.or.sending.or.filerr
endif
return
end
integer function sdata()
ccc sdata - send a data packet and wait for reply.
c
*call kermcom
c
c have we tried this too many times?
c
if (numtry .gt. maxrtry) then
sdata = a
abortyp = toomany.or.sending.or.dataerr
return
endif
numtry = numtry + 1
c
c send the current data buffer
c
if (psize .eq. eof) then
sdata = z
return
endif
call sndpack(d,packnum,psize,packet)
c
c check on the reply
c
ptyp = rdpack(len,num,recpack)
if (ptyp .eq. n) then
if (mod(packnum+1,64) .ne. num) then
sdata = state
return
else
ptyp = y
num = num - 1
endif
endif
if (ptyp .eq. y) then
if (packnum .ne. num) then
sdata = state
return
endif
numtry = 0
packnum = mod(packnum+1,64)
psize = buffill(ffd,packet)
if (psize .eq. eof) then
sdata = z
else
sdata = state
endif
c
c did we get an error packet?
c
else if (ptyp .eq. e) then
sdata = e
return
else if (ptyp .eq. error) then
sdata = state
else
sdata = a
abortyp = invalid.or.sending.or.dataerr
endif
return
end
integer function seof()
ccc seof - send an eof packet and wait for the reply.
c
*call kermcom
c
c have we tried this too many times?
c
if (numtry .gt. maxrtry) then
seof = a
abortyp = toomany.or.sending.or.eoferr
return
endif
numtry = numtry + 1
c
c send the eof packet
c
call sndpack(z,packnum,0,0)
c
c check the reply
c
ptyp = rdpack(len,num,recpack)
if (ptyp .eq. n) then
if (mod(packnum+1,64) .ne. num) then
seof = state
return
else
ptyp = y
num = num - 1
endif
endif
if (ptyp .eq. y) then
if (packnum .ne. num) then
seof = state
return
endif
numtry = 0
packnum = mod(packnum+1,64)
call fclose(ffd)
seof = b
c
c did we get an error packet?
c
else if (ptyp .eq. e) then
seof = e
return
else if (ptyp .eq. error) then
seof = state
else
seof = a
abortyp = invalid.or.sending.or.eoferr
endif
return
end
integer function sbreak()
ccc sbreak - send the break packet and wait for reply.
c
*call kermcom
c
c have we tried this too many times?
c
if (numtry .gt. maxrtry) then
sbreak = a
abortyp = toomany.or.sending.or.brkerr
return
endif
numtry = numtry + 1
c
c send the break packet
c
call sndpack(b,packnum,0,0)
c
c check on the reply
c
ptyp = rdpack(len,num,recpack)
if (ptyp .eq. n) then
if (mod(packnum+1,64) .ne. num) then
sbreak = state
return
else
ptyp = y
num = num - 1
endif
endif
if (ptyp .eq. y) then
if (packnum .ne. num) then
sbreak = state
return
endif
numtry = 0
packnum = mod(packnum+1,64)
sbreak = c
c
c did we get an error packet?
c
else if (ptyp .eq. e) then
sbreak = e
return
else if (ptyp .eq. error) then
sbreak = state
else
sbreak = a
abortyp = invalid.or.sending.or.brkerr
endif
return
end
subroutine sndpack(type,num,len,data)
ccc sndpack - send a packet down an output stream
c
c sndpack will send a packet of information and log it
c if debug is turned on. this subroutine could be made
c more efficient by not calling a subroutine for each
c character, but that might cause portability problems.
c
*call kermcom
integer data(200)
c
c define the tochar statement function
c
tochar(ascch) = ascch + blank
if ((debug.and.dbgpack).ne.0) call fprintf(debugfd,'^sending...',
+ 0,0,0,0)
c
c put out pad chars
c
do 100 i = 1,spad
call putc(spadch,ofd)
if ((debug.and.dbgpack).ne.0) then
call putc(spadch,debugfd)
endif
100 continue
call putc(sndsync,ofd)
c
c packet len assumes one character checksums
c
chksum = tochar(len+3)
call putc(chksum,ofd)
tmp = tochar(num)
chksum = chksum + tmp
call putc(tmp,ofd)
chksum = chksum + type
call putc(type,ofd)
do 110 i = 1,len
chksum = chksum + (data(i) .and. o"377")
call putc(data(i),ofd)
110 continue
chksum = (chksum + (chksum.and.o"300") / o"100") .and. o"77"
call putc(tochar(chksum),ofd)
call putc(speol,ofd)
if ((debug.and.dbgpack).ne.0) then
call putc(sndsync,debugfd)
call putc(tochar(len+3),debugfd)
call putc(tochar(num),debugfd)
call putc(type,debugfd)
if (len .gt. 0) call putstr(debugfd,data)
call putc(tochar(chksum),debugfd)
call putc(speol,debugfd)
call putc(nel,debugfd)
endif
c force buffer flush since desired eol char won't. under nos/be,
c scope, and (i suspect) nos, we need 12 bits of zero in the
c low order 12 bits of a word to be the eol, or the data gets left
c in an intercom small buffer till the eol (or a writer) comes
c along. the conditional code adds a 60 bit eol in the case
c where the data is a multiple of 5 characters. in all other
c cases the eol is present, as the word was zeroed before any
c data was put in it.
if(fwshft(ofd) .eq. 0) then
fwshft(ofd) = 48
fnwds(ofd) = fnwds(ofd) + 1
fchbuf(fnwds(ofd),ofd) = 0
endif
call fflush(ofd)
c
c update the statistics
c
nch = spad + 5 + len + 1
schcnt = schcnt + nch
schovrh = schovrh + nch - len
return
end
integer function rdpack(len,num,data)
ccc rdpack - read a packet of information.
c
c rdpack will read a packet of data and return the packet type
c as a result. if the packet contains an error (checksum) then
c error will be returned. len, num, and data will be set according
c to the fields of the packet.
c
*call kermcom
integer data(*)
c
c define the unchar statement function
c
unchar(ascch) = ascch - blank
c
c is debug packets turned on?
c
if ((debug.and.dbgpack).ne.0) then
call fprintf(debugfd,'^reading...',0,0,0,0)
endif
nch = 0
c
c hunt for the start of packet
c
10 if(getc(ifd,ch) .eq. eof) then
call remark(' rdpack - found unexpected eof.')
call abtp("nd")
endif
nch = nch + 1
if ((debug.and.dbgpack).ne.0) call putc(ch,debugfd)
if (ch .ne. sync) go to 10
chksum = 0
len = 0
c
c parse each field of the packet
c
c for (field=1; field <= 5; field++)
field = 1
20 if (field .le. 5) then
c
c a character read in field 4 here is the first char of the
c data field or the checksum character if the data field is empty
c
if (field .ne. 5 .or. len .gt. 0) then
if(getc(ifd,ch) .eq. eof) then
call remark(' rdpack - found unexpected eof.')
call abtp("nd")
endif
if (ch .eq. sync) field = 0
nch = nch + 1
if ((debug.and.dbgpack).ne.0) call putc(ch,debugfd)
endif
if (field .le. 3) chksum = chksum + ch
c
c if resync
if (field .eq. 0) then
chksum = 0
if ((debug.and.dbgpack).ne.0) then
call fprintf(debugfd,'\n^reading...@c',sync,0,0,0)
endif
c
c if data length
else if (field .eq. 1) then
len = unchar(ch-3)
c
c if packet number
else if (field .eq. 2) then
num = unchar(ch)
c
c if packet type
else if (field .eq. 3) then
type = ch
c
c if data field is not empty
else if (field .eq. 4 .and. len .gt. 0) then
c
c read 2nd-len chars of data & checksum char
c
do 100 i = 1,len
if (i .gt. 1) then
ch = getc(ifd,ch)
if(ch .eq. eof) then
call remark(' rdpack - found unexpected eof.')
call abtp("nd")
endif
nch = nch + 1
if (ch .eq. sync) then
field = 0
go to 20
endif
if ((debug.and.dbgpack).ne.0) call putc(ch,debugfd)
endif
chksum = chksum + ch
data(i) = ch
100 continue
c
c if chksum char
else if (field .eq. 5) then
data(len+1) = 0
chksum = (chksum + ((chksum .and. o"300") / o"100"))
+ .and. o"77"
endif
c
c process next packet field
c
field = field + 1
go to 20
endif
if ((debug.and.dbgpack).ne.0) call putc(nel,debugfd)
c
c does the checksum match?
c
if (chksum .ne. unchar(ch)) then
rdpack = error
rchovrh = rchovrh + nch
if (debug .ne. 0) then
call fprintf(debugfd,'chksum error, found @d needed @d\n',
+ unchar(ch),chksum,0,0)
endif
else
rdpack = type
rchovrh = rchovrh + nch - len
endif
rchcnt = rchcnt + nch
c
c flush any end-of-line characters and other garbage
c
call fflush(ifd)
return
end
integer function buffill(fd,buffer)
ccc buffill - get some data to send.
c
c buffill reads from the file to send and performs all
c the proper escaping of control characters and mapping
c newlines into crlf sequences. if it ever gets smart
c enough, it will also do the 8 bit quoting and repeat
c counts.
c
c *** note: this algorithm assumes 5 overhead characters for the
c packet and leaves 3 characters in case the last character
c to buffer is a nel (expands to 4 characters).
c
*call kermcom
boolean buffer(*)
c
c define ctl statement function
c
ctl(ascch) = ascch .xor. o"100"
c
c get a packet worth of data
c
i = 0
10 if (getc(fd,ch) .ne. eof) then
if(ch .eq. null) ch = 0
tch = ch .and. o"177"
if (tch.lt.blank .or. tch.eq.del .or. tch.eq.spquote) then
if (ch .eq. nel .and. dskcset .ne. dskimag) then
buffer(i+1) = spquote
buffer(i+2) = ctl(cr)
i = i + 2
ch = lf
endif
i = i + 1
buffer(i) = spquote
if (tch.lt.blank .or. tch.eq.del) ch = ctl(ch)
endif
i = i + 1
buffer(i) = ch
if (i .ge. spksiz-8) then
buffill = i
go to 99
endif
go to 10
endif
if (i .eq. 0) then
buffill = eof
else
buffill = i
endif
99 buffer(i+1) = 0
return
end
subroutine bufemp(buffer,fd,len)
ccc bufemp - dump a buffer to a file.
c
*call kermcom
boolean buffer(*), ch, prevch
save prevch
data prevch / -1 /
c
c define ctl statement function
c
ctl(ascch) = ascch .xor. o"100"
c
c write the packet data to the file
c
i = 1
10 if (i .le. len) then
ch = buffer(i)
if (ch .eq. quotech) then
i = i + 1
ch = buffer(i)
tch = ch .and. o"177"
if ((ctl(tch).lt.blank).or.(ctl(tch).eq.del)) ch = ctl(ch)
if(ch .eq. 0) ch = null
endif
c
c if image transfer, do not convert things.
c
if(dskcset .eq. dskimag) then
call putc(ch,fd)
else
c
c convert cr/lf pair to nel (205b)
c
if (ch .eq. lf .and. prevch .eq. cr) then
ch = nel
c
c just a lone cr
c
else if (prevch .eq. cr) then
call putc(prevch,fd)
endif
if (ch .ne. cr) call putc(ch,fd)
prevch = ch
endif
i = i + 1
go to 10
endif
return
end
integer function fopen(fn,mode)
ccc fopen - pretend to open a file for i/o.
c
c fopen just assigns a file desciptor (integer index) to
c a file name. no opening of the file is really performed
c since this is done automatically by iop.
c
*call kermcom
character*10 fn
logical cfe
c
c check for valid parameters
c
if (mode .lt. rd .or. mode .gt. create) then
call displa(' fopen - invalid mode ',mode)
call abtp("nd")
endif
c
c find the next unused entry
c
do 100 i = 1, maxfile
c
c if unused table entry is found
c
if (fmode(i) .eq. closed) then
fname(i) = fn
fwptr(i) = 1
fnwds(i) = 0
if (mode .eq. rd) then
fwshft(i) = 12
else
fwshft(i) = 0
endif
if (mode .eq. create) then
if (cfe(fname(i))) then
fmode(i) = closed
fopen = error
return
endif
fmode(i) = wr
else
fmode(i) = mode
endif
feof(i) = .false.
ctdev(i) = .false.
fopen = i
call makefet(fname(i),fets(0,i),fetl,ciobuff(1,i),ciobufl)
c$ if (nos .eq. 1)
call nosetlf(fets(0,i), i)
c$ endif
c
c if standard i/o files, connect them to the terminal.
c
if (fn .eq. 'stdin' .or. fn .eq. 'stdout') then
c$ if (nos .eq. 1)
call return (fets(0,i))
fets(1,i) = l"tt" .or. (compl(mask(12)) .and. fets(1,i))
call mtr (l"lfmp" .or. shift(13, 24) .or. shift(1, 19)
+ .or. locf (fets(0,i)))
c$ else
call xcon(fets(0,i),1)
c$ endif
ctdev(i) = .true.
endif
c
c set the ascii flag and rewind the file.
c
if(fmode(i) .eq. rd) then
call open(fets(0,i),"read")
else
call open(fets(0,i),"write")
endif
call recall(fets(0,i))
fets(0,i) = and(fets(0,i),shift(mask(44),2))
if(fmode(i) .eq. wr) fets(0,i) = or(fets(0,i),ciowt)
if(fmode(i) .eq. rd) fets(0,i) = or(fets(0,i),ciord)
return
c
c if table entry file name matches fn
c
else if (fname(i) .eq. fn) then
call remark(' fopen - file ' // fn // ' already open.')
call abtp("nd")
endif
100 continue
call remark(' fopen - too many files open.')
call abtp("nd")
return
end
subroutine fclose(fd)
ccc fclose - remove an fd from the active list.
c
c fclose will remove the fd from the active list for
c allocation at a later date.
c
*call kermcom
if (fd .lt. 1 .or. fd .gt. maxfile) then
call displa(' fclose - invalid fd ',fd)
call abtp("nd")
endif
if (fmode(fd) .eq. 0) then
call displa(' fclose - fd not open.',fd)
return
endif
c
c force emptying of the buffer
c
call fflush(fd)
c
c write a file mark
c
if(fmode(fd) .eq. wr) then
call writer(fets(0,fd))
call recall(fets(0,fd))
endif
fmode(fd) = closed
if(ctdev(fd)) then
call close(fets(0,fd),"unload")
call recall(fets(0,fd))
else
call close(fets(0,fd),"rewind")
call recall(fets(0,fd))
endif
return
end
subroutine fflush(fd)
ccc fflush - flush an i/o buffer.
c
c fflush will flush the ascii string buffer for a particular
c file descriptor.
c
*call kermcom
parameter (nosibit = 36, intrcom = 42, asc128 = 22, asc256 = 23)
parameter (first = 1, in = 2, out = 3, limit = 4, intwd = 5)
c$ if (nos .eq. 1)
boolean bpatx
c$ endif
c
c is the fd valid?
c
if (fd .lt. 1 .or. fd .gt. maxfile) then
call displa(' fflush - invalid file descriptor',fd)
call abtp("nd")
endif
if (fmode(fd) .eq. 0) then
call displa(' fflush - file descriptor not open',fd)
call abtp("nd")
endif
c
c if fd was opened as write, then flush to the file
c
if (fmode(fd) .eq. wr) then
if(ctdev(fd)) then
c$ if (ut2d .eq. 1) then
fets(first,fd) = or(fets(first,fd),shift(1,asciiio))
c$ else
fets(first,fd) = or(fets(first,fd),shift(1,intrcom))
fets(intwd,fd) = shift(1,asc256)
c$ if (nos .eq. 1)
fets(first,fd) = or(fets(first,fd),shift(1,nosibit))
if (fnwds(fd) .eq. 1) then
bpatx = o"00004000400040004000"
else
bpatx = o"40004000400040004000"
endif
fchbuf(fnwds(fd),fd) = fchbuf(fnwds(fd),fd) .or. bpatx
fnwds(fd) = fnwds(fd) + 1
fchbuf(fnwds(fd),fd) = 0
c$ endif
c$ endif
elseif(fd .ne. debugfd .and. dskcset .eq. dskdpc) then
temp = dpctbl(0)
dpctbl(0) = 0
call xtxs(fchbuf(1,fd),fnwds(fd),fchbuf(1,fd),dpctbl)
if(mod(fnwds(fd),2) .eq. 0)
+ fchbuf(fnwds(fd) / 2 + 1,fd) = 0
dpctbl(0) = temp
fnwds(fd) = findeol(fchbuf(1,fd),fnwds(fd),.false.)
endif
call writew(fets(0,fd),fchbuf(1,fd),fnwds(fd))
c$ if (nos .eq. 1)
if ((binmode .or. rawmode) .and. ctdev(fd)) then
call writer(fets(0,fd))
endif
c$ endif
else if (fmode(fd) .eq. rd) then
call recall(fets(0,fd))
fets(in,fd) = and(fets(first,fd),o"777777")
fets(out,fd) = fets(in,fd)
endif
c
c reset buffer character count
c
fwptr(fd) = 1
fnwds(fd) = 0
if (fmode(fd) .eq. rd) then
fwshft(fd) = 12
else
fwshft(fd) = 0
endif
return
end
integer function getc(fd,ch)
ccc getc - return next character from the input stream.
c
c getc will return the next ascii character that was
c read from the file descriptor fd. reads are buffered
c with 5 characters packed to a word. o"0000" bytes
c are ignored. nuls are o"4000" bytes. eof (-1) is
c returned when eof is read.
c
*call kermcom
c
c is the fd valid?
c
if (fd .lt. 1 .or. fd .gt. maxfile) then
call displa(' getc - invalid file descriptor',fd)
call abtp("nd")
endif
if (fmode(fd) .eq. closed) then
call displa(' getc - file descriptor not open',fd)
call abtp("nd")
endif
c
c check if ok to read
c
if ((fmode(fd).and.rd) .ne. rd) then
call displa(' getc - read on write-only file ',fd)
call abtp("nd")
endif
c
c check if more data needed
c
10 if (fwptr(fd) .gt. fnwds(fd)) then
if (feof(fd)) then
getc = eof
return
endif
c
c get a buffer worth of data
c
nread = getrec(fd,fchbuf(1,fd),maxwd,feof(fd))
fwptr(fd) = 1
fnwds(fd) = nread
fwshft(fd) = 12
go to 10
endif
c
c pickup char to return and check for ignored o"0000" byte
c
ch = shift(fchbuf(fwptr(fd),fd),fwshft(fd)) .and. o"7777"
fwshft(fd) = fwshft(fd) + 12
if (fwshft(fd) .gt. 60) then
fwshft(fd) = 12
fwptr(fd) = fwptr(fd) + 1
endif
c
c if the front-end isn't stripping parity and we aren't using
c the eigth bit for data, then strip the parity bit. also, convert
c carriage returns and linefeeds which come from the keyboard into
c regular end-of-lines (this only happens in binmode).
c
if (binmode .and. .not. rawmode) then
if (parity .ne. nopar .and. ctdev(fd)) ch = ch .and. o"177"
if(ctdev(fd) .and. (ch .eq. cr .or. ch .eq. lf)) ch = nel
endif
if (ch .eq. 0) go to 10
getc = ch
return
end
subroutine ungetc(fd,ch)
ccc ungetc - try to put a character back into the input stream.
c
c ungetc can only put back characters as far as the beginning
c of the buffer. hopefully, this is ok, since only getword
c does this with an nel which should be well into the buffer.
*call kermcom
c
c is it ok to back up the pointer?
c
if (fwshft(fd) .eq. 12 .and. fwptr(fd) .eq. 1) then
call displa('ungetc - cannot push character ',ch)
return
endif
c
c back up the pointer
c
if (fwshft(fd) .eq. 12) then
fwshft(fd) = 60
fwptr(fd) = fwptr(fd) - 1
else
fwshft(fd) = fwshft(fd) - 12
endif
fchbuf(fwptr(fd),fd) = (fchbuf(fwptr(fd),fd) .and. shift(
+ o"7777",60-fwshft(fd))) .or. shift(ch,60-fwshft(fd))
feof(fd) = .false.
return
end
integer function getword(fd,str,maxlen)
ccc getword - get a word from an input stream.
c
c getword considers a word to be delimited by blanks.
c it will return the length of the word as its value.
c
*call kermcom
integer str(maxlen)
len = 0
c
c skip leading white spaces
c
10 if (getc(fd,ch) .eq. eof) then
getword = eof
return
else if (ch .eq. nel) then
getword = 0
return
endif
if (ch .eq. blank .or. ch .eq. tab) go to 10
c
c found the first character, so keep going
c
20 if (len .lt. maxlen) then
len = len + 1
str(len) = ch
endif
ch = getc(fd,ch)
if (ch .ne. eof .and. ch .ne. blank .and. ch .ne. tab .and.
+ ch .ne. nel) go to 20
c
c save eols for next getword
c
if (ch .eq. nel) call ungetc(fd,ch)
str(len+1) = 0
getword = len
return
end
subroutine putc(tch,fd)
ccc putc - put a character into an output stream
c
c putc outputs a character with the parity bit set to the
c proper parity if the output file is conversational.
c the five types of parity are defined for each character
c in a table.
c
*call kermcom
integer chparty(128)
data (chparty(i),i=1,38) /
+ o"40000200020040004000", o"02010001020100010001",
c nul soh
+ o"02020002020200020002", o"00030203020300030003",
c stx etx
+ o"02040004020400040004", o"00050205020500050005",
c eot enq
+ o"00060206020600060006", o"02070007020700070007",
c ack bel
+ o"02100010021000100010", o"00110211021100110011",
c bs ht
+ o"00120212021200120012", o"02130013021300130013",
c lf vt
+ o"00140214021400140014", o"02150015021500150015",
c ff cr
+ o"02160016021600160016", o"00170217021700170017",
c so si
+ o"02200020022000200020", o"00210221022100210021",
c dle dc1
+ o"00220222022200220022", o"02230023022300230023",
c dc2 dc3
+ o"00240224022400240024", o"02250025022500250025",
c dc4 nak
+ o"02260026022600260026", o"00270227022700270027",
c syn etb
+ o"00300230023000300030", o"02310031023100310031",
c can em
+ o"02320032023200320032", o"00330233023300330033",
c sub esc
+ o"02340034023400340034", o"00350235023500350035",
c fs gs
+ o"00360236023600360036", o"02370037023700370037",
c rs us
+ o"02400040024000400040", o"00410241024100410041",
c !
+ o"00420242024200420042", o"02430043024300430043",
c " pound
+ o"00440244024400440044", o"02450045024500450045" /
c $ percent
data (chparty(i),i=39,76) /
+ o"02460046024600460046", o"00470247024700470047",
c & '
+ o"00500250025000500050", o"02510051025100510051",
c ( )
+ o"02520052025200520052", o"00530253025300530053",
c * +
+ o"02540054025400540054", o"00550255025500550055",
c , -
+ o"00560256025600560056", o"02570057025700570057",
c . /
+ o"00600260026000600060", o"02610061026100610061",
c 0 1
+ o"02620062026200620062", o"00630263026300630063",
c 2 3
+ o"02640064026400640064", o"00650265026500650065",
c 4 5
+ o"00660266026600660066", o"02670067026700670067",
c 6 7
+ o"02700070027000700070", o"00710271027100710071",
c 8 9
+ o"00720272027200720072", o"02730073027300730073",
c : ;
+ o"00740274027400740074", o"02750075027500750075",
c < =
+ o"02760076027600760076", o"00770277027700770077",
c > ?
+ o"03000100030001000100", o"01010301030101010101",
c @ a
+ o"01020302030201020102", o"03030103030301030103",
c b c
+ o"01040304030401040104", o"03050105030501050105",
c d e
+ o"03060106030601060106", o"01070307030701070107",
c f g
+ o"01100310031001100110", o"03110111031101110111",
c h i
+ o"03120112031201120112", o"01130313031301130113" /
c j k
data (chparty(i),i=77,114) /
+ o"03140114031401140114", o"01150315031501150115",
c l m
+ o"01160316031601160116", o"03170117031701170117",
c n o
+ o"01200320032001200120", o"03210121032101210121",
c p q
+ o"03220122032201220122", o"01230323032301230123",
c r s
+ o"03240124032401240124", o"01250325032501250125",
c t u
+ o"01260326032601260126", o"03270127032701270127",
c v w
+ o"03300130033001300130", o"01310331033101310131",
c x y
+ o"01320332033201320132", o"03330133033301330133",
c z [
+ o"01340334033401340134", o"03350135033501350135",
c \ ]
+ o"03360136033601360136", o"01370337033701370137",
c ^ underscore
+ o"01400340034001400140", o"03410141034101410141",
c grave accent a
+ o"03420142034201420142", o"01430343034301430143",
c b c
+ o"03440144034401440144", o"01450345034501450145",
c d e
+ o"01460346034601460146", o"03470147034701470147",
c f g
+ o"03500150035001500150", o"01510351035101510151",
c h i
+ o"01520352035201520152", o"03530153035301530153",
c j k
+ o"01540354035401540154", o"03550155035501550155",
c l m
+ o"03560156035601560156", o"01570357035701570157",
c n o
+ o"03600160036001600160", o"01610361036101610161" /
data (chparty(i),i=115,128) /
c p q
+ o"01620362036201620162", o"03630163036301630163",
c r s
+ o"01640364036401640164", o"03650165036501650165",
c t u
+ o"03660166036601660166", o"01670367036701670167",
c v w
+ o"01700370037001700170", o"03710171037101710171",
c x y
+ o"03720172037201720172", o"01730373037301730173",
c z left brace
+ o"03740174037401740174", o"01750375037501750175",
c bar right brace
+ o"01760376037601760176", o"03770177037701770177" /
c tilde del
c
c is the fd valid?
c
if (fd .lt. 1 .or. fd .gt. maxfile) then
call displa(' putc - invalid file descriptor',fd)
call abtp("nd")
endif
if (fmode(fd) .eq. closed) then
call displa(' putc - file descriptor not open',fd)
call abtp("nd")
endif
c
c is it ok to write on this stream?
c
if ((fmode(fd).and.wr) .ne. wr) then
call displa(' putc - write on read-only file ',fd)
call abtp("nd")
endif
c
c add another character to the output buffer
c
ch = tch
10 if (ctdev(fd)) then
if (ch .eq. nel .and. .not. rawmode) ch = cr
if (ch .ge. 0 .and. ch .lt. 128)
+ ch = shift(chparty(ch+1),parity*12) .and. o"7777"
endif
if (fwshft(fd) .eq. 0) then
if (fnwds(fd) .eq. maxwd) then
call fflush(fd)
endif
fwshft(fd) = 48
fnwds(fd) = fnwds(fd) + 1
fchbuf(fnwds(fd),fd) = 0
else
fwshft(fd) = fwshft(fd) - 12
endif
c
c if this is an mass storage device (disk), and we have a nel
c character, flush the line into the cio buffer. the standard cdc
c line terminator is already present thanks to the above code
c pre-zeroing the target word before anything is put in it.
c however, don't flush if we need the nel character in the
c line (e.g. ut 812 ascii and disk image format).
c
if(.not.ctdev(fd) .and. tch.eq.nel .and. dskcset.ne.dskut8 .and.
+ dskcset.ne.dskimag) then
call fflush(fd)
return
endif
c$ if (nos .eq. 1)
c
c preset transparent output for the terminal if first word of buffer
c
if (fnwds(fd) .eq. 1 .and. fwshft(fd) .eq. 48) then
if (fmode(fd) .eq. wr .and. ctdev(fd)) then
fchbuf(fnwds(fd),fd) = shift(o"0007",48)
fwshft(fd) = 36
endif
endif
if (ctdev(fd)) ch = ch .or. o"4000"
c$ endif
fchbuf(fnwds(fd),fd) = fchbuf(fnwds(fd),fd) .or.
+ shift(and(ch,o"7777"),fwshft(fd))
if (tch .eq. nel .and. (ch.and.o"0177") .eq. cr) then
ch = lf
go to 10
endif
if (tch .eq. nel .and. ctdev(fd)) call fflush(fd)
return
end
subroutine fread(fd,buf,nwd)
ccc fread - read some words from a file.
c
*call kermcom
integer buf(nwd)
c
c is the fd valid?
c
if (fd .lt. 1 .or. fd .gt. maxfile) then
call displa(' fread - invalid file descriptor',fd)
call abtp("nd")
endif
if (fmode(fd) .eq. closed) then
call displa(' fread - file descriptor not open',fd)
call abtp("nd")
endif
c
c check if ok to read
c
if ((fmode(fd).and.rd) .ne. rd) then
call displa(' fread - read on write-only file ',fd)
call abtp("nd")
endif
c
c transfer a cio buffer full at a time until done
c
istart = 1
nleft = nwd
10 nrd = nleft
if (nrd .gt. ciobufl-1) then
nrd = ciobufl-1
endif
call readw(fets(0,fd),buf(istart),nrd)
istart = istart + nrd
nleft = nleft - nrd
if (nleft .gt. 0) goto 10
return
end
subroutine fwrite(fd,buf,nwd)
ccc fwrite - write some words to a file.
c
*call kermcom
c
c is the fd valid?
c
if (fd .lt. 1 .or. fd .gt. maxfile) then
call displa(' fwrite - invalid fd ',fd)
call abtp("nd")
endif
if (fmode(fd) .eq. closed) then
call displa(' fwrite - fd not open.',fd)
return
endif
c
c is it ok to write on this stream?
c
if ((fmode(fd).and.wr) .ne. wr) then
call displa(' fwrite - write on read-only file ',fd)
call abtp("nd")
endif
c
c write the words to the file
c
call writew(fets(0,fd),buf,nwd)
return
end
subroutine putstr(fd,str)
ccc putstr - output a string to an output stream.
c
c putstr will add characters from the null terminated character
c buffer str to the specified output stream.
c
*call kermcom
integer str(*)
c
c is the fd valid?
c
if (fd .lt. 1 .or. fd .gt. maxfile) then
call displa(' putc - invalid fd ',fd)
call abtp("nd")
endif
if (fmode(fd) .eq. 0) then
call displa(' putc - fd not open.',fd)
return
endif
c
c is it ok to write on this stream?
c
if ((fmode(fd).and.wr) .ne. wr) then
call displa(' putc - write on read-only file ',fd)
call abtp("nd")
endif
c
c put chars in the output buffer
c
i = 1
10 if (str(i) .ne. 0) then
c
c is it a valid character?
c
c if ((str(i).and.mask(48)) .ne. 0) then
c call displa(' putstr - invalid ascii byte ',str(i))
c call abort
c endif
call putc(str(i),fd)
i = i + 1
go to 10
endif
return
end
subroutine putint(fd,int,minwid)
ccc putint - output an integer.
c
*call kermcom
integer string(21)
width = 0
if (int .lt. 0) then
call putc(asc('-'),fd)
width = 1
endif
val = iabs(int)
ascii0 = asc('0')
nch = 0
10 nch = nch + 1
string(nch) = mod(val,10) + ascii0
val = val / 10
if (val .ne. 0 .and. nch .lt. 20) go to 10
width = width + nch
c
c now output the digits
c
20 call putc(string(nch),fd)
nch = nch - 1
if (nch .gt. 0) go to 20
30 if (width .lt. minwid) then
call putc(blank,fd)
width = width + 1
go to 30
endif
return
end
subroutine putday(fd,mm,dd,yy)
ccc output day of week.
c
*call kermcom
izlr(iyr,m,idy)=mod((13*(m+10-(m+10)/13*12)-1)/5+idy+77
1 +5*(iyr+(m-14)/12-(iyr+(m-14)/12)/100*100)/4
2 +(iyr+(m-14)/12)/400-(iyr+(m-14)/12)/100*2,7)+1
wkday = izlr(yy,mm,dd)
if (wkday .eq. 1) then
call fprintf(fd,'^sunday')
else if (wkday .eq. 2) then
call fprintf(fd,'^monday')
else if (wkday .eq. 3) then
call fprintf(fd,'^tuesday')
else if (wkday .eq. 4) then
call fprintf(fd,'^wednesday')
else if (wkday .eq. 5) then
call fprintf(fd,'^thursday')
else if (wkday .eq. 6) then
call fprintf(fd,'^friday')
else
call fprintf(fd,'^saturday')
endif
return
end
subroutine putmnth(fd,mm)
ccc putmnth - output the month name.
c
*call kermcom
if (mm .eq. 1) then
call fprintf(fd,'^january',0)
else if (mm .eq. 2) then
call fprintf(fd,'^february',0)
else if (mm .eq. 3) then
call fprintf(fd,'^march',0)
else if (mm .eq. 4) then
call fprintf(fd,'^april',0)
else if (mm .eq. 5) then
call fprintf(fd,'^may',0)
else if (mm .eq. 6) then
call fprintf(fd,'^june',0)
else if (mm .eq. 7) then
call fprintf(fd,'^july',0)
else if (mm .eq. 8) then
call fprintf(fd,'^august',0)
else if (mm .eq. 9) then
call fprintf(fd,'^september',0)
else if (mm .eq. 10) then
call fprintf(fd,'^october',0)
else if (mm .eq. 11) then
call fprintf(fd,'^november',0)
else if (mm .eq. 12) then
call fprintf(fd,'^december',0)
else
call fprintf(fd,'putmnth - no such month as @d\n',mm)
endif
return
end
subroutine fprintf(fd,fmt,i1,i2,i3,i4)
ccc fprintf - poor attempt at formatted ascii output.
c
c conversion is similar to fprintf used in c. supported
c conversions are @d (integer), @c (ascii character), @s (ascii
c string buffer). a \n will map to a newline, a \t will
c will map to a tab, a \0 will terminate the format scanning.
c a \ followed by any other character will cause that character
c to be output. the default output case will be lowercase.
c a ^ followed by a letter will cause that character to be output
c as uppercase. a @d conversion may now specify a minimum field
c width as @<n>d (i.e. @10d) in which the number will be blank
c padded to the right to use up <n> characters.
c
*call kermcom
character*(*) fmt
c
c is the fd valid?
c
if (fd .lt. 1 .or. fd .gt. maxfile) then
call displa(' fprintf - invalid fd ',fd)
call abtp("nd")
endif
if (fmode(fd) .eq. closed) then
call displa(' fprintf - fd not open.',fd)
return
endif
c
c is it ok to write on this stream?
c
if ((fmode(fd).and.wr) .ne. wr) then
call displa(' fprintf - write on read-only file ',fd)
call abtp("nd")
endif
c
c now call the real fprintf workhorse
c
call doprnt(fd,0,1,fmt,i1,i2,i3,i4)
return
end
subroutine sprintf(str,fmt,i1,i2,i3,i4)
ccc sprintf - poor attempt at doing internal formatted i/o.
c
c sprintf is the same as fprintf except that it writes to
c and ascii string buffer instead.
c
*call kermcom
character*(*) fmt
boolean str(*)
c
c call the real sprintf workhorse
c
call doprnt(0,str,2,fmt,i1,i2,i3,i4)
return
end
subroutine doprnt(fd,strng,ptyp,fmt,i1,i2,i3,i4)
ccc doprnt - workhorse for formatted ascii i/o.
c
c conversion is similar to fprintf used in c. supported
c conversions are @d (integer), @c (ascii character), @s (ascii
c string buffer). a \n will map to a newline, a \t will
c will map to a tab, a \0 will terminate the format scanning.
c a \ followed by any other character will cause that character
c to be output. the default output case will be lowercase.
c a ^ followed by a letter will cause that character to be output
c as uppercase. a @d conversion may now specify a minimum field
c width as @<n>d (i.e. @10d) in which the number will be blank
c padded to the right to use up <n> characters.
c
*call kermcom
character*(*) fmt
boolean str(21), strng(*)
character*1 ch
c
c check for file or string write
c
if (ptyp .ne. 1 .and. ptyp .ne. 2) then
call displa(' doprnt - invalid write function',ptyp)
call abtp("nd")
endif
c
c output the formatted string
c
iptr = 1
optr = 1
fptr = 1
fmtlen = len(fmt)
10 if (fptr .le. fmtlen) then
ch = fmt(fptr:fptr)
if (ch .ne. '\' .and. ch .ne. '@' .and. ch .ne. '^') then
if (ptyp .eq. 1) then
call putc(asc(ch),fd)
else
strng(optr) = asc(ch)
optr = optr + 1
endif
c
c is it a quote or special sequence character?
c
else if (ch .eq. '\') then
fptr = fptr+1
ch = fmt(fptr:fptr)
if (ch .eq. 'n' .and. ptyp .eq. 1) then
call putc(nel,fd)
else if (ch .eq. 't' .and. ptyp .eq. 1) then
call putc(tab,fd)
else if (ch .eq. '0') then
if (ptyp .eq. 2) strng(optr) = 0
return
else if (ch .eq. 'n') then
strng(optr) = nel
optr = optr + 1
else if (ch .eq. 't') then
strng(optr) = tab
optr = optr + 1
else
if (ptyp .eq. 1) then
call putc(asc(ch),fd)
else
strng(optr) = asc(ch)
optr = optr + 1
endif
endif
c
c is it an uppercase mapping?
c
else if (ch .eq. '^') then
fptr = fptr + 1
ch = fmt(fptr:fptr)
if (ch .ge. 'a' .and. ch .le. 'z') then
ach = asc(ch)-32
else
ach = asc(ch)
endif
if (ptyp .eq. 1) then
call putc(ach,fd)
else
strng(optr) = ach
optr = optr + 1
endif
c
c must be a conversion (@)
c
else
intwdth = 1
fptr = fptr + 1
ch = fmt(fptr:fptr)
c
c is it an integer value format spec?
c
20 if (ch .eq. 'd') then
if (iptr .eq. 1) then
ach = i1
else if (iptr .eq. 2) then
ach = i2
else if (iptr .eq. 3) then
ach = i3
else
ach = i4
endif
if (ptyp .eq. 1) then
call putint(fd,ach,intwdth)
else
tlen = itos(ach,strng(optr),intwdth)
optr = optr + tlen
endif
iptr = iptr + 1
c
c is it a character value output spec?
c
else if (ch .eq. 'c') then
if (iptr .eq. 1) then
ach = i1
else if (iptr .eq. 2) then
ach = i2
else if (iptr .eq. 3) then
ach = i3
else
ach = i4
endif
if (ptyp .eq. 1) then
call putc(ach,fd)
else
strng(optr) = ach
optr = optr + 1
endif
iptr = iptr + 1
c
c is it a string value output spec?
c
else if (ch .eq. 's') then
if (iptr .eq. 1) then
if (ptyp .eq. 1) then
call putstr(fd,i1)
else
call strcpy(i1,strng(optr))
optr = optr + slen(i1)
endif
else if (iptr .eq. 2) then
if (ptyp .eq. 1) then
call putstr(fd,i2)
else
call strcpy(i2,strng(optr))
optr = optr + slen(i2)
endif
else if (iptr .eq. 3) then
if (ptyp .eq. 1) then
call putstr(fd,i3)
else
call strcpy(i3,strng(optr))
optr = optr + slen(i3)
endif
else
if (ptyp .eq. 1) then
call putstr(fd,i4)
else
call strcpy(i4,strng(optr))
optr = optr + slen(i4)
endif
endif
iptr = iptr + 1
c
c is it a field width specifier?
c
else if (ch .ge. '0' .and. ch .le. '9') then
sptr = 0
30 sptr = sptr + 1
str(sptr) = asc(ch)
fptr = fptr + 1
ch = fmt(fptr:fptr)
if (ch .ge. '0' .and. ch .le. '9') go to 30
str(sptr+1) = 0
intwdth = ctoi(str)
go to 20
c
c unknown conversion so output the @ and conversion char
c
else
if (ptyp .eq. 1) then
call putc(asc('@'),fd)
call putc(asc(ch),fd)
else
strng(optr) = asc('@')
strng(optr+1) = asc(ch)
optr = optr + 2
endif
endif
endif
fptr = fptr + 1
go to 10
endif
if (ptyp .eq. 2) strng(optr) = 0
return
end
subroutine stty(mode,value)
ccc stty - set a terminal mode.
c
*call kermcom
character*(*) mode
integer value
c$ if (nos .eq. 1)
integer nositm(5), nosttm(2), nosfull, noshalf,
+ noszero, nosodd, noseven, nosnone
c
c for nos (initiate *rawmode*):
c set pw=0,ci=0,li=0,pg=n,ubl=15,ubz=200,eb=cr,fa=y,cp=0,lk=y
c
data nositm / o"00164043400040544000", o"40554000404540004030",
+ o"40174031400241014001", o"40674001410740004040",
+ o"40010000000000000000" /
c
c for nos (terminate *rawmode*):
c set fa=n,cp=1,lk=n
c
data nosttm / o"00164067400041074001", o"40404000000000000000" /
c
c for nos (full/half duplex):
c
data nosfull / o"00164061400100000000" /
data noshalf / o"00164061400000000000" /
c
c for nos (parity: zero, odd, even, none)
c
data noszero / o"00164062400000000000" /
data nosodd / o"00164062400100000000" /
data noseven / o"00164062400200000000" /
data nosnone / o"00164062400300000000" /
c
c$ endif
c
c is it setting duplex?
c
if (mode .eq. 'duplex') then
if (value .eq. fulldup) then
c$ if (ut2d .eq. 1)
call bellc(l"full",0,0)
c$ endif
c$ if(uariz .eq. 1)
call echoplx('on')
c$ endif
c$ if(nos .eq. 1)
call writew(fets(0,stdout),nosfull,1)
call writer(fets(0,stdout))
if (debug .ne. 0) then
call fprintf(debugfd, '^stty - full duplex.\n')
endif
c$ endif
duplex = fulldup
else if (value .eq. halfdup) then
c$ if (ut2d .eq. 1)
call bellc(l"half",0,0)
c$ endif
c$ if(uariz .eq. 1)
call echoplx('off')
c$ endif
c$ if(nos .eq. 1)
call writew(fets(0,stdout),noshalf,1)
call writer(fets(0,stdout))
if (debug .ne. 0) then
call fprintf(debugfd, '^stty - half duplex.\n')
endif
c$ endif
duplex = halfdup
else
call displa(' stty - invalid duplex ',value)
call abtp("nd")
endif
c
c is it setting parity?
c
else if (mode .eq. 'parity') then
if (value .eq. nopar .or. value .eq. evepar .or.
+ value .eq. oddpar .or. value .eq. mrkpar .or.
+ value .eq. spcpar) then
parity = value
c$ if (nos .eq. 1)
if (debug .ne. 0) then
call fprintf(debugfd, '^stty - parity switch.\n')
endif
if (parity .eq. nopar) then
call writew(fets(0,stdout),nosnone,1)
call writer(fets(0,stdout))
else if (parity .eq. evepar) then
call writew(fets(0,stdout),noseven,1)
call writer(fets(0,stdout))
else if (parity .eq. oddpar) then
call writew(fets(0,stdout),nosodd,1)
call writer(fets(0,stdout))
else if (parity .eq. mrkpar) then
call writew(fets(0,stdout),noszero,1)
call writer(fets(0,stdout))
else if (parity .eq. spcpar) then
call writew(fets(0,stdout),noszero,1)
call writer(fets(0,stdout))
endif
c$ endif
else
call displa(' stty - invalid parity ',value)
call abtp("nd")
endif
c
c is it setting binary (no translation) i/o?
c
else if (mode .eq. 'binary') then
binmode = (value .eq. on)
do 100 i = 1,maxfile
if (fmode(i) .ne. closed) then
if (ctdev(i)) then
if (binmode) then
fets(0,i) = or(fets(0,i),cioodd)
else
fets(0,i) = and(fets(0,i),.not.cioodd)
endif
endif
endif
100 continue
c$ if(nos .eq. 1)
if (binmode) then
call writew(fets(0,stdout),nositm, 5)
call writer(fets(0,stdout))
if (debug .ne. 0) then
call fprintf(debugfd, '^stty - binary.\n')
endif
else
call writew(fets(0,stdout),nosttm, 2)
call writer(fets(0,stdout))
if (debug .ne. 0) then
call fprintf(debugfd, '^stty - normal.\n')
endif
endif
c$ endif
c
c is it setting transparent (raw) i/o?
c
else if (mode .eq. 'raw') then
if (value .eq. 0) then
rawmode = .false.
else
rawmode = .true.
endif
else
call displa(' stty - invalid mode ',bool(mode))
call abtp("nd")
endif
return
end
integer function gtty(mode)
ccc gtty - get a tty mode.
c
*call kermcom
character*(*) mode
c
c is it duplex they're looking for?
c
if (mode .eq. 'duplex') then
gtty = duplex
c
c is it parity they're looking for?
c
else if (mode .eq. 'parity') then
gtty = parity
else
call displa(' gtty - invalid mode ',bool(mode))
call abtp("nd")
endif
return
end
subroutine as2dpc(astr,dstr)
ccc as2dpc - translate an ascii string buffer to dpc char string.
c
c ascii string is terminated by a zero byte.
c
c
*call kermcom
boolean astr(*)
character dstr*(*)
integer clen
c
c
i = 1
clen = len(dstr)
dstr = ' '
10 if (astr(i) .ne. 0 .and. i .le. clen) then
if (astr(i) .gt. 127) then
call movech(dpctbl(blank),9,dstr,i - 1,1)
else
call movech(dpctbl(astr(i)),9,dstr,i - 1,1)
endif
i = i + 1
go to 10
endif
c
return
end
integer function asc(dpch)
ccc asc - convert a dpc character to lower case ascii.
c
c
*call kermcom
character*1 dpch
c
c
asc = lascii(ichar(dpch))
c
return
end
subroutine dpc2as(dstr,astr,nwords)
c
c translate string of display code characters to uppercase ascii.
c string is nwords characters (words) long.
c
c
*call kermcom
character*(*) dstr
boolean astr(nwords)
c
c
do 1 i=1,nwords
astr(i) = uascii((ichar(dstr(i:i))))
1 continue
c
c set ascii end-of-string-buffer
c
astr(nwords+1) = 0
c
return
end
integer function ctoi(astr)
ccc ctoi - convert character buffer to integer.
c
c ctoi converts the number using base 10 as a default.
c a suffix of h will convert using base 16 and a suffix
c of o will convert using base 8. default suffix is
c d.
c
*call kermcom
parameter (dig0=48, dig7=55, dig9=57, biga=65, bigb=66, bigd=68)
parameter (bigf=70, bigh=72, bigo=79, leta=97, letb=98, letd=100)
parameter (letf=102, leth=104, leto=111)
integer astr(*)
base = 0
ptr = 0
c
c find last valid digit
c
10 ptr = ptr + 1
if (astr(ptr) .ne. 0) go to 10
ptr = ptr - 1
if (astr(ptr) .eq. leto .or. astr(ptr) .eq. bigo .or.
+ astr(ptr) .eq. letb .or. astr(ptr) .eq. bigb .or.
+ astr(ptr) .eq. leth .or. astr(ptr) .eq. bigh) then
eod = ptr - 1
else
eod = ptr
ptr = ptr + 1
endif
c
c try to figure out the base
c
if (astr(ptr) .eq. 0) then
base = 10
else if (astr(ptr) .eq. leto .or. astr(ptr) .eq. bigo .or.
+ astr(ptr) .eq. letb .or. astr(ptr) .eq. bigb) then
base = 8
else if (astr(ptr) .eq. leth .or. astr(ptr) .eq. bigh) then
base = 16
endif
c
c if didn't find a base
c
if (base .eq. 0) then
call fprintf(stdout,'ctoi - invalid base @c\n',astr(ptr),0,0,0)
ctoi = 0
return
endif
c
c add up the digits
c
total = 0
isneg = 1
do 100 i = 1,eod
ch = astr(i)
if (ch .eq. minus) then
isneg = -1
go to 100
endif
if (base .eq. 10) then
if (ch .lt. dig0 .or. ch .gt. dig9) then
call fprintf(stdout,'ctoi - invalid decimal digit @c\n',
+ ch,0,0,0)
ctoi = 0
return
else
ch = ch - dig0
endif
else if (base .eq. 8) then
if (ch .lt. dig0 .or. ch .gt. dig7) then
call fprintf(stdout,'ctoi - invalid octal digit @c\n',
+ ch,0,0,0)
ctoi = 0
return
else
ch = ch - dig0
endif
else if (base .eq. 16) then
if (ch .ge. dig0 .and. ch .le. dig9) then
ch = ch - dig0
else if (ch .ge. leta .and. ch .le. letf) then
ch = 10 + ch - leta
else if (ch .ge. biga .and. ch .le. bigf) then
ch = 10 + ch - biga
else
call fprintf(stdout,'ctoi - invalid hex digit @c\n',
+ ch,0,0,0)
ctoi = 0
return
endif
endif
total = total*base + ch
100 continue
ctoi = total * isneg
return
end
integer function itos(int,str,minwid)
ccc itos - convert an integer to string format.
c
*call kermcom
integer str(*)
width = 0
if (int .lt. 0) then
width = 1
str(width) = asc('-')
endif
val = iabs(int)
ascii0 = asc('0')
10 width = width + 1
str(width) = mod(val,10) + ascii0
val = val / 10
if (val .ne. 0) go to 10
str(width+1) = 0
c
c now reverse the digits
c
iptr = 1
endptr = width
if (str(iptr) .eq. asc('-')) iptr = iptr + 1
20 if (iptr .lt. endptr) then
tch = str(iptr)
str(iptr) = str(endptr)
str(endptr) = tch
iptr = iptr + 1
endptr = endptr - 1
go to 20
endif
itos = width
return
end
subroutine getemsg(strng)
ccc getemsg - get an error message string for the current error.
c
*call kermcom
integer direc(8,2)
integer packnam(9,0:6)
data direc / 115, 101, 110, 100, 4*0,
c s e n d
+ 114, 101, 99, 101, 105, 118, 101, 0 /
c r e c e i v e
data packnam / 85, 78, 75, 78, 79, 87, 78, 2*0,
c u n k n o w n
+ 73, 110, 105, 116, 5*0,
c i n i t
+ 70, 105, 108, 101, 110, 97, 109, 101, 0,
c f i l e n a m e
+ 68, 97, 116, 97, 5*0,
c d a t a
+ 69, 79, 70, 6*0,
c e o f
+ 66, 114, 101, 97, 107, 4*0,
c b r e a k
+ 83, 101, 114, 118, 101, 114, 3*0 /
c s e r v e r
if ((abortyp.and.initerr) .ne. 0) then
ptyp = 1
else if ((abortyp.and.filerr) .ne. 0) then
ptyp = 2
else if ((abortyp.and.dataerr) .ne. 0) then
ptyp = 3
else if ((abortyp.and.eoferr) .ne. 0) then
ptyp = 4
else if ((abortyp.and.brkerr) .ne. 0) then
ptyp = 5
else if ((abortyp.and.srvcmd) .ne. 0) then
ptyp = 6
else
ptyp = 0
endif
dtyp = shift(abortyp.and.o"300",-6)
if ((abortyp.and.toomany) .ne. 0) then
call sprintf(strng,'^cannot @s @s packet',direc(1,
+ dtyp),packnam(1,ptyp),0,0)
else if ((abortyp.and.invalid) .ne. 0) then
call sprintf(strng,
+ '^received an invalid packet while trying to @s @s packet',
+ direc(1,dtyp),packnam(1,ptyp),0,0)
else if ((abortyp.and.seqerr) .ne. 0) then
call sprintf(strng,
+ '^packet sequence error while trying to @s @s packet',
+ direc(1,dtyp),packnam(1,ptyp),0,0)
else if ((abortyp.and.lclfile) .ne. 0) then
call sprintf(strng,'^file is already local',0,0,0,0)
else if ((abortyp.and.notlcl) .ne. 0) then
call sprintf(strng,'^file is not local',0,0,0,0)
else if ((abortyp.and.invfn) .ne. 0) then
call sprintf(strng,'^invalid filename',0,0,0,0)
else if ((abortyp.and.srvcmd) .ne. 0) then
call sprintf(strng,'^unimplemented server command',0,0,0,0)
endif
return
end
integer function creat(fn)
ccc creat - open a file for writing packet data to.
c
c creat will try to create a file to write to. if it
c already exists, then it will fail.
c
*call kermcom
character*10 filenam
c
c get the dpc version of the filename
c
call as2dpc(fn,filenam)
call filchk(filenam)
creat = fopen(filenam,create)
return
end
subroutine getnow(mm,dd,yy,hr,min,sec)
ccc get the current date and time.
c
*call kermcom
character*10 date, time, string
string = date()
offset = ichar('0')
c$ if (ut2d .eq. 1)
dd = (ichar(string(2:2))-offset)*10 + ichar(string(3:3))-offset
mm = -1
if (string(5:7) .eq. 'jan') then
mm = 1
else if (string(5:7) .eq. 'feb') then
mm = 2
else if (string(5:7) .eq. 'mar') then
mm = 3
else if (string(5:7) .eq. 'apr') then
mm = 4
else if (string(5:7) .eq. 'may') then
mm = 5
else if (string(5:7) .eq. 'jun') then
mm = 6
else if (string(5:7) .eq. 'jul') then
mm = 7
else if (string(5:7) .eq. 'aug') then
mm = 8
else if (string(5:7) .eq. 'sep') then
mm = 9
else if (string(5:7) .eq. 'oct') then
mm = 10
else if (string(5:7) .eq. 'nov') then
mm = 11
else if (string(5:7) .eq. 'dec') then
mm = 12
endif
yy = (ichar(string(9:9))-offset)*10 + ichar(string(10:10))-offset
c$ endif
c$ if (nos .eq. 1)
yy = (ichar(string(2:2))-offset)*10 + ichar(string(3:3))-offset
mm = (ichar(string(5:5))-offset)*10 + ichar(string(6:6))-offset
dd = (ichar(string(8:8))-offset)*10 + ichar(string(9:9))-offset
c$ endif
c$ if (nosbe .eq. 1)
dd = (ichar(string(5:5))-offset)*10 + ichar(string(6:6))-offset
mm = (ichar(string(2:2))-offset)*10 + ichar(string(3:3))-offset
yy = (ichar(string(8:8))-offset)*10 + ichar(string(9:9))-offset
c$ endif
yy = yy + 1900
string = time()
hr = (ichar(string(2:2))-offset)*10 + ichar(string(3:3))-offset
min = (ichar(string(5:5))-offset)*10 + ichar(string(6:6))-offset
sec = (ichar(string(8:8))-offset)*10 + ichar(string(9:9))-offset
return
end
subroutine filchk(fn)
ccc filchk - check and fix filename validity.
c
c check validity of filename. invalid characters are dropped
c and the filename is truncated at 7 characters. if there
c is still not a valid filename (all characters were bad) then
c use file kermdat.
c
*call kermcom
boolean ch
character *(*) fn
integer ptr,length
c
ptr = 0
length = len(fn)
do 2 i=1,7
1 ptr = ptr + 1
if (ptr .gt. length) go to 3
ch = ichar(fn(ptr:ptr))
if (ch .lt. 1 .or. ch .gt. 36) go to 1
fn(i:i)=fn(ptr:ptr)
2 continue
i = 8
c
3 if (length .gt. 7) then
do 4 j=i,length
fn(j:j) = ' '
4 continue
endif
c
c use our magic file if no valid characters in the file name.
c this can happen as some micros allow things like '&' for
c a file name. note that nos allows a digit in the first
c character of an lfn while scope and nos/be do not.
c
c$ if(ut2d .eq. 1 .or. nosbe .eq. 1 .or. scope .eq. 1)
if(ichar(fn(1:1)) .lt. 1 .or. ichar(fn(1:1)) .gt. 26)
+ fn = 'kermdat'
c$ else
if(ichar(fn(1:1)) .lt. 1 .or. ichar(fn(1:1)) .gt. 36)
+ fn = 'kermdat'
c$ endif
return
end
subroutine rdparam(pdata)
ccc rdparam - get the packet parameters from the other kermit.
c
*call kermcom
boolean pdata(*)
integer params(11)
equivalence (params,spksiz)
c
c define ctl and unchar statement functions
c
ctl(ascch) = ascch .xor. o"100"
unchar(ascch) = ascch - blank
c
c cycle through the list of parameters until the end-of-list
c is found (a 0 byte).
c
i = 1
10 if (pdata(i) .ne. 0) then
c
c is it the pad character?
c
if (i .eq. 4) then
params(i) = ctl(pdata(i))
if (params(i) .eq. 0) params(i) = null
c
c is it the quote character?
c
else if (i .eq. 6) then
params(i) = pdata(i)
else
if (unchar(pdata(i)) .ne. 0) then
params(i) = unchar(pdata(i))
endif
endif
i = i + 1
go to 10
endif
return
end
subroutine remove(fn)
ccc remove - remove a file from the local file list.
c
*call kermcom
boolean fn(*)
character*10 lfn
c
c quit if nothing useful in the file name array.
c
if(fn(1) .eq. 0) return
c
c convert the file name to display code.
c
call as2dpc(fn,lfn)
c
c get rid of the file.
c
call retfile(lfn)
return
end
subroutine strcpy(s1,s2)
ccc strcpy - copy one ascii string to another
c
*call kermcom
boolean s1(*),s2(*)
i1 = 1
10 s2(i1) = s1(i1)
if (s1(i1) .ne. 0) then
i1 = i1 + 1
go to 10
endif
return
end
integer function slen(str)
ccc slen - return the length of a zero terminated ascii string buffer.
c
*call kermcom
boolean str(*)
i = 0
10 if (str(i+1) .ne. 0) then
i = i + 1
go to 10
endif
slen = i
return
end
integer function sndpar(pdata)
ccc sndpar - set up parameters to send to other kermit.
c
*call kermcom
boolean pdata(*)
c
c define ctl and tochar statement functions
c
ctl(ascch) = ascch .xor. o"100"
tochar(ascch) = ascch + blank
c
c send what we want
c
pdata(1) = tochar(packsiz)
pdata(2) = tochar(timeout)
pdata(3) = tochar(npad)
pdata(4) = ctl(padch)
pdata(5) = tochar(eolch)
pdata(6) = quotech
pdata(7) = 0
c
c return length of how many things we want to set
c
sndpar = 6
c
c other values are set by default to not operate
c
return
end
subroutine sleep(seconds)
cc sleep - use periodic recall to delay things.
c
c entry seconds = integer number of seconds to sleep.
c
c exit indicated number of seconds has elapsed.
c
*call kermcom
do 100 i=1,seconds
call delay(1000)
100 continue
return
end
subroutine delay(msec)
cc delay - delay for a few milliseconds.
c
c entry msec = delay time in milliseconds.
c
c exit time has elapsed.
c
c notes works for scope, ut2d, and nos/be systems. nos users must
c change the computation to account for the difference
c in data returned by rtime macro.
c
*call kermcom
c
c use real time clock to control delay period.
c
call rtime(rtcl)
rtcl = and(rtcl,compl(mask(24)))
10 call rtime(rtcl1)
rtcl1 = and(rtcl1,compl(mask(24)))
c
c convert from seconds/4096 to milliseconds.
c
if((rtcl1-rtcl)/4.096 .gt. msec) return
c
c sleep for 100 milliseconds.
c
call recall(0)
go to 10
end
subroutine echoplx(ecmode)
*** echoplx - set echoplex mode for 2550 front end.
*
* depends on u of arizona modifications to cci, plus a u of
* arizona pp routine 'uui'. this subroutine is only called
* from stty if uariz is defined.
*
* entry ecmode = 'on' or 'off' to enable or disable echoplex.
*
* exit uui called to change echoplex mode.
*call kermcom
c
c don't compile if not university of arizona
c
c$ if (uariz .eq. 1)
boolean echofnc, echooff, echoon, uuiwd
character*(3) ecmode
parameter (echofnc=o"10",echooff=0,echoon=1)
if(ecmode .eq. 'on') then
uuiwd = or(shift(echoon,12),echofnc)
elseif(ecmode .eq. 'off') then
uuiwd = or(shift(echooff,12),echofnc)
else
call remark(' kermit - invalid echoplex option.')
call abtp("nd")
endif
call mtr(l"uui","rcl",locf(uuiwd))
* nudge 2550 into processing the reconfiguration message
* sent by the uui call, so echo gets fully reset, even if
* next kermit operation is a read, not a write.
call putc(null,stdout)
call fflush(stdout)
c$ endif
return
end
integer function getrec(fd,wsa,wsal,eofflag)
cc getrec - get a record from a file.
c
c nread = getrec(fd,wsa,wsal,eofflag)
c
c entry fd = file descriptor.
c wsal = length of wsa.
c
c exit wsa contains data record.
c nread = number of words actually placed in wsa
c eofflag = .true. if eof hit (iff nread .eq. 0).
c
c notes performs display to ascii conversion if needed.
*call kermcom
parameter (intrcom = 42, asc128 = 22, asc256 = 23)
parameter (first = 1, in = 2, out = 3, limit = 4, intwd = 5)
boolean status, wsa(wsal)
logical eofflag
eofflag = .false.
c
c start read if possible, and determine disk character set
c if not in raw data mode.
c
1 if(.not. ctdev(fd) .and. and(fets(0,fd),o"1") .eq. o"1") then
if(fets(in,fd) .eq. fets(out,fd) .and.
+ and(fets(0,fd),o"20") .eq. 0) then
call read(fets(0,fd))
if(.not. rawmode) then
cset = xscs(fets(0,fd))
if(cset .eq. 0) go to 1
if (cset .eq. -1) then
dskcset = dsknos8
c$ if (ut2d .eq. 1)
c must set nos bit for screwy coded read routines
fets(first,fd) = fets(first,fd)
+ .or.shift(1,nosbit)
c$ endif
elseif(cset .eq. -2) then
dskcset = dskut8
c$ if (ut2d .eq. 1)
c must clear nos bit for screwy coded read routines
fets(first,fd) = and(fets(first,fd),
+ .not.shift(1,nosbit))
c$ endif
endif
if(cset .lt. 0) then
c$ if (ut2d .eq. 1)
c these are needed for strange coded read routines.
fets(first,fd) = fets(first,fd).or.shift(1,asciiio)
c$ endif
else
dskcset = dskdpc
c$ if (ut2d .eq. 1)
fets(first,fd) = and(fets(first,fd),
+ .not.shift(1,asciiio))
c$ endif
endif
endif
endif
endif
c
c process terminal devices.
c
if(ctdev(fd)) then
c$ if (ut2d .eq. 1) then
fets(first,fd) = or(fets(first,fd),shift(1,asciiio))
c$ else
fets(first,fd) = or(fets(first,fd),shift(1,intrcom))
fets(intwd,fd) = shift(1,asc128)
if(binmode .or. rawmode) fets(intwd,fd) = shift(1,asc256)
c$ endif
c$ if (nos .eq. 1)
c$ if (noslvl .ge. 602)
c
c wait for input checking for timeout on read
c
if (binmode .or. rawmode) then
nosdlay = stimout * 1000
else
nosdlay = rdelay
endif
do 10 irdl = 1, nosdlay, 24
if (nosctab().ne.0) goto 11
call noswait
10 continue
if (binmode .or. rawmode) then
call remark(' kermit - read timeout....')
endif
c$ else
if (rdelay .gt. 0) call delay(rdelay)
c$ endif
11 continue
c$ else
if (rdelay .gt. 0) call delay(rdelay)
c$ endif
call readc(fets(0,fd),wsa,wsal,status)
if(status .eq. 0) then
nread = wsal
elseif(status .lt. 0) then
c$ if (nos .eq. 1)
nread = 0
c
c give poor user another prompt
c
if ((.not. rawmode) .and. (.not. binmode)) then
call memstat
call fprintf(stdout,'^kermit-170>',0,0,0,0)
call fflush(stdout)
call writer(fets(0,stdout))
call read(fets(0,fd))
endif
goto 1
c$ else
nread = 0
eofflag = .true.
c$ endif
else
nread = status - locf(wsa)
fets(0,fd) = or(and(fets(0,fd),shift(mask(44),2)),ciord)
if(nread .le. 0) go to 1
endif
c$ if (nos .eq. 1)
if (nread .gt. 0) call conbuff(wsa, nread, eofflag, status)
c$ endif
getrec = nread
if(nread .gt. 0) getrec = findeol(wsa,nread,.not. binmode)
else
c
c process mass storage (disk) files.
c
if(rawmode) then
call readw(fets(0,fd),wsa,wsal,status)
elseif((dskcset.and.dskasci) .ne. 0) then
call readc(fets(0,fd),wsa,wsal,status)
else
call readc(fets(0,fd),wsa(wsal / 2 + 1),wsal / 2, status)
if(status .ge. 0) then
call edl(wsa,wsa(wsal / 2 + 1),wsal / 2,status)
endif
endif
c
c process mass storage (disk) file status return.
c
if(status .eq. 0) then
getrec = findeol(wsa,wsal,.not. rawmode)
elseif(status .gt. 0) then
getrec = findeol(wsa,status - locf(wsa),.not. rawmode)
fets(0,fd) = or(and(fets(0,fd),shift(mask(44),2)),ciord)
if(getrec .le. 0) go to 1
elseif(status .eq. -1) then
getrec = 0
fets(0,fd) = or(and(fets(0,fd),shift(mask(44),2)),ciord)
c$ if (ut2d .eq. 1) then
eofflag = .true.
c$ else
go to 1
c$ endif
else
getrec = 0
eofflag = .true.
endif
endif
return
end
integer function findeol(wsa,wsal,addnel)
cc findeol - find eol byte in working buffer.
c
c len = findeol(wsa,wsal,addnel)
c
c entry wsa = line image.
c wsal = length of wsa.
c addnel = .true. if a nel should be stuffed in buffer.
c
c exit len = length of data line in words.
*call kermcom
boolean wsa(wsal)
logical addnel
c
c if the line length is zero, return zero length.
c
if(wsal .le. 0) then
findeol = 0
return
endif
c
c find eol, and stick nel in if needed.
c
do 10 i = 1, wsal
if((and(wsa(i),o"7777") .eq. 0) .or.
+ (and(wsa(i),o"7777") .eq. nel)) then
if(addnel .and. (dskcset.ne.dskut8)) wsa(i) = or(wsa(i),nel)
findeol = i
return
endif
10 continue
if(addnel) wsa(wsal) = or(and(wsa(wsal),mask(48)),nel)
findeol = wsal
return
end
subroutine edl(ascbuf,dpcbuf,dpcbufl,status)
cc edl - expand display code line.
c
c call edl(ascbuf,dpcbuf,dpcbufl,status)
c
c entry dpcbuf = display code line image.
c dpcbufl = dimensioned size of dpcbuf.
c status = readc status.
c
c exit ascbuf = ascii line.
c status = lwa + 1 of data converted, iff status was
c non-zero on entry to edl.
c
c notes edl must not be called with negative status values.
*call kermcom
boolean ascbuf(*), dpcbuf(dpcbufl), dpcch, status, tempdpc
c
c determine number of words in buffer (worst case).
c
wc = dpcbufl
if(status .gt. 0) wc = status - locf(dpcbuf)
if(wc .le. 0) then
status = locf(ascbuf)
return
endif
c
c now scan for zero byte.
c
do 10 i = 1, wc
if(and(dpcbuf(i),o"7777") .eq. 0) go to 1
10 continue
c
c no eol was found, so we force one in the last word.
c
i = wc
dpcbuf(i) = and(dpcbuf(i),mask(48))
c
c at this point, 'i' contains the position of the eol word.
c
1 eolwd = i
ascbuf(1) = 0
if(eolwd .eq. 1 .and. dpcbuf(eolwd) .eq. 0) return
if(eolwd .gt. 1 .and. dpcbuf(eolwd) .eq. 0 .and.
+ and(dpcbuf(eolwd - 1),o"77") .eq. 0) eolwd = eolwd - 1
c
c now we convert everything up to the eol word, but not the eol word
c itself, as we do not want to 'convert' the line terminator.
c
wc = 0
if(eolwd .gt. 1) then
call xsxt(dpcbuf,eolwd - 1,ascbuf,uascii)
wc = 2 * (eolwd - 1)
endif
c
c now convert the eol word. code can handle overlapping buffers.
c
wc = wc + 1
tempdpc = dpcbuf(eolwd)
ascbuf(wc) = 0
ascbuf(wc + 1) = 0
do 20 i = 0, 9
tempdpc = shift(tempdpc,6)
dpcch = and(tempdpc,o"77")
tempdpc = and(tempdpc,mask(54))
if(tempdpc .eq. 0 .and. dpcch .eq. 0) then
if(status .gt. 0) status = locf(ascbuf(wc + i / 5)) + 1
return
endif
ascbuf(wc + i / 5) = or(ascbuf(wc + i / 5),
+ shift(uascii(dpcch),60 - 12 * (mod(i,5) + 1)))
20 continue
if(status .gt. 0) status = locf(ascbuf(wc + 1)) + 1
return
end
ident makefet
entry makefet
sst
syscom b1
makefet title makefet - make a file environment table.
comment make a file environment table.
makefet space 4,10
** makefet - make a file environment table.
*
* call makefet(lfn,fet,fetl,ciobuf,ciobufl)
*
* entry (lfn) = is the character*7 file name.
* (fet) = an array to receive the fet.
* (fetl) = length of fet in words (minimum of 5).
* (ciobuf) = an array to be used as the cio buffer.
* (ciobufl) = the length of ciobuf.
*
* exit fet built.
makefet subr entry/exit
sb1 1 always
sa2 a1+b1
sb6 x2 (b6) = fet address
sa2 a2+b1
sa3 x2 (x3) = fet length
sa2 a2+b1
sx6 x2 (x6) = fwa of cio buffer
sa2 a2+b1
sa2 x2 (x2) = buffer length
ix7 x6+x2 (x7) = limit pointer
sa6 b6+2 set in and out
sa6 a6+b1
sa7 a6+b1 set limit
sx7 x3-5 (x7) = fet length - 5
sb7 x7
lx7 18
bx6 x6+x7 add (fet length - 5) to first
sa6 b6+b1 set first
mx7 0
makefet1 gt b7,b0,makefet2 if no more words to set
sa7 a7+b1
sb7 b7-b1
eq makefet1 loop till done
makefet2 sb7 b1 length of transfer
rj =xmfs> move lfn into fet
sa1 b6-b1
rj =xbtz> convert blanks to 00b
sx1 b1 add complete bit to lfn
bx6 x6+x1
sa6 a1
eq makefetx return
end
*if def,nosbe
ident cfe
entry cfe
syscom b1
cfe title cfe - check files existance.
comment check files existance.
cfe space 4,10
** cfe - check files existance.
*
* logical cfe, result
*
* result = cfe(lfn)
*
* entry (lfn) = is the character*7 file name.
*
* exit (result) = .true. if file exists.
* (result) = .false. otherwise.
cfe subr entry/exit
sb1 1 always
sb6 cfea
sb7 b1
rj =xmfs> move lfn into filinfo block
sa1 cfea
rj =xbtz> convert blanks to 00b
sx1 4 block length
lx1 12
bx6 x6+x1
sa6 a1
mx7 0 clear rest of block
sa7 a6+b1
sa7 a7+b1
sa7 a7+b1
sa7 a7+b1
filinfo cfea check on file
mx6 0 assume no file (.false.)
mx7 12
sa1 cfea+1
bx7 x7*x1 (x7) = device code if file exists, or 0
zr x7,cfex if no file
mx6 -1 set file found (.true.)
eq cfex return
cfea vfd 42/**,6/4,12/0 filinfo block
bssz 4
end
*endif
*if -def,nosbe
ident cfe
entry cfe
sst
syscom b1
cfe title cfe - check files existance.
comment check files existance.
cfe space 4,10
** cfe - check files existance.
*
* logical cfe, result
*
* result = cfe(lfn)
*
* entry (lfn) = is the character*7 file name.
*
* exit (result) = .true. if file exists.
* (result) = .false. otherwise.
cfe subr entry/exit
sb1 1 always
sb6 cfea
sb7 b1
rj =xmfs> move lfn into filinfo block
sa1 cfea
rj =xbtz> convert blanks to 00b
sx1 b1 set complete
bx6 x6+x1
sa6 a1
mx7 0 clear rest of block
sa7 a6+b1
sa7 a7+b1
sa7 a7+b1
sa7 a7+b1
status cfea check on file
mx6 0 assume no file (.false.)
mx7 11
lx7 12
sa1 cfea
bx7 x7*x1 (x7) = 0 if file doesn't exist
zr x7,cfex if no file
mx6 -1 set file found (.true.)
eq cfex return
cfea bssz 1 fake fet
end
*endif
subroutine conbuff (buf, wc, eofflag, status)
*call,kermcom
c$ if (nos .eq. 1)
boolean buf(1), nosbuf(maxwd)
logical eofflag, conbug
data conbug / .false. /
c check for special *eof* flag.
if (wc .eq. 1 .and. buf(1) .eq. shift(r"^<",48)) then
wc = 0
eofflag = .true.
return
endif
c copy the buffer first
savewc = wc
do 1 i = 1, wc
1 nosbuf(i) = buf(i)
if (debug .ne. 0 .and. conbug) then
call fprintf(debugfd, 'conbuff called.\n',0,0,0,0)
endif
ips = 0
ipw = 1
ops = 60
opw = 1
buf(opw) = 0
c
c now scan for zero byte.
c
do 2 i = 1, wc
if(and(nosbuf(i),o"7777") .eq. 0) go to 3
2 continue
c
c no eol was found, so we force one in the last word.
c
i = wc
nosbuf(i) = and(nosbuf(i),mask(48))
c
c at this point, 'i' contains the position of the eol word.
c
3 eolwd = i
if(eolwd .eq. 1 .and. nosbuf(eolwd) .eq. 0) return
c
c check for the famous 66-bit end-of-line!!!
c
if(eolwd .gt. 1 .and. nosbuf(eolwd) .eq. 0 .and.
+ and(nosbuf(eolwd - 1),o"77") .eq. 0) eolwd = eolwd - 1
c calculate the character position of the last *real* character!
do 4 j = 6, 54, 6
if ((compl(mask(60-j)) .and. nosbuf(eolwd)) .ne. 0) then
lps = 72 - j
goto 5
endif
4 continue
lps = 6
c
c now convert the characters!
c
5 nose = 0
lch = 0
if (debug .ne. 0 .and. conbug) then
call fprintf(debugfd,' conbuff - wc @d\n', wc,0,0,0)
call fprintf(debugfd,' conbuff - el @d\n', eolwd,0,0,0)
call fprintf(debugfd,' conbuff - ls @d\n', lps,0,0,0)
endif
10 ips = ips + 6
if (ips .eq. 66) then
ips = 6
ipw = ipw + 1
endif
if (debug .ne. 0 .and. conbug) then
call fprintf(debugfd,' conbuff - is @d\n', ips,0,0,0)
call fprintf(debugfd,' conbuff - iw @d\n', ipw,0,0,0)
endif
if (ipw .eq. eolwd .and. ips .ge. lps) then
if (.not.rawmode) then
ch = nel
lch = nel
goto 40
else
goto 50
endif
endif
ich = and(shift(nosbuf(ipw), ips), o"77")
if (debug .ne. 0 .and. conbug) then
call fprintf(debugfd,' conbuff - ich @d\n', ich,0,0,0)
endif
if (nose .eq. 0) then
if (ich .eq. r"@") then
nose = ich
else if (ich .eq. r"^") then
nose = ich
else if (ich .ge. r"a" .and. ich .le. r"z") then
if (.not.(binmode .or. rawmode)) then
ch = lascii(ich)
else
ch = uascii(ich)
endif
else
ch = uascii(ich)
endif
else if (nose .eq. r"^") then
nose = 0
if (ich .ge. r"a" .and. ich .le. r"z") then
ch = lascii(ich)
else if (ich .ge. r"0" .and. ich .le. r"4") then
ch = ich + o"140"
else if (ich .ge. r"5" .and. ich .le. r";") then
ch = ich - o"40"
if (ch .eq. 0) ch = nul
else
ch = nul
endif
else if (nose .eq. r"@") then
nose = 0
if (ich .eq. r"a") then
ch = lascii(r"@")
else if (ich .eq. r"b") then
ch = lascii(r"^")
else if (ich .eq. r"d") then
ch = lascii(r":")
else if (ich .eq. r"g") then
ch = o"140"
else if (ich .eq. r"h") then
ch = cr
else if (ich .eq. r"i") then
ch = lf
else
ch = nul
endif
endif
c
c process this character.
c
if (nose .ne. 0) then
goto 10
else if (ch .lt. 0) then
goto 10
else if (ch .eq. lf .and. .not. rawmode) then
goto 10
else if (ch .eq. cr .and. .not. rawmode) then
ch = nel
else if (ch .eq. nul .and. .not. rawmode) then
goto 10
endif
c
c really process the character.
c
40 if (debug .ne. 0 .and. conbug) then
call fprintf(debugfd,' conbuff - ich @d\n', ich,0,0,0)
call fprintf(debugfd,' conbuff - ch @d\n', ch,0,0,0)
call fprintf(debugfd,' conbuff - ch @c\n', ch,0,0,0)
endif
c
c put it in the buffer
c
if (ops .eq. 0) then
ops = 48
opw = opw + 1
buf(opw) = 0
else
ops = ops - 12
endif
buf(opw) = buf(opw) .or. shift(ch,ops)
if (lch .eq. 0) goto 10
c we are now done.
50 wc = opw
if (debug .ne. 0 .and. conbug) then
call fprintf(debugfd, ' conbuff exited.\n',0,0,0,0)
endif
c$ endif
return
end