program jtmodace
c Copyright (c) 1994 Glenn C. Everhart
c All Rights Reserved
c Master program to edit file attributes. This is one of two
c to be done, the one that works from command lines. The other is to be
c a fullscreen utility. It will edit both the EACF/HSM/DELU database and the
c file ACEs involved.
c Delete old ACE entry and add a new one and maintain isam data.
	integer*4 fgetfid
	external fgetfid
	integer*4 lgetfid
	external lgetfid
	integer*4 prvmsk(2)
	integer*4 ident(2),lnkid(2)
	integer*4 cmdlen,fcmsk,kios
	character*80 fidasc,keystr,dlnwrk
	character*80 wrkfnm,dvcnam,sdvc,sstr
	character*250 cmdlin,cmdini,wrest,aclac,sfil
	character*250 wwrest
	integer*4 ki4a(2)
	integer*4 mfid1,mfid2
	integer*2 mfid22(2)
	equivalence(mfid2,mfid22(1))
	character*8 cki4a,cconfw
	equivalence(cki4a,ki4a(1))
	integer*4 iios(2),iucbk(2),itrunc
	byte newace(256)
	character*256 cnewace
	equivalence(cnewace,newace(1))
	character*250 caclac
	equivalence(aclac,caclac)	
	logical*1 lucbk(8)
	character*16 fidavl
	character*4 hv(6)
	character*4 hd(9)
	logical istatus
	equivalence(iucbk(1),lucbk(1))
	integer*4 ifid(2),ifsz,ifcnmsk,kfid(2)
	character*8 cifid
	equivalence(ifid(1),cifid)
        integer*4 sys$assign,sys$dassgn
        external sys$assign,sys$dassgn
	integer*2 ufid(4)
	equivalence(ufid(1),kfid(1))
	character*12 bsace
	common/fffiii/lnkid,lnkfs
	common/ffiidd/ifid,ifsz
	integer*4 iwbuf(8)
	byte wbuf(32)
	character*32 cwbuf
	equivalence(wbuf(1),cwbuf,iwbuf)
	character*512 spncmd,spnwk
	character*256 oldstr,newstr
        Integer*4 lib$sys_trnlog,lib$get_foreign
        External lib$sys_trnlog,lib$get_foreign
	integer*4 sekey(2),auth(2)
	integer*4 fid(2),secinfo(2)
c Define our database info. Keep the info in a nice big ISAM file
c indexed by file ID.
	include '($dvidef)'
	include '($jpidef)'
	include '($acldef)'
	include '($acedef)'
	character*256 dbnam
	integer*4 iosb(2),il3(3,3),lib$set_symbol
	external lib$set_symbol
	character*36 nsoftl
	integer*2 il32(6,3)
	equivalence(il3(1,1),il32(1,1))
	character*256 wtxts
	structure /jtdb/
	 union
	  map
	  integer*4 ifid(2)	! file ID = isam index
	  character*24 itim	! 24 hour time freq.
c each character in itim represents 1 hour of the day.
c Chars:
c Y = access ok if other stuff checks out
c N = no access (except su list)
c U = no checks, let everything by if DEC security does ("unlimited")
c P = check privs only
c R = readonly access only by anyone
	  integer*4 maxprv(2)	! max priv mask
	  integer*4 chksum(2)	! integrity file checksum if nonzero
	  character*36 csoftl	! conditional softlink ACE part
				! 06,len,fid,dvcname
	  integer*4 pswd(2)	! hashed password on file (our hash!)
c note: a utility must build job logicals first that are of
c form eac$pw<hexfid> and value = hashed password (one way hash)
c so this can be compared ar runtime if pswd .ne. 0
c Thus we get file passwords. (ahhhhhh...)
	  integer*4 kflgs	! flags for file treatment
c flags:
c 1 = conditional softlink on acc fail
c 2 = system users may only read, not open for write
c 4 = move by copy (actually move type is handled in cmdfiles,not here.)
c 8 = move by zip
c
	integer*4 ifilsiz ! file length in blocks
	  character*1600 lists	! misc. stuff, all encoded in a string
c	to avoid wasting truly immense space.
c Strings formats used:
c S(file)	- filename of original file (makes display easier)
c U(userlist)	- list of usernames permitted access. Comma separated
c			and * = wildcard. Must test if username matches
c			any of these strings with match-wild
c V(userlist)	- list of forbidden users, comma separated
c K(ttylist)	- List of permitted terminals (check accpornam if lat)
c L(ttylist)	- List of forbidden terminals
c I(imagelist)	- List of permitted images
c J(imagelist)	- List of forbidden images
c B(userlist)	- List of superusers (backup users, generally)
c A(ace part after flags) - Part of file ACE to be used after flag part
c		(since flag pat is basically constant)
c Z(cmdname) - command to run in spawned image IF access fails
c
	  end map
	  map
	  character*1712 ch
	  end map
	 end union
	end structure
c jtdb is 21 + 400 + 4+3 = 425+3 longwords long max
	record /jtdb/dskrec
	character*128 fuldvcnm,fdvc2
	integer*4 ifnmsz,ialcls,lookhere
	character*32 wk1,wk2,wk3
	byte acehere(256)
	character*256 cacehere
	equivalence(acehere(1),cacehere)
c add stuff to let us log user commands
        integer*4 jpiitm(3,8)
        integer*2 jp2itm(6,8)
        equivalence(jpiitm(1,1),jp2itm(1,1))
	character*23 dtim
	character*32 unamb,ttyspb
	character*64 accpor
	integer*4 accporl,unaml,ttyspl
	integer*4  LIB$DATE_TIME
	external  LIB$DATE_TIME
	integer*4 iuic,iprv(2),ipid,lipid
	common/kiuic/iuic
	character*256 imgspb
	character*512 wrkarg
	integer*4 ccol
	common/jpijunk/ttyspb,ttyspl,imgspb,imgspl,unamb
     1  ,unaml,accpor,accporl
	integer*4 lib$spawn
	external lib$spawn
	integer*4 sys$getjpiw
	external sys$getjpiw
c We want to issue $getjpiw early on to get the username, so we can log
c who is issuing what commands. Some of this code is just copied from
c JTOPN so that we can access it. To prevent the log file from containing
c volume access password information we will search out such and 
c replace the password with junk; otherwise this log would be in all
c cases a security hazard. Basically the philosophy here is that a user
c needs to enter the security key every time; it is not displayed (and
c really isn't invertible by any way I know).
c Set up the getjpi list so we can find terminal name etc.
c for the victim process. Get the image name so we can check for a
c special exempted image.
	jp2itm(1,1)=32
        jp2itm(2,1)=JPI$_TT_PHYDEVNAM
        jpiitm(2,1)=%loc(ttyspb)
        jpiitm(3,1)=%loc(ttyspl)
        jp2itm(1,2)=256
        jp2itm(2,2)=JPI$_IMAGNAME
        jpiitm(2,2)=%loc(imgspb)
        jpiitm(3,2)=%loc(imgspl)
        jp2itm(1,3)=32
        jp2itm(2,3)=JPI$_USERNAME
        jpiitm(2,3)=%loc(unamb)
        jpiitm(3,3)=%loc(unaml)
c        jpiitm(1,4)=0
	jp2itm(1,4)=64
c	jp2itm(2,4)=JPI$TT_ACCPORNAM
	jp2itm(2,4)=813
        jpiitm(2,4)=%LOC(ACCPOR)
        jpiitm(3,4)=%LOC(ACCPORL)
c        jpiitm(1,5)=0
	jp2itm(1,5)=4
	jp2itm(2,5)=JPI$_UIC
        jpiitm(2,5)=%loc(iuic)
	jpiitm(3,5)=%loc(lluic)
        jp2itm(1,6)=8
        jp2itm(2,6)=JPI$_CURPRIV
        jpiitm(2,6)=%loc(iprv(1))
        jpiitm(3,6)=%loc(lprvs)
c Get the PID too, since the accounting database will have that to help
c tell which user this was.
c	jpiitm(1,7)=0
        jp2itm(1,7)=4
	jp2itm(2,7)=JPI$_PID
        jpiitm(2,7)=%loc(ipid)
        jpiitm(3,7)=%loc(lipid)
        jpiitm(1,8)=0
        jpiitm(2,8)=0
        jpiitm(3,8)=0
	kkpid=0
	kk=sys$getjpiw(%val(1),kkpid,,jpiitm,iosb,,)
	unaml=ivlen(unamb,16)
	ttyspl=ivlen(ttyspb,32)
	imgspl=ivlen(imgspb,256)
	accporl=ivlen(accpor,64)
c Now we know the user name, accport, UIC, privs, etc. and thus can
c create a log file. We'll want to record all this stuff since if
c the person's been impersonating someone else, we want what info we
c can get.
c exempt jtauthmaint from tests by the driver etc since they share data.
	call exempt
	lookhere=1 ! use lookhere to set/clr use-daemon flag
	il32(1,1)=128
	il32(2,1)=dvi$_fulldevnam
	il3(2,1)=%loc(fuldvcnm)
	il3(3,1)=%loc(ifnmsz)
	il32(1,2)=4
	il32(2,2)=dvi$_alloclass
	il3(2,2)=%loc(ialcls)
	il3(3,2)=0
	il3(1,3)=0
	il3(2,3)=0
	il3(3,3)=0
c ifcnmsk is functions we want done with this file.
	izip=0
	aclac=' '
	izoo=0
	icmpr=0
	ichn=0
	iucmpr=0
	ilink=0
	ifcnmsk=0
	itrunc=0
	imov=0
	iovwt=0
c initially replacement ACE is zero.
	newace(1)=0
c Pass in the desired ACE as hex
	ii=lib$get_foreign(cmdlin,'Dev:file or (n,s,v)>',cmdlen,)
	cmdlin=cmdlin(1:cmdlen)
c test termination. Q or ctrlZ will just exit...
	if(ichar(cmdlin(1:1)).le.32)goto 9999
	if(cmdlin(1:1).eq.'q'.or.cmdlin(1:1).eq.'Q')goto 9999
c find where the filename is if we can....
c If there are multiple spaces skip to the last
c (This way, the natural tendency to ignore extra whitespace is
c  supported rather than making the program seem flaky.)
	wrkfnm=cmdlin
c Terminate filespec stuff with \ char; then add hex.
	idlm=index(cmdlin,'\')
	wrest='I+'
	if(idlm.ne.0)wrkfnm=wrkfnm(:idlm-1)
	if(idlm.ne.0)wrest=cmdlin(idlm+1:)
c
c have to get file open to get its' file ID...
c Only open for read...we don't want to mess up any info in it.
	lwf=ilen(wrkfnm)
c If 1st char is ( then this must be file id
	if(cmdlin(1:1) .eq. '(') then
	llwf=lwf-1
	read(cmdlin(2:llwf),1020)iif1,iif2,iif3
1020	format(3i)
c Third FID word has the top part of file number; isolate this.
	iii=iif3/256
	iif3=mod(iif3,256)
	iif1=iif1+65536*iii
	ufid(1)=iif1
	ufid(2)=iif2
	ufid(3)=iif3
	ufid(4)=0
	ifid(1)=kfid(1)
	ifid(2)=kfid(2)
c use default device name for our channel
c Translate it here, however, since RMS won't be used.
	kkk=lib$sys_trnlog('SYS$DISK',icolon,dvcnam)
	if(.not.kkk) goto 9999
	dvcnam=dvcnam(:icolon)
	goto 8009
	end if
c use useropen to get file ID
	open(unit=3,file=wrkfnm(:lwf),err=9898,status='old',
     1  useropen=fgetfid,readonly)
	close(unit=3)
c get channel to ichn
	icolon=index(wrkfnm,':')
	dvcnam=wrkfnm(:icolon)
c assign, then tear down, channel to the device
8009	continue
c Form database name now.
c Use $getdvi to get device name, alloc class, unit no., nodename
c Form jtd$db:op<node><dvcnm><unit>.gdb or
c      jtd$db:op<alloclass><dvcnm><unit>.gdb
c
	call sys$getdviw(%val(1),,dvcnam,il3,iosb,,,)
c Now full device name should have node$devicenameunit: or
c $alloclass$devnmunit: so test which.
	fuldvcnm=fuldvcnm(:ifnmsz)
	lfdvc2=ifnmsz
	fdvc2=fuldvcnm
	if(fuldvcnm(1:1).eq.'_')fuldvcnm=fuldvcnm(2:)
c now either $alloclass$ or node$ there.
	icol=index(fuldvcnm,':')
	if(icol.ne.0)fuldvcnm=fuldvcnm(:icol-1)
	lfdv=ivlen(fuldvcnm,128)
c ought to have a unit within 7 digits ok
	do 31 n31=1,7
	mm=lfdv-n31+1
	if(fuldvcnm(mm:mm).gt.'9')goto 33
31	continue
33	CONTINUE
	mm=mm+1
	read(fuldvcnm(mm:lfdv),34)iunitno
34	format(i)
	fuldvcnm=fuldvcnm(:mm-1)
c isolate device name part too.
	if(ialcls.eq.0)then
c need to get nodename
	ldol=index(fuldvcnm,'$')
	wk1=fuldvcnm(:ldol-1)
	fuldvcnm=fuldvcnm(ldol+1:)
	lfdv=ivlen(fuldvcnm,128)
	wk2=fuldvcnm(:lfdv)
	lwk1=ivlen(wk1,32)
	lwk2=ivlen(wk2,32)
	write(dbnam,100)wk1(:lwk1),wk2(:lwk2),iunitno
100	format('JTD$DB:OP',a,a,i3.3,'.GDB')
	end if
	if(ialcls.ne.0)then
c skip $n$
	ldol=index(fuldvcnm,'$')
	fuldvcnm=fuldvcnm(ldol+1:)
	ldol=index(fuldvcnm,'$')
	fuldvcnm=fuldvcnm(ldol+1:)
	lfdv=ivlen(fuldvcnm,128)
	wk2=fuldvcnm(:lfdv)
	lwk2=ivlen(wk2,32)
	write(dbnam,101)ialcls,wk2(:lwk2),iunitno
101	format('JTD$DB:OP',i3.3,a,i3.3,'.GDB')
	end if
	ldbn=ivlen(dbnam,256)
c Handle logging what is requested
c exempt %syms
c Create or open the log file so we can append a record to it.
c Note we don't bother with this if the operation is just a %syms
c operation since modifications all do this first and may not in
c fact attempt any writing. Other %operation calls could be worth
c recording, though.
	if(index(wrest,'%SYMS').eq.0)then
	open(unit=14,file='gcy$cm:accctlrecs.log',recl=1024,
     1  form='formatted',carriagecontrol='list',access='append',
     2  status='unknown',shared,err=6659)
c Get the user-visible fid
	kfid(1)=ifid(1)
	kfid(2)=ifid(2)
	inum=ufid(1)
	iseq=ufid(2)
	irvn=ufid(3).and.255
	iii=ufid(3)/256
	inum=inum+(iii*65536)
c First report what device and file was accessed (or access attempted)
	write(14,6660)fdvc2(1:lfdvc2),wrkfnm(1:lwf),inum,iseq,irvn
6660	Format(' **** File security access on device:',a,/,1x,
     1  ' Filespec given:',a,/,1x,' Fid:(',i6,',',i6,',',i6,')')
c Now give the username, UIC, where he is, what privs he has. The image
c is of course this one so no need to give that.
	write(14,6658)unamb(1:unaml),iuic,iprv,ttyspb(1:ttyspl),
     1  accpor(1:accporl),ipid
6658	Format(' User:',a,' UIC:',z8.8,' Hex priv vector:',2z8.8,/,1x,
     1  'Terminal:',a,' Accport:',a,' PID:',z8.8)
c Now we need to show what the user was trying to do with this file 
c so we can have the record for later. Also we need to know what time
c it is and log that.
c Get the date & time
	kkk=lib$date_time(dtim)
	wwrest=wrest
	lwwr=ivlen(wwrest,250)
c strip off between 'K<' and '>'
	ii=index(wwrest,'K<')
        if(ii.ne.0)then
        ij=index(wwrest(ii+2:),'>')
        ij=ij+ii+1
        lpwd=ij-ii+1-3
	iij=ij-1
c Erase password. In fact, just leave one character so we don't
c even reveal the length. We will only reveal one exists if it does.
	wwrest=wrest(1:ii+1) // '?' // wrest(ij:lwwr)
        end if
	lwwr=ivlen(wwrest,250)
	write(14,6661)dtim,wwrest(1:lwwr)
6661	Format(' Date of this access:',a,' Access string:',x,1x,a)
c That's it; the whole access info is now available, so close the log
c file.
6659	continue
	close(unit=14)
	endif
c end logging
        OPEN(UNIT=2,FILE=DBNAM(1:ldbn),ORGANIZATION='INDEXED'
     1  ,ACCESS='KEYED',SHARED,
     2  RECORDTYPE='VARIABLE',RECL=1712,FORM='FORMATTED',
     3  BLOCKSIZE=16384,buffercount=3,
     4  KEY=(1:8:CHARACTER),STATUS='UNKNOWN',ERR=9999)
8	continue
c Handle global report or msintenance jobs signalled by commands in wrest
	if(index(wrest,'%PURGE').NE.0)THEN
c use copy of full dvc name to open a channel to the device
c fdvc2(:lfdvc2) is name
	iii=sys$assign(fdvc2(:lfdvc2),lchnl,,,)
	iii=iii.and.1
	if(iii.eq.0.or.lchnl.eq.0)then
	call unexempt
	call exit(8)
	endif
c now lchnl is dsk channel
6310	continue
	read(unit=2,fmt=6300,end=6309,err=6309)dskrec.ch
c fid in cifid now. equiv'd to ifid.
	iexist=1
	call filacc(lchnl,dskrec.ifid,iexist)
	if (iexist.eq.0)delete(unit=2)
	goto 6310
6309	continue
c exit will deassign dsk chnl.
	call unexempt
	call exit
	end if
	if(index(wrest,'%LIST').NE.0)THEN
c use copy of full dvc name to open a channel to the device
c fdvc2(:lfdvc2) is name
	spnwk=dbnam(:ldbn) // '_LIST'
	iii=ldbn+5
	open(unit=14,file=spnwk(:iii),recl=512,form='formatted',
     1  status='new',carriagecontrol='list',err=6379)
c Set the symbol JTA_LISTFILE to the filename of the list file so
c any front ends can easily get it to work with further.
	CALL LIB$SET_SYMBOL('JTA_LISTFILE',spnwk(:iii))
6316	continue
	read(unit=2,fmt=6300,end=6379,err=6379)dskrec.ch
c fid in cifid now. equiv'd to ifid.
	kfid(1)=dskrec.ifid(1)
	kfid(2)=dskrec.ifid(2)
c build a file ID string for the output.
c first get filename string out of data.
	spnwk=' '
	nfn=index(dskrec.lists,'S(')
	if(nfn.gt.0)then
	spnwk=dskrec.lists(nfn+2:nfn+512)
	nrp=index(spnwk,')')
	if(nrp.gt.0)spnwk=spnwk(:nrp-1)
	end if
	lspncmd=ivlen(spnwk,256)
	inum=ufid(1)
	iseq=ufid(2)
	irvn=ufid(3).and.255
	iii=ufid(3)/256
	inum=inum+(iii*65536)
	write(spncmd,6317)spnwk(:lspncmd),inum,iseq,irvn
6317	format(a,' (',i8.8,',',i6.6,',',i3.3,')')
	lspncmd=ivlen(spncmd,512)
	write(14,6318)spncmd(:lspncmd)
6318	format(a)
	goto 6316
6379	continue
c exit will deassign dsk chnl.
	close(unit=14)
	call unexempt
	call exit
	end if
	if(index(wrest,'%SUMM').NE.0)THEN
c use copy of full dvc name to open a channel to the device
c fdvc2(:lfdvc2) is name
	spnwk=dbnam(:ldbn) // '_SUMM'
	iii=ldbn+5
	nsiztotl = 0
	open(unit=14,file=spnwk(:iii),recl=512,form='formatted',
     1  status='new',carriagecontrol='list',err=6479)
c Set the symbol JTA_SUMMFILE to the filename of the list file so
c any front ends can easily get it to work with further.
	CALL LIB$SET_SYMBOL('JTA_SUMMFILE',spnwk(:iii))
6416	continue
	read(unit=2,fmt=6300,end=6479,err=6479)dskrec.ch
c fid in cifid now. equiv'd to ifid.
	kfid(1)=dskrec.ifid(1)
	kfid(2)=dskrec.ifid(2)
c build a file ID string for the output.
c first get filename string out of data.
	spnwk=' '
	nfn=index(dskrec.lists,'S(')
	if(nfn.gt.0)then
	spnwk=dskrec.lists(nfn+2:nfn+512)
	nrp=index(spnwk,')')
	if(nrp.gt.0)spnwk=spnwk(:nrp-1)
	end if
	lspncmd=ivlen(spnwk,256)
	inum=ufid(1)
	iseq=ufid(2)
	irvn=ufid(3).and.255
	iii=ufid(3)/256
	inum=inum+(iii*65536)
	kiik=dskrec.ifilsiz
	nsiztotl = nsiztotl + kiik
	write(spncmd,6417)spnwk(:lspncmd),inum,iseq,irvn,kiik
6417	format(a,' (',i8.8,',',i6.6,',',i3.3,') ',i10)
	lspncmd=ivlen(spncmd,512)
	write(14,6318)spncmd(:lspncmd)
	goto 6416
6479	continue
c exit will deassign dsk chnl.
	close(unit=14)
c symbol JTA_SUMMLEN will contain total files space needed to inswap
c everything.
	write(spncmd,6728)nsiztotl
6728	format(i11.11)
c generate DCL symbol for total size of outswapped files
c (note one should purge first...)
	call lib$set_symbol('JTA_SUMMLEN',SPNCMD(:11))
	call unexempt
	call exit
	end if
c Add a %REPORT literal
	if(index(wrest,'%REPORT').NE.0)THEN
c use copy of full dvc name to open a channel to the device
c fdvc2(:lfdvc2) is name
	spnwk=dbnam(:ldbn) // '_REPORT'
	iii=ldbn+5
	open(unit=14,file=spnwk(:iii),recl=512,form='formatted',
     1  status='new',carriagecontrol='list',err=6779)
c Set the symbol JTA_RPTFILE to the filename of the report file so
c any front ends can easily get it to work with further.
	CALL LIB$SET_SYMBOL('JTA_RPTFILE',spnwk(:iii))
6716	continue
	read(unit=2,fmt=6300,end=6779,err=6779)dskrec.ch
c fid in cifid now. equiv'd to ifid.
	kfid(1)=dskrec.ifid(1)
	kfid(2)=dskrec.ifid(2)
c build a file ID string for the output.
c first get filename string out of data.
	spnwk=' '
	nfn=index(dskrec.lists,'S(')
	if(nfn.gt.0)then
	spnwk=dskrec.lists(nfn+2:nfn+512)
	nrp=index(spnwk,')')
	if(nrp.gt.0)spnwk=spnwk(:nrp-1)
	end if
	lspncmd=ivlen(spnwk,256)
	inum=ufid(1)
	iseq=ufid(2)
	irvn=ufid(3).and.255
	iii=ufid(3)/256
	inum=inum+(iii*65536)
	write(spncmd,6717)spnwk(:lspncmd),inum,iseq,irvn
6717	format(a,' (',i8.8,',',i6.6,',',i3.3,')')
	lspncmd=ivlen(spncmd,512)
c Emit the header line
	write(14,6648)
6648	format(' ****************** Next File *********************')
	write(14,6718)spncmd(:lspncmd)
6718	format(a)
c Now we have the filename and FID of the file. Make up a report that will
c show basically everything about the file whose record we have just
c read. Do so for the whole database.
c In doing this, emit the info like we do in the symbol dump
c &&&&&&&&&&&&&&
c Emit the time access mask
	write(14,6601)dskrec.itim
6601	format(' Time access control string:',a)
c Emit the max privs to open mask
	write(14,6602)DSKREC.MAXPRV
6602	format(' Max privilege to open file mask (hex):',2z8.8)
c Emit the security checksum for the file
	write(14,6603)DSKREC.CHKSUM
6603	format(' Security checksum stored for file (0 if none):'2Z8.8)
c Emit the hashed file password if any
	write(14,6604)DSKREC.PSWD
6604	format(' File password hash (0 if none): ',2z8.8)
c Now separate off the other subfields so we can handle them too.
c find out if string exists in wrks
c
c symbols defined:
c  JTA_ZFID	- FILE ID, HEX
C  JTA_ITIM	- Permitted usage by time (24 chars)
C  JTA_MXPV	- Max privs (hex mask)
C  JTA_CKSM	- Checksum (hex mask) (0 means none)
C  JTA_PSWD	- File password hash (0 means no password)
c  JTA_USRS	- OK USERS
C  JTA_FUSR	- FORBIDDEN USERS
C  JTA_TTYS	- OK TTYS
C  JTA_FTTY	- FORBIDDEN TTYS
C  JTA_IMGS	- OK IMAGES
C  JTA_FIMG	- FORBIDDEN IMAGES
C  JTA_BKPU	- BACKUP USER LIST
C  JTA_FNAM	- FILENAME AS STORED
C  JTA_CSLK	- conditional softlink dvc:file
c  JTA_INSP	- inspectme flag - space or I+
c  JTA_BPRI	- baseprio set - space or base prio
c  JTA_RPRV	- Replacement privs vector (hex)
c  JTA_IDNT	- Identifier hex value. Note only one is reported even though
c			the system will allow more. Space if none.
c  JTA_SURW 	- superuser (backup) read-only access. 'R/O' or 'R/W'
c  JTA_ZCMD	- Command to exec on access fail if any
c
	iw=index(dskrec.lists,'U(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
c Emit the permitted user list
	write(14,6605)wtxts(:lwtxts)
6605	format(' Permitted user list:',a)
	end if
	iw=index(dskrec.lists,'V(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
c Emit the forbidden user list
	write(14,6606)wtxts(:lwtxts)
6606	FORMAT(' Forbidden user list:',a)
c Now separate off the other subfields so we can handle them too.
c find out if string exists in wrks
c
c symbols defined:
c  JTA_ZFID	- FILE ID, HEX
C  JTA_ITIM	- Permitted usage by time (24 chars)
C  JTA_MXPV	- Max privs (hex mask)
C  JTA_CKSM	- Checksum (hex mask) (0 means none)
C  JTA_PSWD	- File password hash (0 means no password)
c  JTA_USRS	- OK USERS
C  JTA_FUSR	- FORBIDDEN USERS
C  JTA_TTYS	- OK TTYS
C  JTA_FTTY	- FORBIDDEN TTYS
C  JTA_IMGS	- OK IMAGES
C  JTA_FIMG	- FORBIDDEN IMAGES
C  JTA_BKPU	- BACKUP USER LIST
C  JTA_FNAM	- FILENAME AS STORED
C  JTA_CSLK	- conditional softlink dvc:file
c  JTA_INSP	- inspectme flag - space or I+
c  JTA_BPRI	- baseprio set - space or base prio
c  JTA_RPRV	- Replacement privs vector (hex)
c  JTA_IDNT	- Identifier hex value. Note only one is reported even though
c			the system will allow more. Space if none.
c  JTA_SURW 	- superuser (backup) read-only access. 'R/O' or 'R/W'
c  JTA_ZCMD	- Command to exec on access fail if any
c
	iw=index(dskrec.lists,'Z(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
C show what command is to be run if access fails
	write(14,6607)wtxts(:lwtxts)
6607	format(' Command file to run if access fails:',a)
	end if
c external validate command
	iw=index(dskrec.lists,'X(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
c Show command file to validate access if doing that
	write(14,6608)wtxts(:lwtxts)
6608	format(' Command file to run to check access:',a)
	end if
	iw=index(dskrec.lists,'K(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
c show permitted terminal locations
	write(14,6609)wtxts(:lwtxts)
6609	format(' Permitted terminal/accport list:',a)
	end if
	iw=index(dskrec.lists,'L(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
c Show forbidden terminal list
	write(14,6610)wtxts(:lwtxts)
6610	format(' Forbidden terminal/accport list:',a)
	end if
	iw=index(dskrec.lists,'I(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
c show permitted images list
	write(14,6611)wtxts(:lwtxts)
6611	format(' Permitted image list:',a)
	end if
c check for superuser readonly flag
	n=dskrec.kflgs
	n=n.and.2
c  JTA_SURW 	- superuser (backup) read-only access. 'R/O' or 'R/W'
c Show superuser readonly/readwrite flag
	if (n.eq.0)write(14,6612)
6612	format(' Backup user allowed R/W access to this file')
	if (n.ne.0)write(14,6613)
6613	format(' Backup user allowed R/O access to this file')
	iw=index(dskrec.lists,'J(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
c show forbidden images
	write(14,6614)wtxts(:lwtxts)
6614	format(' Images forbidden to access file:',a)
	end if
	iw=index(dskrec.lists,'B(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
c show backup usr list
	write(14,6615)wtxts(:lwtxts)
6615	format(' Backup user list:',a)
	end if
	iw=index(dskrec.lists,'D(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
	write(14,6616)wtxts(:lwtxts)
6616	format(' Softlink to this file if acc denied:',a)
	end if
	iw=index(dskrec.lists,'R(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
c Show normal softlink if any
	write(14,6617)wtxts(:lwtxts)
6617	format(' File softlinked (r/w) to:',a)
	end if
	iw=index(dskrec.lists,'A(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
c go over ACE to reconstruct flags
c Decode security relevant ones only this time.
	n6721=1
6721	continue
	icode=ichar(wtxts(n6721:n6721))
	if(icode.le.0.or.icode.gt.6)goto 6722
	if(icode.eq.1)then
	n6721=n6721+1
	write(14,6618)
6618	format(' File is set to be inspected by Safety server')
	goto 6721
	end if
	if(icode.eq.3)then
	write(sdvc,6723)ichar(wtxts(n6721+1:n6721+1))
6723	format(i2.2)
	write(14,6619)sdvc(1:2)
6619	format(' Process accessing file has base prio set to ',a)
	n6721=n6721+6
	goto 6721
	end if
	if(icode.eq.4)then
	cki4a=wtxts(n6721+1:n6721+9)
	write(sdvc,6305)ki4a
	write(14,6620)sdvc(:16)
6620	format(' Priv mask when this file is open becomes:',a)
	n6721=n6721+17
	goto 6721
	end if
	if(icode.eq.5)then
	cki4a=wtxts(n6721+1:n6721+9)
	write(sdvc,6305)ki4a
	write(14,6621)sdvc(:16)
6621	format(' When file opens process gains ident value (hex):',a)
	n6721=n6721+17
	goto 6721
	end if
6722	continue
	end if
	end if
	goto 6716
6779	continue
c exit will deassign dsk chnl.
	close(unit=14)
	call unexempt
	call exit
	end if
c Add command %GBLEDIT to do a global edit of strings in the database
	if(index(wrest,'%GBLEDIT').NE.0)THEN
c First get the string to remove
c Form should be %gbledit `oldstring`newstring`
c where if 'oldstring' is null we skip out, and if 'newstring' is
c null we just delete oldstring. Should make it pretty easy to pull
c a username out when there's need.
	iconfrm=index(wrest,'%GBLEDITCON')
	iii=index(wrest,'%GBLEDIT')
	spnwk=wrest(iii+8:)
9316	continue
	if(ivlen(spnwk,512).lt.4)goto 7379
	if(spnwk(1:1).eq.' ')then
	spnwk=spnwk(2:)
	goto 9316
	endif
c spnwk(1:1) is now the character
	wk1=spnwk(1:1)
c wk1 is the delimiter now
	spnwk=spnwk(2:)
c strip off the strings
	idlm=index(spnwk,wk1(1:1))
	if(idlm.le.1)goto 7379
	oldstr=spnwk(1:idlm-1)
	spnwk=spnwk(idlm+1:)
	inewstr=0
	newstr=' '
	idlm=index(spnwk,wk1(1:1))
	if(idlm.le.0)goto 7379
	if(idlm.gt.1)then
	newstr=spnwk(1:idlm-1)
	inewstr=1
	endif
	lnew=0
	lold=ivlen(oldstr,256)
	if(inewstr.ne.0)lnew=ivlen(newstr,256)
7316	continue
	read(unit=2,fmt=6300,end=7379,err=7379)dskrec.ch
c fid in cifid now. equiv'd to ifid.
c now work on dskrec.lists to build an edited one.
	imodd=0
	nrep=0
8316	continue
c find tyhe old string and replace with the new, if a new exists.
	iloc=index(dskrec.lists,oldstr(:lold))
	if(iloc.gt.0)then
	IF(ICONFRM.GT.0)then
	llsts=ivlen(dskrec.lists,1600)
	write(6,8516)dskrec.lists(:llsts)
8516	format(' Old:',a,/,'$Confirm replace [Y/N/A/X]')
	read(5,8517)cconfw
8517	format(a)
c y=yes, n=no, a=all, x=exit
	if(cconfw(1:1).eq.'Y'.or.cconfw(1:1).eq.'y')goto 8518
	if(cconfw(1:1).eq.'N'.or.cconfw(1:1).eq.'n')goto 7316
	if(cconfw(1:1).eq.'A'.or.cconfw(1:1).eq.'a')iconfrm=0	
	if(cconfw(1:1).eq.'X'.or.cconfw(1:1).eq.'x')goto 7379
8518	continue
	endif
	  if(iloc.eq.1)then
	    dskrec.lists=dskrec.lists(lold+1:)
	    if(lnew.gt.0)dskrec.lists=newstr(:lnew) // dskrec.lists
	  endif
	  if(iloc.gt.1)then
	    if(lnew.eq.0)then
	      dskrec.lists=dskrec.lists(1:iloc-1) //
     1  dskrec.lists(iloc+lold:)
	    endif
	    if(lnew.gt.0)then
	      dskrec.lists=dskrec.lists(1:iloc-1) //
     1  newstr(:lnew) //
     1  dskrec.lists(iloc+lold:)
	    endif
	  endif
	imodd=1
	nrep=nrep+1
	if(nrep.lt.200)goto 8316
	endif
	if(imodd.ne.0)rewrite(unit=2)
	goto 7316
7379	continue
	call unexempt
	call exit
	end if
	if(index(wrest,'%REGEN').NE.0)THEN
c use copy of full dvc name to open a channel to the device
c fdvc2(:lfdvc2) is name
	iii=sys$assign(fdvc2(:lfdvc2),lchnl,,,)
	iii=iii.and.1
	if(iii.eq.0.or.lchnl.eq.0)then
	call unexempt
	call exit(8)
	endif
c now lchnl is dsk channel
6510	continue
	read(unit=2,fmt=6300,end=6319,err=6319)dskrec.ch
c fid in cifid now. equiv'd to ifid.
	iexist=1
c read the ACL on the file for our ACE and if it is not present,
c write out a warning to console and opcom and fix things up.
c ace format:
c .byte length
c .byte ace$c_info
c .word %xE01
c .long 1
c .ascii /GCEV/
c contents of our record in A(...) brackets
	call redacl(dskrec.ifid,acehere,lchnl)
c if ACE is found then leave it alone...all's well.
	if (cacehere(9:12) .ne. 'GCEV')then
	spnwk=' '
	nfn=index(dskrec.lists,'S(')
	if(nfn.gt.0)then
	spnwk=dskrec.lists(nfn+1:nfn+512)
	nrp=index(spnwk,')')
	if(nrp.gt.0)spnwk=spnwk(:nrp)
	end if
	lspncmd=ivlen(spnwk,512)
	write(spncmd,6511)dskrec.ifid,spnwk(:lspncmd)
6511	format(' %EACF-W-File ID ',2z8,1x,a,
     1  ' ACE deleted. Replacing.')
	lspnc=ivlen(spncmd,256)
	write(6,6512)spncmd(:lspnc)
6512	format(a)
	call oprmsg(spncmd(:lspnc))
c now try 'n' fix things up.
	bsace=char(1) // char(ace$c_info) // char(1) // char (14)
     1  // char(1) // char(0) // char(0) // char(0) // 'GCEV'
c 12 char prefix
	noldac=index(dskrec.lists,'A(')
	if (noldac .gt. 0)then
	spncmd=dskrec.lists(noldac+2:noldac+259)
	nrp=index(spncmd,')')
	if (nrp.gt.0)then
	spncmd=spncmd(:nrp-1)
	lena=nrp-1+12
	bsace(1:1)=char(lena)
	spnwk=bsace(1:12) // spncmd(1:nrp-1)
c wk1 string now has ACE desired.
	cacehere=spnwk(1:lena)//char(0)//char(0)
c zero the rest of the ACE so we only enter ONE entry...
	nnrp=lena+1
	do 6514 nrp=nnrp,256
	acehere(nrp)=0
6514	continue
	call replent(dskrec.ifid,lchnl,acehere)
c this should replace the ACE entry for us, warning of any deletions.
	end if
	end if
	end if
	goto 6510
6319	continue
c exit will deassign dsk chnl.
	call unexempt
	call exit
	end if
c Get our data if possible
	igot=1
	kios=99
        read(unit=2,fmt=6300,keyeq=cifid,
     1  keyid=0,iostat=kios)DSKREC.ch
6300	format(a)
	if(kios.eq.0.or.kios.eq.67)goto 10
	if(kios.eq.52) then
c locked record...wait & retry
	xtim=4.0
	call lib$wait(xtim)
	goto 8
	end if
	igot=0
c default allow access in most fields for new records.
	dskrec.itim='YYYYYYYYYYYYYYYYYYYYYYYY'
	DSKREC.MAXPRV(1)=-536870913	!all privs except bypass
	DSKREC.MAXPRV(2)=-1
	DSKREC.CSOFTL=' '
	DSKREC.PSWD(1)=0
	DSKREC.PSWD(2)=0
	DSKREC.KFLGS=0
	DSKREC.LISTS='U(*)K(*)I(*)'
	dskrec.ifid(1)=ifid(1)
	dskrec.ifid(2)=ifid(2)
	llst=ivlen(dskrec.lists,1600)
	llst=llst+112
	write(2,6301)dskrec.ch(:llst)
        read(unit=2,fmt=6300,keyeq=cifid,
     1  keyid=0,iostat=kios)DSKREC.ch
	igot=1
10	continue
c Note: this program has a command-line interface so menu systems
c that have to call it can do so. Another version with a screen
c interface would be available as a user access editor...
c
c After \ the following can exist:
c
c DELETE - deletes record in database
c SYMS - generate dcl symbols
c SHOW - display the whole record
c K<key>  keystring
c I+	  inspectme tag
c Snn	  Base prio to nnnn (use S since B could appear in hex #)
c P<mask> Priv mask
c I<ident> Identifier
c M+	Move file tag (just tag...no more)
c H+ call proc to do a move
c &&  set "paranoid mode" open flags
c
c For the security version add commands as follows too:
c
c V<maxprivmask,hex> Max priv mask
c T<nnnnyyyyyyyyyyyynnnnnnnn> - time-value access permission
c U+<add-username-permitted>
c U-<sub-username-permitted>
c U*<repl-permitted-user-list>
c V+<add-forbidden-user>
c V-<sub-forbidden-user>
c V*<repl forbidden user list>
c K+<add permitted-termname>
c K-<sub-permitted-termname>
c K*<repl permitted termname>
c (note letter+, letter-, letter* pattern above...continue for all)
c L+-*<operate on forbidden termnames>
c Z+- - turn checksum on/off (on -> compute checksum)
c N+-*<image> - operate on permitted image list
c O+-*<forbidden-imagelist> - operate on forbidden imagelist
c Q+-*<superuserlist - operate on superuser list
c Y+-<password> - modify password on file
c W+-  Skip ace alteration if +, allow if -. Default allow.
c X+  eXpunge variable field stuff initially
c S+ - standalone, clear lookhere flag on ace so daemon not needed
c Z<command> - set command to exec on failure
c X<command> - external command, run to test access.
c
c need a way to enter conditional softlink fields and to extract
c ace fields. Also new records should by default allow all users,
c times, privs, images, terms.
c 
c H<dvc:file> - enter normal softlink
c H<> - zero normal softlink
c C<dvc:file> - enter conditional softlink for this file. (type 0)
c C<> - zero cond. softlink.
c R+ - su readonly
c R- - su not readonly
c No others for now...
c  call jtscr(sekey,secinfo,fid,auth)
c Now build the ACE variable stuff
	fid(1)=ifid(1)
	fid(2)=ifid(2)
	if(index(wrest,'%DELETE').ne.0)then
	if(igot.ne.0) delete(unit=2)
	close(unit=2)
	call unexempt
	call exit
	end if
c Allow SYMS call to just generate dcl symbols for various values
c found in the database. This will facilitate control via a dcl menu
c script to give a fullscreen interface.
	if(index(wrest,'%SYMS').ne.0)then
	if(igot.eq.0)then
	call unexempt
	call exit(4)
	end if
C Generate a bunch of dcl symbols so we can handle all this from inside
C a script.
	write(wtxts,6305)DSKREC.ifid
6305	format(2z8.8)
	call lib$set_symbol('JTA_ZFID',WTXTS(:16))
	CALL LIB$SET_SYMBOL('JTA_ITIM',DSKREC.ITIM)
	WRITE(WTXTS,6305)DSKREC.MAXPRV
	CALL LIB$SET_SYMBOL('JTA_MXPV',WTXTS(:16))
	WRITE(WTXTS,6305)DSKREC.CHKSUM
	CALL LIB$SET_SYMBOL('JTA_CKSM',WTXTS(:16))
	WRITE(WTXTS,6305)DSKREC.PSWD
	CALL LIB$SET_SYMBOL('JTA_PSWD',WTXTS(:16))
c Now separate off the other subfields so we can handle them too.
c find out if string exists in wrks
c
c symbols defined:
c  JTA_ZFID	- FILE ID, HEX
C  JTA_ITIM	- Permitted usage by time (24 chars)
C  JTA_MXPV	- Max privs (hex mask)
C  JTA_CKSM	- Checksum (hex mask) (0 means none)
C  JTA_PSWD	- File password hash (0 means no password)
c  JTA_USRS	- OK USERS
C  JTA_FUSR	- FORBIDDEN USERS
C  JTA_TTYS	- OK TTYS
C  JTA_FTTY	- FORBIDDEN TTYS
C  JTA_IMGS	- OK IMAGES
C  JTA_FIMG	- FORBIDDEN IMAGES
C  JTA_BKPU	- BACKUP USER LIST
C  JTA_FNAM	- FILENAME AS STORED
C  JTA_CSLK	- conditional softlink dvc:file
c  JTA_INSP	- inspectme flag - space or I+
c  JTA_BPRI	- baseprio set - space or base prio
c  JTA_RPRV	- Replacement privs vector (hex)
c  JTA_IDNT	- Identifier hex value. Note only one is reported even though
c			the system will allow more. Space if none.
c  JTA_SURW 	- superuser (backup) read-only access. 'R/O' or 'R/W'
c  JTA_ZCMD	- Command to exec on access fail if any
c
	iw=index(dskrec.lists,'U(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
	call lib$set_symbol('JTA_USRS',wtxts(:lwtxts))
	end if
	iw=index(dskrec.lists,'V(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
	call lib$set_symbol('JTA_FUSR',wtxts(:lwtxts))
	end if
	iw=index(dskrec.lists,'Z(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
	call lib$set_symbol('JTA_ZCMD',wtxts(:lwtxts))
	end if
c external validate command
	iw=index(dskrec.lists,'X(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
	call lib$set_symbol('JTA_XCMD',wtxts(:lwtxts))
	end if
	iw=index(dskrec.lists,'K(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
	call lib$set_symbol('JTA_TTYS',wtxts(:lwtxts))
	end if
	iw=index(dskrec.lists,'L(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
	call lib$set_symbol('JTA_FTTY',wtxts(:lwtxts))
	end if
	iw=index(dskrec.lists,'I(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
	call lib$set_symbol('JTA_IMGS',wtxts(:lwtxts))
	end if
c check for superuser readonly flag
	n=dskrec.kflgs
	n=n.and.2
c  JTA_SURW 	- superuser (backup) read-only access. 'R/O' or 'R/W'
	if (n.eq.0)call lib$set_symbol('JTA_SURW','R/W')
	if (n.ne.0)call lib$set_symbol('JTA_SURW','R/O')
	iw=index(dskrec.lists,'J(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
	call lib$set_symbol('JTA_FIMG',wtxts(:lwtxts))
	end if
	iw=index(dskrec.lists,'B(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
	call lib$set_symbol('JTA_BKPU',wtxts(:lwtxts))
	end if
	iw=index(dskrec.lists,'S(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
	call lib$set_symbol('JTA_FNAM',wtxts(:lwtxts))
	end if
	iw=index(dskrec.lists,'D(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
	call lib$set_symbol('JTA_CSLK',wtxts(:lwtxts))
	end if
	iw=index(dskrec.lists,'R(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
	call lib$set_symbol('JTA_NSLK',wtxts(:lwtxts))
	end if
	iw=index(dskrec.lists,'A(')
	if(iw.gt.0)then
	iwr=index(dskrec.lists(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wtxts=dskrec.lists(iw+2:iwr)
	lwtxts=iwr-iw-1
c go over ACE to reconstruct flags
c Decode security relevant ones only this time.
	n6321=1
	call lib$set_symbol('JTA_INSP',' ')
	call lib$set_symbol('JTA_BPRI',' ')
	call lib$set_symbol('JTA_RPRV',' ')
	call lib$set_symbol('JTA_IDNT',' ')
6321	continue
	icode=ichar(wtxts(n6321:n6321))
	if(icode.le.0.or.icode.gt.6)goto 6322
	if(icode.eq.1)then
	n6321=n6321+1
	call lib$set_symbol('JTA_INSP','I+')
	goto 6321
	end if
	if(icode.eq.3)then
	write(sdvc,6323)ichar(wtxts(n6321+1:n6321+1))
6323	format(i2.2)
	call lib$set_symbol('JTA_BPRI',sdvc(1:2))
	n6321=n6321+6
	goto 6321
	end if
	if(icode.eq.4)then
	cki4a=wtxts(n6321+1:n6321+9)
	write(sdvc,6305)ki4a
	call lib$set_symbol('JTA_RPRV',sdvc(:16))
	n6321=n6321+17
	goto 6321
	end if
	if(icode.eq.5)then
	cki4a=wtxts(n6321+1:n6321+9)
	write(sdvc,6305)ki4a
	call lib$set_symbol('JTA_IDNT',sdvc(:16))
	n6321=n6321+17
	goto 6321
	end if
6322	continue
c	call lib$set_symbol('JTA_PVRP',wtxts(:lwtxts))
	end if
	end if
c after syms call, just exit...no more
c Otherwise we might mess ace up.
	if(index(wrest,'%SYMS').ne.0)then
	call unexempt
	call exit
	endif
	if(index(wrest,'%SHOW').ne.0)then
	if(igot.eq.0)then
	write(6,130) wrkfnm(:lwf)
130	format(' No security record exists file ',a)
	call unexempt
	call exit
	end if
C Generate a bunch of dcl symbols so we can handle all this from inside
C a script.
	write(wtxts,6305)DSKREC.ifid
c6305	format(2z8.8)
	call lib$set_symbol('JTA_ZFID',WTXTS(:16))
	CALL LIB$SET_SYMBOL('JTA_ITIM',DSKREC.ITIM)
	WRITE(WTXTS,6305)DSKREC.MAXPRV
	CALL LIB$SET_SYMBOL('JTA_MXPV',WTXTS(:16))
	WRITE(WTXTS,6305)DSKREC.CHKSUM
	CALL LIB$SET_SYMBOL('JTA_CKSM',WTXTS(:16))
	WRITE(WTXTS,6305)DSKREC.PSWD
	CALL LIB$SET_SYMBOL('JTA_PSWD',WTXTS(:16))
	write(6,1301)wrkfnm(:lwf)
1301	format(' Security controls, file:',a)
	kfid(1)=dskrec.ifid(1)
	kfid(2)=dskrec.ifid(2)
	ifnm=ufid(1)+65536*mod(kfid(3),256)
	ifsq=ufid(2)
	ifrv=kfid(3).and.255
	write(6,1302)ifnm,ifsq,ifrv
1302	format(' File id:',i,',',i,',',i)
	write(6,1303)dskrec.itim
1303	format(' Time access permissions:',a)
	write(6,1304)dskrec.maxprv,dskrec.chksum
1304	format(' Max privs:',z8.8,1x,z8.8,'  Tamper xsums:',2z9)
	write(6,1305)
1305	format(' Lists key: S(filename)U(ok-users-list)V(bad-user-list)',
     1 /,' K(ok-tty-list)L(bad-tty-list)I(ok-image-list)',
     2 /,' J(bad-image-list)B(backup-user-list)A(ACE contents)')
	nlo=1
	nhi=100
c just do a crude dump for this utility. Fullscreen one should do
c better.
	do 1306 n=1,16
	write(6,1307)dskrec.lists(nlo:nhi)
1307	format(a)
	nlo=nlo+100
	nhi=nhi+100
1306	continue
	call unexempt
	call exit
	end if
	if(index(wrest,'S+').ne.0)lookhere=0
	if(index(wrest,'X+').ne.0)then
	dskrec.lists=' '
	dskrec.maxprv(1)=-1
	dskrec.maxprv(2)=-1
	dskrec.chksum(0)=0
	dskrec.chksum(2)=0
	dskrec.itim='YYYYYYYYYYYYYYYYYYYYYYYY'
	end if
	if(index(wrest,'R+').ne.0)then
c turn superuser readonly flag on
	n=dskrec.kflgs
	n=n.or.2
	dskrec.kflgs=n
	end if
	if(index(wrest,'R-').ne.0)then
c turn superuser readonly flag off
	n=dskrec.kflgs
	n=n.and.-3
	dskrec.kflgs=n
	end if
	if(index(wrest,'Y-<').gt.0)then
c disable file passwords
	dskrec.pswd(1)=0
	dskrec.pswd(2)=0
	end if
	if(index(wrest,'Y+<').gt.0)then
c enable file passwords
	ii=index(wrest,'Y+<')+3
	ij=index(wrest(ii:),'>')-1
	if(ij.gt.0)then
	ilj=ii+ij-1
c form a password hash
c and save in the indexed file.
	call getpv(wrest(ii:ilj),ij,dskrec.pswd(1),dskrec.pswd(2))
	end if
	end if
	ikey=0
	auth(1)=0
	auth(2)=0
	laclac=0
	if(index(wrest,'I+').gt.0)then
	aclac=char(1)
c inspectme code is just a byte 1
	laclac=1
	end if
c set movhsm flag but require M+ tag too.
	movhsm=0
	if(index(wrest,'H+').gt.0)movhsm=1
	if(index(wrest,'&&').gt.0)dskrec.kflgs=dskrec.kflgs.or.
     1  786432
	if(index(wrest,'&%').gt.0)dskrec.kflgs=dskrec.kflgs.or.
     1  131072
	if(index(wrest,'M+').gt.0)then
	laclac=laclac+1
	aclac(laclac:laclac)=char(2)
c Stick in a move flag in the record
	dskrec.kflgs=dskrec.kflgs .or. 4
c 'moveme' flag is a 2
	else
	movhsm=0
	end if
c Do file move if this was wanted
c filename is wrkfnm(:lwf)
	if(movhsm.ne.0)then
c get file size too...
c This comes out of our earlier useropen...just gets allocated
c size.
	dskrec.ifilsiz=ifsz
	write(spncmd,9865)wrkfnm(:lwf),ifid(1),ifid(2)
9865	format('$@GCY$CM:FILSAV ',a,1x,z8.8,1x,z8.8)
c        kkllst=ivlen(dskrec.lists,1600)
c        kkllst=kkllst+112
cc release the disk record so open is ok during move
c        if(igot.eq.1)rewrite(2,6301)dskrec.ch(:kkllst)
	if(igot.eq.1)delete(unit=2)
	lspncmd=ivlen(spncmd,512)
	kkk=lib$spawn(spncmd(:lspncmd),,,,,,istat)
c	kkllst=igot
c	igot=02
	if((istat.and.1).ne.0)igot=0
	if((istat.and.1).eq.0)then
c remove the "moveme" flag from the ACL if the move failed so we
c don't have things inconsistent.
c	igot=kkllst
c        if(igot.eq.1)read(unit=2,fmt=6300,keyeq=cifid,
c     1  keyid=0,iostat=kios)DSKREC.ch
	igot=2
	aclac(laclac:laclac)=char(0)
	laclac=laclac-1
	end if
	end if
c Others need auth key so try and get that if it's here.
	ii=index(wrest,'K<')
	if(ii.ne.0)then
	ij=index(wrest(ii+2:),'>')
	ij=ij+ii+1
	lpwd=ij-ii+1-3
c Transform string to binary
	call getpv(wrest(ii+2:ij-1),lpwd,ilo,ihi)
	sekey(1)=ilo
	sekey(2)=ihi
	ikey=1
	end if
	ii=index(wrest,'P<')
	if(ii.ne.0)then
	if(ikey.eq.0)goto 18
	ij=index(wrest(ii+2:),'>')
	ij=ij+ii+1
	lpwd=ij-ii+1-3
	ii=ii+2
	ij=ij-1
c Read the priv mask in hex
	read(wrest(ii:ij),16,err=18)secinfo
16	format(2z8.8)
	call jtscr(sekey,secinfo,fid,auth)
	laclac=laclac+1
	ij=laclac+16
c Fill in priv info and auth info
	iwbuf(1)=secinfo(1)
	iwbuf(2)=secinfo(2)
	iwbuf(3)=auth(1)
	iwbuf(4)=auth(2)
	aclac(laclac:ij)=char(4) // cwbuf(1:16)
	laclac=laclac+16
18	continue
	end if
17	continue
	ii=index(wrest,'I<')
	ik=ii
	if(ii.ne.0)then
	if(ikey.eq.0)goto 28
	ij=index(wrest(ii+2:),'>')
	ij=ij+ii+1
	ijj=ij
	lpwd=ij-ii+1-3
	ii=ii+2
	ij=ij-1
c Read the identifier in hex
	read(wrest(ii:ij),16,err=28)secinfo
	call jtscr(sekey,secinfo,fid,auth)
	laclac=laclac+1
	iijj=ij
	ij=laclac+16
c Fill in ident info and auth info
	iwbuf(1)=secinfo(1)
	iwbuf(2)=secinfo(2)
	iwbuf(3)=auth(1)
	iwbuf(4)=auth(2)
	aclac(laclac:ij)=char(5) // cwbuf(1:16)
	laclac=laclac+16
	if(ik.le.1.or.iijj.gt.200)goto 28
c Go back and look for more identifiers if we find any, escaping when
c we find no more identifier tags. This allows us to have multiple
c identifiers associated with a file.
c
c Do so by chopping out the part of the string with the identifier we
c just decoded and try to find more.
	wrest=wrest(:ik-1) // wrest(iijj+2:)
	goto 17
28	continue
	end if
	ii=index(wrest,'#S')
	if(ii.ne.0)then
	if(ikey.ne.0)then
c #Snn base prio alter. 2 digit prio.
	read(wrest(ii+2:ii+3),29,err=30)ibs
29	format(i2)
	if(ibs.lt.0.or.ibs.gt.31)goto 30
	ibs=31-ibs
c internal base prio is represented in reverse, hi binary # ==> low prio
	secinfo(1)=ibs
	secinfo(2)=0
	call jtscr(sekey,secinfo,fid,auth)
	iwbuf(1)=auth(1)
	iwbuf(2)=auth(2)
	laclac=laclac+1
	aclac(laclac:laclac+5)=char(3) // char(ibs) // cwbuf(1:4)
	laclac=laclac+5
30	continue
	end if
	end if
c process max priv mask
	ivmsk=index(wrest,'V<')
	if(ivmsk.gt.0)then
	read(wrest(ivmsk+2:),630,err=631)i1,i2
630	format(2z8.8)
	dskrec.maxprv(1)=i1
	dskrec.maxprv(2)=i2
631	continue
	end if
c process time dependent check field
	iltim=index(wrest,'T<')
	if(iltim.ne.0)then
	i2=index(wrest(iltim+2:),'>')
	i2=i2+1+iltim
	if((i2-iltim-2).ge.24)then
	dskrec.itim=wrest(iltim+2:iltim+25)
	end if
	end if
c Handle list items
c All are processed similarly, so just handle them.
c
	call lprc(wrest,'U','U(',dskrec.lists)
	call lprc(wrest,'V','V(',dskrec.lists)
	call lprc(wrest,'K','K(',dskrec.lists)
	call lprc(wrest,'L','L(',dskrec.lists)
	call lprc(wrest,'N','I(',dskrec.lists)
	call lprc(wrest,'O','J(',dskrec.lists)
	call lprc(wrest,'Q','B(',dskrec.lists)
	if(index(wrest,'Z-').gt.0)then
c turn off checksum
	dskrec.chksum(1)=0
	dskrec.chksum(2)=0
	end if
	if(index(wrest,'Z+').gt.0)then
c compute checksum
	call filck(wrkfnm(:lwf),dskrec.chksum(1),dskrec.chksum(2))
	end if
c fill in filename
	iii=index(dskrec.lists,'S(')
	if(iii.gt.0)then
	iij=index(dskrec.lists(iii:),')')
	if(iij.gt.0)then
	iij=iij+iii+1-3
	dskrec.lists=dskrec.lists(:iii-1) // dskrec.lists(iij+2:)
	end if
	end if
	ldrl=ivlen(dskrec.lists,1600)
	dskrec.lists=dskrec.lists(:ldrl) // 'S(' // wrkfnm(:lwf) // ')'
c Proceed to add the conditional softlink if any.
c C<dvc:file> sets it up (easier than making user figure out the
c link). Save link in d(cond'l link) for display purposes.
ccccccccccccccccccccccccccccccccccccccccccccccc
	iltim=index(wrest,'C<')
	if(iltim.ne.0)then
	i2=index(wrest(iltim+2:),'>')
	i2=i2+iltim
c wrest(iltim+2:i2) is the file spec.
	if((i2-iltim-2).lt.4)then
	dskrec.csoftl=' '
c c<> removes the softlink.
	iii = -2
	dskrec.kflgs=dskrec.kflgs.and.iii
	end if
	if((i2-iltim-2).ge.4)then
c add the softlink after removing oldinfo about it
c	dskrec.itim=wrest(iltim+2:iltim+25)
	iii=index(dskrec.lists,'D(')
	if(iii.gt.0)then
	iij=index(dskrec.lists(iii:),')')
	if(iij.gt.0)then
	iij=iij+iii+1
c get rid of any old cond'l link info
	dskrec.lists=dskrec.lists(:iii) // dskrec.lists(iij+1:)
	end if
	end if
	ldrl=ivlen(dskrec.lists,1600)
	dskrec.lists=dskrec.lists(:ldrl) // 'D(' // 
     1   wrest(iltim+2:i2) // ')'
c now generate the softlink info in the record
c compute the file device and file ID.
	kft1=ifid(1)
	kft2=ifid(2)
	sfil=wrest(iltim+2:i2)
	open(unit=3,file=wrest(iltim+2:i2),err=9766,status='old',
     1  useropen=fgetfid,readonly)
	close(unit=3)
	mfid1=ifid(1)
	mfid2=ifid(2)
	ifid(1)=kft1
	ifid(2)=kft2
c get channel to ichn
	icolon=index(sfil,':')
	sdvc=sfil(:icolon)
c assign, then tear down, channel to the device
c Form database name now.
c Use $getdvi to get device name, alloc class, unit no., nodename
c Form jtd$db:op<node><dvcnm><unit>.gdb or
c      jtd$db:op<alloclass><dvcnm><unit>.gdb
c
	kii=ivlen(sdvc,80)
	call sys$getdviw(%val(1),,sdvc,il3,iosb,,,)
c Now full device name should have node$devicenameunit: or
c $alloclass$devnmunit: so test which.
	fuldvcnm=fuldvcnm(:ifnmsz)
	write(sstr,6308)mfid1,mfid22(1)
6308	format(a4,a2)
	kln=ifnmsz+16+3+1
c jtdriver needs dvc name to be counted ascii
	write(dskrec.csoftl,6307,err=9766)char(6),char(kln),
     1  char(0),sstr(:6),char(ifnmsz),fuldvcnm(:ifnmsz)
	dskrec.kflgs=dskrec.kflgs.or.1
6307	format(3a1,a,a1,a)
9766	continue
	end if
	end if
ccccccccccccccccccccccccccccccccccccccccccc
ccccccccccccccccccccccccccccccccccccccccccccccc
	nstyp=0
	iltim=index(wrest,'#<')
	if(iltim.ne.0)then
	nstyp=1
	goto 9643
	endif
	nsoftl=' '
	iltim=index(wrest,'H<')
	if(iltim.ne.0)then
9643	continue
	i2=index(wrest(iltim+2:),'>')
	i2=i2+iltim
c wrest(iltim+2:i2) is the file spec.
	if((i2-iltim-2).lt.4)then
	nsoftl=' '
	iii = -2
	dskrec.kflgs=dskrec.kflgs.and.iii
	end if
	if((i2-iltim-2).ge.4)then
c add the softlink after removing oldinfo about it
c	dskrec.itim=wrest(iltim+2:iltim+25)
	iii=index(dskrec.lists,'R(')
	if(iii.gt.0)then
	iij=index(dskrec.lists(iii:),')')
	if(iij.gt.0)then
	iij=iij+iii+1
c get rid of any old cond'l link info
	dskrec.lists=dskrec.lists(:iii) // dskrec.lists(iij+1:)
	end if
	end if
	ldrl=ivlen(dskrec.lists,1600)
	dskrec.lists=dskrec.lists(:ldrl) // 'R(' // 
     1   wrest(iltim+2:i2) // ')'
	ldrll=ivlen(dskrec.lists,1600)
	if(nstyp.eq.1)dskrec.lists = dskrec.lists(:ldrll) // '<#>'
c now generate the softlink info in the record
c compute the file device and file ID.
	kft1=ifid(1)
	kft2=ifid(2)
	sfil=wrest(iltim+2:i2)
	open(unit=3,file=wrest(iltim+2:i2),err=9786,status='old',
     1  useropen=fgetfid,readonly)
9786	continue
	close(unit=3)
	mfid1=ifid(1)
	mfid2=ifid(2)
	ifid(1)=kft1
	ifid(2)=kft2
c get channel to ichn
	icolon=index(sfil,':')
	sdvc=sfil(:icolon)
c assign, then tear down, channel to the device
c Form database name now.
c Use $getdvi to get device name, alloc class, unit no., nodename
c Form jtd$db:op<node><dvcnm><unit>.gdb or
c      jtd$db:op<alloclass><dvcnm><unit>.gdb
c
	kii=ivlen(sdvc,80)
	call sys$getdviw(%val(1),,sdvc,il3,iosb,,,)
c Now full device name should have node$devicenameunit: or
c $alloclass$devnmunit: so test which.
	fuldvcnm=fuldvcnm(:ifnmsz)
	write(sstr,6308)mfid1,mfid22(1)
	kln=ifnmsz+6+3+1
c jtdriver needs dvc name to be counted ascii
	write(nsoftl,6307,err=9676)char(6),char(kln),
     1  char(nstyp),sstr(:6),char(ifnmsz),fuldvcnm(:ifnmsz)
9676	continue
	lnsoftl=ivlen(nsoftl,36)
	if(lnsoftl.gt.4)then
	  iii=laclac
	  laclac=laclac+lnsoftl
          if (iii.eq.0)aclac=nsoftl(1:lnsoftl)
	  if (iii.gt.0)aclac=aclac(1:iii) // nsoftl(1:lnsoftl)
	end if
	end if
	end if
ccccccccccccccccccccccccccccccccccccccccccc
c Accept action routines in z<act-cmd> input
	if(index(wrest,'Z<').gt.0)then
	iii=index(dskrec.lists,'Z(')
	if(iii.gt.0)then
	iij=index(dskrec.lists(iii:),')')
	if(iij.gt.0)then
	iij=iij+iii+1-3
	dskrec.lists=dskrec.lists(:iii-1) // dskrec.lists(iij+2:)
	end if
	end if
	iii=index(wrest,'Z<')
	iij=index(wrest(iii:),'>')
	if(iij.gt.0)then
	iij=iij+iii-2
	ldrl=ivlen(dskrec.lists,1600)
	dskrec.lists=dskrec.lists(:ldrl) // 'Z(' // 
     1  wrest(iii+2:iij) // ')'
	endif
	endif
c Accept action routines in z<act-cmd> input
	if(index(wrest,'X<').gt.0)then
	iii=index(dskrec.lists,'X(')
	if(iii.gt.0)then
	iij=index(dskrec.lists(iii:),')')
	if(iij.gt.0)then
	iij=iij+iii+1-3
	dskrec.lists=dskrec.lists(:iii-1) // dskrec.lists(iij+2:)
	end if
	end if
	iii=index(wrest,'X<')
	iij=index(wrest(iii:),'>')
	if(iij.gt.0)then
	iij=iij+iii-2
	ldrl=ivlen(dskrec.lists,1600)
	dskrec.lists=dskrec.lists(:ldrl) // 'X(' // 
     1  wrest(iii+2:iij) // ')'
	endif
	endif
c Now build the new ACE
	lnace=laclac+12
c do nothing if no new ACL entry was specified.
	if(laclac.gt.0)then
	newace(1)=lnace
	newace(2)=ace$c_info
	newace(3)=ace$c_cust
	newace(4)=14 !(ace$m_protected+ace$m_hidden+ace$m_nopropagate)/256
c no sense proagsting...file ID would change so no benefit. One can
c use the sys to protect directory files, though.
	newace(5)=lookhere ! my "look at this in dmn" flag. Should really not
c be there if only priv/ident/baseprio mods are there. Make it external so
c we can control it though. There may be future apps (in softlinks?) where
c we'll want to not do the obvious...
	newace(6)=0
	newace(7)=0
	newace(8)=0
	cnewace(9:12)='GCEV' ! my flag text
	cnewace(13:lnace)=aclac(1:laclac)
c null terminate it all
	newace(laclac+13)=0
	newace(laclac+14)=0
	newace(laclac+15)=0
	end if
c
c get a channel to the device
	icolon=index(dvcnam,':')
	kkk=sys$assign(dvcnam(:icolon),ichn,,,,)
c pass new ACE to our file
c Also junks any pre-existing ACE from us.
c (skip if override specified)
	if(index(wrest,'W+').gt.0)goto 761
	call replent(ifid,ichn,newace)
761	continue
	kkk=sys$dassgn(%val(ichn))
c add in A(<aclac>) into record
	dskrec.ifid(1)=ifid(1)
	dskrec.ifid(2)=ifid(2)
	if(laclac.gt.0)then
c Add the ACE part to the index file, which makes tracking it all
c possible.
	ii=index(dskrec.lists,'A(')
c remove old ace stuff if any
	if(ii.gt.0)then
	ij=index(dskrec.lists(ii:),')')
	ij=ii+1+ij
	dskrec.lists=dskrec.lists(:ii-1) // dskrec.lists(ij+1:)
	end if
	ldrl=ivlen(dskrec.lists,1600)
	dskrec.lists=dskrec.lists(:ldrl) // 'A(' // aclac(:laclac)
     1  // ')'
	llst=ivlen(dskrec.lists,1600)
	llst=llst+112
	if(igot.eq.1)rewrite(2,6301)dskrec.ch(:llst)
6301	format(a)
	if(igot.eq.0)write(2,6301)dskrec.ch(:llst)
	end if
	close(unit=2)
9999	call unexempt
	call exit
9898	call unexempt
	call exit(4)
	end
c The following user open routine will get the file ID for us.
	integer*4 function fgetfid(fab,rab,iunit)
	include '($rmsdef)'
	include '($fabdef)'
	include '($rabdef)'
	include '($xabfhcdef)'
	record	/fabdef/fab
	record  /rabdef/rab
	integer*2 ifid(4)
	integer*4 filsiz,sys$open
	external sys$open
	common/ffiidd/ifid,filsiz
	record /xabfhcdef/xabfhc
	integer*4 istat
	filsiz = -1
	istat=1
c assume OK
c open the file and find its' file ID and size for caller
	istat=sys$open(fab)
	if(.not.istat)goto 9999
	filsiz=fab.fab$l_alq
	ifid(4)=0
c get file ID
	call getfid(fab,ifid)
9999	fgetfid=istat
	return
	end
c ILEN function to find the length of a string less trailing whitespace
c Assumes string length = 80 max.
	integer*4 function ilen(arg)
	character*80 arg
c return length of printable string
	do 1 n=1,80
	k=81-n
c go back in loop looking for a printing char.
	if(ichar(arg(k:k)).gt.32)goto 2
1	continue
2	continue
	ilen=k
	return
	end
	subroutine getpv(pwd,lpwd,ilo,ihi)
	character*80 pwd
	integer*4 ilo,ihi,lpwd
	ilo=0
	ihi=0
c crazy little function of password string to produce a couple of
c different values. Lossy, but that's what we want.
	do 1 n=1,lpwd
	khar=ichar(pwd(n:n))
	ilo=ilo*3 + khar
	ihi=ihi*5 + khar
	if(ilo.lt.0)ilo=ilo+1
	if(ihi.lt.0)ihi=ihi+1
1	continue
	return
	end
	integer*4 function ivlen(arg,len)
	integer*4 len
	character*(*) arg
c return length of printable string
	do 1 n=1,len
	k=len+1-n
c go back in loop looking for a printing char.
	if(ichar(arg(k:k)).gt.32)goto 2
1	continue
	ivlen=0
	return
2	continue
	ivlen=k
	return
	end
c
	subroutine lprc(cmdchrs,csw,cfill,wrks)
c hunt for csw+ csw- or csw* andact on wrks string
	character*256 cmdchrs
	character*1600 cwrk
	character*1 csw
	character*2 cfill
	character*3 cwk
	character*1600 wrks
c if csw command is in cmdchrs string, process it.
	cwk=csw // '+<'
	iii=index(cmdchrs,cwk)
	if(iii.gt.0)then
	iv=index(cmdchrs(iii:),'>')
	if(iv.gt.0)then
	iv=iii-2+iv
c add to string
c find out if string exists in wrks
	iw=index(wrks,cfill)
	if(iw.gt.0)then
	iwr=index(wrks(iw:),')')
	iwr=iwr+1+iw-3
c we will add comma separators here
	wrks=wrks(:iwr) // ',' // cmdchrs(iii+3:iv) // wrks(iwr+1:)
	end if
	if(iw.le.0)then
c add string to wrks list
	lwrk=ivlen(wrks,1600)
	wrks=wrks(:lwrk) // cfill // cmdchrs(iii+3:iv) // ')'
	end if
	end if
	end if
	cwk=csw // '-<'
	iii=index(cmdchrs,cwk)
	if(iii.gt.0)then
	iv=index(cmdchrs(iii:),'>')
	if(iv.gt.0)then
	iv=iii-2+iv
c subtract from string
c find out if string exists in wrks
	iw=index(wrks,cfill)
	if(iw.gt.0)then
	iwr=index(wrks(iw:),')')
	iwr=iwr+1+iw-3
c remove leading comma if any as well as our string
	ixpng=index(wrks(iw+2:iwr),cmdchrs(iii+3:iv))
	if(ixpng.gt.0)then
	ix2=ixpng+iw+2+1
	ix3=ix2+(iv-iii-2)
	if(wrks(ix2-1:ix2-1).eq.',')ix2=ix2-1
	wrks=wrks(:ix2-1) // wrks(ix3+1:)
	end if
c no need to remove if the type is missing altogether
	end if
	end if
	end if
	cwk=csw // '*<'
	iii=index(cmdchrs,cwk)
	if(iii.gt.0)then
	iv=index(cmdchrs(iii:),'>')
	if(iv.gt.0)then
	iv=iii-2+iv
c replace string
c find out if string exists in wrks
	iw=index(wrks,cfill)
	if(iw.gt.0)then
	iwr=index(wrks(iw:),')')
	iwr=iwr+1+iw-3
c remove old string wherever it was
	wrks=wrks(:iw-1) // wrks(iwr+1:)
	end if
c add string to wrks list
	lwrk=ivlen(wrks,1600)
	wrks=wrks(:lwrk) // cfill // cmdchrs(iii+3:iv) // ')'
	end if
	end if
	return
	end
	subroutine filck(fnam,ics1,ics2)
	character*(*) fnam
	integer*4 ics1,ics2
	integer*4 lfil,nffree
	common/fszc/lfil,nffree
	byte wrkbuf(2048)
	integer*4 iufck
	external iufck
	integer*4 wbl,i4tst,i4x
	integer*2 i2tst(2),i2x(2)
	equivalence (i4tst,i2tst(1)),(i4x,i2x(1))
c compute a couple checksums on a file fnam, returning them in
c ics1, ics2
c For faster access,
	i4tst=ics1
	i2sv=ics2
c now i2tst(2) is sum of len + firstfree byte
	ics1=0
	ics2=0
c on error just return 0
	irecl=80
	inquire(file=fnam,recl=irecl)
	open(unit=10,file=fnam,readonly,form='formatted',
     1  status='old',err=999,recl=irecl,useropen=iufck)
	ipar=1
c if file length code changed we can exit instantly.
	i4x=8*lfil+nffree
100	continue
	read(10,2000,end=990,err=990)wbl,wrkbuf
2000	format(q,128a1,128a1,128a1,128a1,128a1,128a1,128a1,128a1,
     1  128a1,128a1,128a1,128a1,128a1,128a1,128a1,128a1)
	do 200 n=1,wbl
c ics1 is just a 32 bit checksum; ics2 is a random weirdo checksum
c which anuhowe should be reproducible.
	ics1=ics1+wrkbuf(n)
	ics2=ics2*3 + ipar * wrkbuf(n)
	ipar = -ipar
c wrap hi bit back in
	if(ics2.lt.0)ics2=ics2+1
200	continue
c if we get partway thru only, return what we can. Use the same
c routine to compute the checksum in the first place so we can be
c sure we get it approximately right.
	goto 100
990	continue
	close(unit=10)
c encode file size in 1st sum high word
	i4tst=ics1
	i2tst(2)=i2x(1)
	ics1=i4tst
999	continue
	return
	end
	integer*4 function iufck(fab,rab,lun)
	include '($rmsdef)'
	include '($fabdef)'
	include '($rabdef)'
	include '($xabfhcdef)'
	include '($syssrvnam)'
	integer*4 lun,istat
	record/fabdef/fab
	record/rabdef/rab
	include '($xabdef)'
	integer*4 lfil,nffree
	common/fszc/lfil,nffree
	iufck=1
c get file length & first free byte & open file.
	istat=sys$open(fab)
	if(istat)istat=sys$connect(rab)
	if(.not.istat)then
	iufck=16
	lfil=-1
	return
	endif
c get xab data. xabfhc there somwhere...
	ixab=fab.fab$l_xab
	inext=0
100	continue
	call gtxab(%val(ixab),inext,ieof,iffree)
	if(inext.ne.0)then
	ixab=inext
	inext=0
	goto 100
	endif
c now we should have our values. Return them in a 16 bit word
c for the code...
	lfil=ieof
	nffree=iffree
	return
	end
	subroutine gtxab(xab,inext,ieof,iffree)
	include '($xabdef)'
	include '($fabdef)'
	include '($rmsdef)'
	include '($rabdef)'
	include '($xabfhcdef)'
	include '($syssrvnam)'
        STRUCTURE /FHCDEF/
            BYTE      XAB$B_COD                 !  xab id code
            BYTE      XAB$B_BLN                 !  block length
            INTEGER*2 %FILL                             !  (spare)
            INTEGER*4 XAB$L_NXT                 !  xab chain link
! THESE 4 FIELDS ARE COMMON TO ALL XABS AND
! HAVE BEEN DEFINED BY $XABDEF
            BYTE      XAB$B_RFO                 !  record format and file org
            UNION
                MAP
                BYTE      XAB$B_ATR                     !  record attributes
                END MAP
                MAP
                BYTE %FILL (1)
                END MAP
            END UNION
            INTEGER*2 XAB$W_LRL                 !  longest record's length
            UNION
                MAP
                INTEGER*4 XAB$L_HBK                     !  hi vbn allocated
                END MAP
!  (n.b. reversed on disk!)
                MAP
                    INTEGER*2 XAB$W_HBK0
                    INTEGER*2 XAB$W_HBK2
                END MAP
            END UNION
            UNION
                MAP
                INTEGER*4 XAB$L_EBK                     !  eof vbn
                END MAP
!  (n.b. reversed on disk)
                MAP
                    INTEGER*2 XAB$W_EBK0
                    INTEGER*2 XAB$W_EBK2
                END MAP
            END UNION
            INTEGER*2 XAB$W_FFB                 !  first free byte in eof block$
            BYTE      %FILL                             !  bucket size for fhc $
!  defined above in $xabdef, since it is shared
!  by the all xab)
            BYTE      XAB$B_HSZ                 !  header size for vfc
            INTEGER*2 XAB$W_MRZ                 !  max record size
            INTEGER*2 XAB$W_DXQ                 !  default extend quantity
            INTEGER*2 XAB$W_GBC                 !  global buffer count
            BYTE      %FILL(1:8)                        !  spares (pad to last $
            INTEGER*2 XAB$W_VERLIMIT            !  version limit for file.
! -----*****
            INTEGER*4 XAB$L_SBN                 !  starting lbn if contiguous
        END STRUCTURE   ! FHCDEF
	record/fhcdef/xab
	integer*4 inext,ieof,iffree
	if(xab.xab$b_cod .ne. xab$c_fhc)then
	inext=xab.xab$l_nxt
	return
	endif
c this is our xab.
	inext=0
	ieof=xab.xab$l_ebk
	iffree=xab.xab$w_ffb
	return
	end