c Open processing filtering here.
c Copyright (c) 1994 Glenn C. Everhart
c All Rights Reserved.
c There are several functions to be implemented:
c 1. Security checks on file
c 2. Move file back from storage (via calling a DCL script) if
c	not currently there
c 3. If file is a directory being opened, get files created empty
c	but with swap-in ACLs that let us find saved files, and with
c	"temporary" flags to allow cleanup later if there's nothing
c	opened there. This for a directory that's swapped out. 
c
c 7/1/94 performance boost attempt...
c Keep track of which file we have open for ISAM access and only
c close and reopen the file if we need to open a new one. Just
c unlock records instead of closing the file. This should mean
c on average less open/close operations and faster access to the
c files. Caches in RMS might work better, too. Apart from these
c smallish changes, however, very few things change. This will be
c real handy for the delete processing where any deletes go via
c the ISAM file checking too...deletes tend to come in bunches...
c
c NOTE: This means we must fill the dir with the original file IDs
c or the temporary tags must tell us original file ids. Use temp.
c tags instead. If not present use file ID we got. Later anything with a
c temp. tag can get removed.
c temp tag has original FID and sys time quadword to allow this.
c; Open Message format (from JTdriver):
c01;0 LDT addr
c02; 1 (= flag this is open call)
c03; Victim device UCB address
c04; ACE address
c05;16 JTKAST address (where to send ast)
c06; FID, 1st long
c07; FID, 2nd long
c08; accmd (how-open)
c09; DID, 1st long
c10; DID, 2nd long
c11; PCB of process
c12;44 IPID of process (sch$qast uses)
c13; EPID of process
c14; JT UCB address
c15  unit number
c16  nodename, lo, counted ascii
c17  nodename, hi, counted ascii
c18  device name, counted ascii 1 of 4
c19  device name, counted ascii 2 of 4
c20  device name, counted ascii 3 of 4
c21  device name, counted ascii 4 of 4
c22  allocation class
c;
c;
c; Extend dmn msg format:
c1; Msg blk addr in knl mode
c2; 2 (= flag for extend call)
c3; dvc name (count + 15 bytes ascii)
c4
c5
c6
c7; unit number, binary
c8; IRP addr
c9; PCB addr
c10; victim ucb
c11; ccb addr
c12; r7
c13; r8
c14; user FIB addr
c15; size user wants
c16; FID, 1st part
c17; FID, 2nd part
c18; how-open (fib$l_acctl)
c19;72 Where to send AST back
c20; PCB 
c21; IPID
c22; EPID
c23 allo class
c24 nodename 1
c25 nodename 2
c;
c; del dmn msg fmt:
c1;0 Msg blk addr in knl mode
c2; 3 (= flag for delete call) (if 4096 on return, abort the i/o)
c3; dvc name (count + 15 bytes ascii)
c4;dvcnam 2
c5;dvcnam 3
c6;dvcnam 4
c7; unit number, binary
c8; IRP addr
c9; PCB addr
c10; victim ucb
c11; ccb addr
c12; r7
c13; r8
c14; user FIB addr
c15; size user wants
c16; FID, 1st part
c17; FID, 2nd part
c18; how-open (fib$l_acctl)
c19;72 Where to send AST back
c20; DID, high part
c21; DID, low part
c22; PCB
c23; IPID
c24; EPID
c25 allo class
c26 nodename 1
c27 nodename 2
c;
c; blk+112 = 1 if a filenum we stored. Check security if so.
c; opnfilt(buf,mdace,uace,vchn)
c; Should return mdace as ACE we will send to the kernel again.
c; initially uace & mdace are the same up to length of ace.
c; vchn points at the device in case we need a channel there, provided
c; it is positive. Do not use if negative!!!
	integer*4 function opnfilt(buf,outace,inace,vchn)
	integer*4 vchn
	integer*4 buf(64)
	byte outace(256),inace(256)
	character*256 cace
	byte bcace(256),mdace(256)
	equivalence(cace,bcace(1),mdace(1))
c Insert a common field to allow control of capabilities
	integer*4 icapab(12)
	common/ilicc/icapab
	integer*4 rjcode
	common/rjcod/rjcode
c
c Define our database info. Keep the info in a nice big ISAM file
c indexed by file ID.
	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
c 8 = move by zip
c
c 524288 = check all opens while this file is open
c 262144 = run stuff...
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 
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
	integer*4 idwrk(2),prvwrk(2)
	integer*2 i2dw(4)
	equivalence(i2dw(1),idwrk(1))
	character*8 cidwrk
	equivalence(idwrk(1),cidwrk)
        integer*4 ipnow(2),ipnowl
        integer*4 ttyspl,imgspl
        integer*4 iosb(2),jpiitm(3,7),KIOS
        integer*2 jp2itm(6,7)
        equivalence(jpiitm(1,1),jp2itm(1,1))
	character*256 dbnam,dbnam2
	character*256 dbnshr
	integer*4 ldbnshr
	common/dbns/ldbnshr,dbnshr
	character*512 wrklst
	character*128 cparan
	integer*4 lparan
	byte wknm(16)
	integer*4 wkn4(4),jtspawn
	external jtspawn
	character*16 cwknm
	character*256 cw1,cw2,cwa1
	character*256 cwrkn
	equivalence (cwrkn,cwknm)
	equivalence (cwknm,wknm(1),wkn4(1))
	character*32 ttyspb,unamb,rjasc
	character*64 accpor
c "globally-ok" images...
	integer*4 nefile
	character*512 wfscr
	character*512 efiles(32),efscr
	common/exfl/nefile,efiles
	include '($jpidef)'
	integer*4 accporl,iuic,iprv(2)
	common/kiuic/iuic
	character*256 imgspb
	character*512 wrkarg
	integer*4 ccol
	integer*4 unaml
	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
	include '($strdef)'
	integer*4 str$match_wild
	external str$match_wild,lib$sys_trnlog
	myparan=0
c If the logical GCY$PARAN is defined as 'OK', enable paranoid mode
	kkk=lib$sys_trnlog('GCY$PARAND',lparan,cparan)
	if((kkk.and.1).ne.0)then
	if (lparan.ge.2.and.cparan(1:2).eq.'OK')then
	myparan=1
	endif
	endif
	kntall=0
c	icapab(1) = -1
c call the license checker to alter icapab mask to disable
c stuff.
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)
        jpiitm(1,7)=0
        jpiitm(2,7)=0
        jpiitm(3,7)=0
c open filtering is not done for delfilt, just for eacf. Thus check
c capabilities there.
c Open filtering is done for HSM too...
	if(iand(icapab(1),5).eq.0)then
c no EACF checks enabled, so skip out here.
	call tstulk
	opnfilt=1
	return
	endif
c Check for exempt images before anything else. Need to do this so we
c don't get wedged by any such opening our files when we need to also.
c get user/tty/image for error messages if any.
	if(buf(1).lt.0)kk=sys$getjpiw(%val(1),buf(13),,jpiitm,iosb,,)
	kkpid=buf(13)
	if(buf(1).ge.0)then
	kkpid=buf(24)
	kk=sys$getjpiw(%val(1),kkpid,,jpiitm,iosb,,)
	end if
	unaml=ivlen(unamb,16)
	ttyspl=ivlen(ttyspb,32)
	imgspl=ivlen(imgspb,256)
	accporl=ivlen(accpor,64)
c First check if this image matches the image we got from $getjpi just
c now...
c Skip null image tho...
	if(imgspl.lt.3)goto 833
	do 831 n831=1,32
	efscr=efiles(n831)
	lspec=ivlen(efscr,512)
	if(lspec.lt.2)goto 831
	if(imgspb(:imgspl).eq.efscr(:lspec))goto 832
	lll=str$match_wild(imgspb(:imgspl),efscr(:lspec))
	if(lll.eq.str$_match)goto 832
831	continue
	lll=str$match_wild(imgspb(:imgspl),'*JTAUTHMAINT.EXE*')
	if(lll.eq.str$_match)goto 832
c Allow jtauthmaint to access files in any case to avoid hangs. Try
c to tighten this up later to be gcy$sys:jtauthmaint.exe;1 if we can
c or in any case to be more specific. We must avoid lockouts between
c jtauthmaint & jtopen for the database file.
	goto 833
832	continue
c One of our patterns matched the image we saw here, so we will let the
c access succeed, regardless of what else is going on.
	call tstulk
	opnfilt=1
	return
833	continue
c
c First figure what we need to do.
c Find the file ID we need to work with first.
	idwrk(1)=buf(6)
	idwrk(2)=buf(7)
	myaccmd=buf(8)
	idid1=buf(9)
	idid2=buf(10)
c we have the couple flags as the high bits, so set flags
	iitemp = -1073741824
	myrunfgs=myaccmd.and. iitemp
	iitemp = 536870912
	myspwnall=myaccmd.and. iitemp
	if(myparan.ne.1)then
c If the enabling logical for paranoid mode is not set, then
c ensure that the "paranoid" flags are 0.
	myrunfgs=0
	myspwnall=0
	endif
	kkk=536870911
	myaccmd=myaccmd.and.kkk
c Mask off 2 bits from myaccmd. If myrunfgs is nonzero, we're
c checking all opens this guy does first.
c use file ID we were sent unless the ACE has a temp flag in which case
c use the file ID there.
	do 31 n=1,256
	outace(n)=inace(n)
31	continue
c the 256 byte of the 2nd longword of the ACE should be 1 if this is suspicions
	isuspic=0
c flag when the ACE was not seen by the driver.
	if ((inace(6).and.1).ne.0)isuspic=1
	call getid(inace,idwrk)
c Now idwrk has the desired file ID.
c Figure out the database name now.
	ldvcn=mod(buf(18),256)
c buf(19) = dvc name, counted
c 22=allo class, 16 = unit no
c 17=nodename, counted ascii
	wkn4(1)=buf(16)
	wkn4(2)=buf(17)
	cw1=cwrkn(2:(wknm(1)+1)) ! nodename, 6 chars or less
	ccol=index(cw1,':')
c strip any ":" from nodename
	if(ccol.gt.0.and.ccol.lt.8)cw1=cw1(:ccol-1)
	lcw1=ivlen(cw1,6)
	wkn4(1)=buf(18)
	wkn4(2)=buf(19)
	wkn4(3)=buf(20)
	wkn4(4)=buf(21)
	cw2=cwrkn(2:(wknm(1)+1)) ! device name
	lcw2=ivlen(cw2,15)
c Write name with alloc. class or nodename. Use nodename if allo
c class is zero.
	if(buf(22).eq.0)write(dbnam,100)cw1(:lcw1),cw2(:lcw2),buf(15)
100	format('JTD$DB:OP',a,a,i3.3,'.GDB')
	if(buf(22).ne.0)write(dbnam,101)buf(22),cw2(:lcw2),buf(15)
101	format('JTD$DB:OP',i3.3,a,i3.3,'.GDB')
	if(buf(22).eq.0)write(dbnam2,9100)cw1(:lcw1),cw2(:lcw2),buf(15)
9100	format('JTD$DB:OP',a,'$',a,'$',i3.3,'.GDB')
	if(buf(22).ne.0)write(dbnam2,9101)buf(22),cw2(:lcw2),buf(15)
9101	format('JTD$DB:OP',i3.3,'$',a,'$',i3.3,'.GDB')
	ldbn2=ivlen(dbnam2,256)
	ldbn=ivlen(dbnam,256)
c if we should look at everything, run the "test" cmd proc here
c before accessing the database. (We can run these accesses in
c parallel with minor mods to the macro stuff if needed to avoid
c long delays in opens.)
	if(myrunfgs.ne.0.or.myspwnall.ne.0)then
	msal=0
	if(myspwnall.ne.0)msal=1
c try and run a command file to process "look at all" file cases.
c pass pid, user, fid, myaccmd and let THAT process figure
c out what to do for now. This will allow lots of things, and should
c be made more efficient (use lib$find_image_symbol) later.
	ldbn24=ldbn2-4
	write(wfscr,5609)idwrk,unamb(1:unaml),iuic,buf(13),buf(8),
     1  dbnam2(10:ldbn24),msal
c fileid, username, uic, pid, accmode, device (less possible initial "$")
5609	format('$@gcy$sys:filtall ',2z9.8,1x,a,1x,z8,1x,z8,
     1   1x,z8,1x,a,1x,i2)
c send the command out and if it returns bad, fail
	lwfscr=ivlen(wfscr,512)
	kkk=lib$spawn(wfscr(1:lwfscr),,,,,,kkkk)
	if(iand(kkkk,1).eq.0)then
	call tstulk
	opnfilt=2
	return
	endif
	endif
c before opening, see if it's open now. If so just leave it. Else
c close & reopen.
	if(ldbnshr.le.0.or.dbnam(1:ldbn).ne.dbnshr(:ldbnshr))
     1 then
	ldbnshr=ldbn
	close(unit=2)
	dbnshr=dbnam(1:ldbn)
        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)
	endif
	kkqwwq=20
8	continue
	i2dw(4)=0
c kntall will be 16384 if flags are...etc...add to rtn code
	kntall=0
        read(unit=2,fmt=6300,keyeq=cidwrk,keyid=0,
     1  iostat=kios)DSKREC.ch
6300	format(a)
c err 67 means record too short, an expected condition.
	isawfst=0
	if(kios.eq.0.or.kios.eq.67)isawfst=1
	if(kios.eq.0.or.kios.eq.67)goto 10
c 36 is no record found. Actually want here to try the owning directory
c instead, in case that has controls...but only ONCE.
	if(kios.eq.52) then
c locked record...wait & retry
	xtim=4.0
	call lib$wait(xtim)
	kkqwwq=kkqwwq - 1
	if(kkqwwq.ge.0)goto 8
	end if
	if(kios.eq.36)then
c try a read of owner directory ID
c do this to ONE level only to avoid infinite looping.
	ikkki=0
	if (idid1.eq.0.and.idid2.eq.0)goto 9999
2118	idwrk(1)=idid1
	idwrk(2)=idid2
c read the owning dir ID record
        read(unit=2,fmt=6300,keyeq=cidwrk,keyid=0,
     1  iostat=kios)DSKREC.ch
	idwrk(1)=buf(6)
	idwrk(2)=buf(7)
	if(kios.eq.0.or.kios.eq.67)goto 10
	if(kios.eq.52)then
	xtim=2.0
	call lib$wait(xtim)
	ikkki=ikkki+1
	if(ikkki.lt.20)goto 2118
	endif
	endif
c kios indicates error. Just lose.
	goto 9999
10	continue
	if (isawfst.ne.0.and.isuspic.ne.0)
     1  call oprmsg(' ** WARNING** File ACE missing **')
	ikflgs=dskrec.kflgs
	kdothis=ikflgs.and.131072
	if(kdothis.ne.0.and.myparan.eq.1)then
	msal=0
	if(kdothis.ne.0)msal=1
c try and run a command file to process "look at all" file cases.
c pass pid, user, fid, myaccmd and let THAT process figure
c out what to do for now. This will allow lots of things, and should
c be made more efficient (use lib$find_image_symbol) later.
	ldbn24=ldbn2-4
	write(wfscr,5609)idwrk,unamb(1:unaml),iuic,buf(13),buf(8),
     1  dbnam2(10:ldbn24),msal
c fileid, username, uic, pid, accmode, device (less possible initial "$")
c send the command out and if it returns bad, fail
	lwfscr=ivlen(wfscr,512)
	kkk=lib$spawn(wfscr(1:lwfscr),,,,,,kkkk)
	if(iand(kkkk,1).eq.0)then
	call tstulk
c Just return error if the command file returns error condition.
	opnfilt=2
	return
	endif
	endif
	kntall=ikflgs.and.(524288+262144)
c mask off flags that file was moved.
	ikflgs=ikflgs.and.12
c make the access-test code a subroutine so the deletion code can test
c it too.
	isaccok=1
	call chkac(isaccok,buf,dskrec,inace,outace)
c isaccok returns not 1 if access should be denied, 1 if all's well.
c Also can edit the ace into mdace if necessary.
c now handle softlink stuff if any
c (do this here only if isaccok comes back not 1)
c This works by just adding the softlink string to the text.
	if (isaccok.eq.1)then
c if there's an X(cmd) command, spawn it and if it comes back even
c (indicating a fail) reject access also. Use jtspawn3 for this.
c begin x( stuff
c If user wanted an action, try & do it.
	iii=index(dskrec.lists,'X(')
	if(iii.gt.0)then
c A user filter routine must be invoked. Run it in a kept subprocess. Note
c that CARE is needed in constructing such since no marked files can be
c opened by that routine if they are handled by this daemon. Such a routine
c can however serve to notify something else in the system that the file
c has been accessed for open, getting there BEFORE the open succeeds or
c fails.
	iij=index(dskrec.lists(iii:),')')
	if(iij.gt.0)then
	iij=iii+iij-1
c Spawn a command to do the work. If the work will be lengthy the
c command should be a submit.
	efscr=dskrec.lists(iii+2:iij-1)
	wfscr=efscr
	lefscr=ivlen(efscr,512)
c Pass the user command the following:
c 1. username
c 2. terminal name
c 3. file id long 1, hex
c 4. file id long 2, hex
c 5. pid, hex
c (but do not do this if cmd characters include "\" in which case chop)
	if(index(efscr,'\').gt.1)then
	iii=index(efscr,'\')
	efscr=efscr(1:iii-1)
	wfscr=efscr
	lefscr=ivlen(efscr,512)
	goto 813
	endif
	wfscr = efscr(:lefscr) // ' ' // unamb(:unaml) // ' '
     1  // ttyspb(:ttyspl)
	lwfscr=ivlen(wfscr,512)
	write(efscr,812)idwrk(1),idwrk(2),buf(13)
812	format(3z9)
	wfscr = wfscr(:lwfscr) // efscr(1:30)
c (actually only efscr 1:27 is filled here)
813	continue
	lwfscr=ivlen(wfscr,512)
	kkk=jtspawn(wfscr(:lwfscr),3)
c	kkk=lib$spawn(wfscr(:lwfscr),,,,,,kkk)
	if (iand(kkk,1) .eq. 0) then
	rjcode=2048
	goto 9631
	endif
	endif
	endif
c end x( stuff
	endif !isaccok = 1
	if(isaccok.ne.1)then
c convert reject code to ascii msg
9631	continue
	iiii=rjcode
	call rj2asc(iiii,rjasc)
	write (cwa1,112)idwrk(1),idwrk(2),buf(13),rjcode,rjasc
112	format('%EACF-F-File access to fid ',2z9,
     1  ' by PID ',z8,' rejected code:',z8,1x,a)
	lcwa1=ivlen(cwa1,256)
c emit an operator alarm about the rejected access.
c (note: we should report username also, and time.)
	call oprmsg(cwa1(:lcwa1))
c report additional info on this guy also
	write(cwa1,113)ttyspb(:ttyspl),imgspb(:imgspl),
     1  unamb(:unaml),accpor(:accporl)
113	format('%EACF - reject tty:',a,' image:',a,
     1  ' username:',a,' accpor:',a)
	lcwa1=ivlen(cwa1,256)
	call oprmsg(cwa1(:lcwa1))
c If user wanted an action, try & do it.
	iii=index(dskrec.lists,'Z(')
	if(iii.gt.0)then
c Action is specified. Spawn it as a command.
	iij=index(dskrec.lists(iii:),')')
	if(iij.gt.0)then
	iij=iii+iij-1
c Spawn a command to do the work. If the work will be lengthy the
c command should be a submit.
	efscr=dskrec.lists(iii+2:iij-1)
	wfscr=efscr
	lefscr=ivlen(efscr,512)
c Pass the user command the following:
c 1. username
c 2. terminal name
c 3. file id long 1, hex
c 4. file id long 2, hex
c 5. pid, hex
c (but do not do this if cmd characters include "\" in which case chop)
	if(index(efscr,'\').gt.1)then
	iii=index(efscr,'\')
	efscr=efscr(1:iii-1)
	wfscr=efscr
	lefscr=ivlen(efscr,512)
	goto 1813
	endif
	wfscr = efscr(:lefscr) // ' ' // unamb(:unaml) // ' '
     1  // ttyspb(:ttyspl)
	lwfscr=ivlen(wfscr,512)
	write(efscr,812)idwrk(1),idwrk(2),buf(13)
c812	format(3z9)
	wfscr = wfscr(:lwfscr) // efscr(1:30)
c (actually only efscr 1:27 is filled here)
1813	continue
	lwfscr=ivlen(wfscr,512)
	kkk=lib$spawn(wfscr(:lwfscr),,,,,,kkk)
	endif
	endif
c do conditional softlinking if called for too.
	if(ichar(dskrec.csoftl(1:1)).eq.6)then
	  lace=outace(1)
c ensure we don't run off the end of the ACE
	  if(lace.gt.(218))then
	    lace=218
	    outace(1)=218
	  end if
	  if(lace.gt.0)then
	    outace(1) = outace(1) + 36
	    mm=lace+1
	    mmm=lace+36
	    mmmm=1
c Add the softlink record to the end of the ACE
	    do 111 n111=mm,mmm
	    outace(n111)=ichar(dskrec.csoftl(mmmm:mmmm))
	    mmmm=mmmm+1
111	continue	
c If we have a softlink, make it look like the I/O was a success
c so the softlink can get opened. Do not however move anything since
c this is really an access failure.
c Note we still use a different return code to flag to NOT edit
c privs/ids/etc. as we would if we granted access.
	goto 29999
	  end if
	end if
c return error condition to caller
	goto 19999
	end if
	dskrec.kflgs=dskrec.kflgs.and.3
c if files were moved, clear flag to move them.
	if(ikflgs.eq.0)then
	llch=ivlen(dskrec.ch,1712)
	rewrite(unit=2,fmt=6301)dskrec.ch(:llch)
6301	format(a)
	unlock(unit=2)
	end if
	lrosb=1598
	irhisb=1598
	irfns=index(dskrec.lists,'R(')
	if(irfns.ge.1.and.irfns.lt.1530)then
	lrosb=irfns+2
	irhisb=index(dskrec.lists(lrosb:),')')
	if(irhisb.gt.1.and.irhisb.lt.512)irhisb=irhisb-1
	irhisb=irhisb+lrosb-1
	end if
c if files need to be moved, move them.
	iinswp=1
	if(ikflgs.ne.0)then
c First see if this might be a r/o softlink and NOT a r/w open.
c If it IS a r/o link and open is r/o, don't inswap.
	iinswp=1
	if(index(dskrec.lists,'<#>').gt.0)then
	iinswp=5
c r/o softlink.
c fib$m_write = 256
	if(iand(myaccmd,256) .eq. 0)then
c this open has no write bit
	dskrec.kflgs=dskrec.kflgs.or.ikflgs
	llch=ivlen(dskrec.ch,1712)
	rewrite(unit=2,fmt=6301)dskrec.ch(:llch)
	iinswp=1
	call tstulk
	opnfilt=1+kntall
	return
	end if
	end if
	if(iand(icapab(1),4).eq.0)then
c no HSM enabled so exit immediately if not.
	unlock(unit=2)
	opnfilt=1+kntall
	return
	endif
	losb=-1
	ihisb=-1
	ifns=index(dskrec.lists,'S(')
	if(ifns.ge.1.and.ifns.lt.1530)then
	losb=ifns+2
	ihisb=index(dskrec.lists(losb:),')')
	if(ihisb.gt.1.and.ihisb.lt.512)ihisb=ihisb-1
	ihisb=ihisb+losb-1
	end if
c Pass the EPID to the inswap procedure also so that if it wants to use
c it to delete a shelved file it can do so. This means the procedure must
c discover that the process at that pid is running delete.
	if(losb.gt.0.and.ihisb.gt.0)
     1	write(wrkarg,989)dbnam2(10:ldbn2-4),idwrk,
     1  dskrec.ifilsiz,
     1  dskrec.lists(losb:ihisb),dskrec.lists(lrosb:irhisb),kkpid
	if(losb.le.0.or.ihisb.le.0)
     1	write(wrkarg,979)dbnam2(10:ldbn2-4),idwrk,dskrec.ifilsiz
     1  ,dskrec.lists(lrosb:irhisb),kkpid
989	format('$@GCY$CM:FILRST ',A,' ',Z8.8,' ',Z8.8,' ',
     1  I12,' ',A,' ',a,' ',z8.8)
979	format('$@GCY$CM:FILRST ',A,' ',Z8.8,' ',Z8.8,' ',i12,
     1  ' NLA0:NONAME ',a,' ',z8.8)
	lwarg=ivlen(wrkarg,512)
	llch=ivlen(dskrec.ch,1712)
	rewrite(unit=2,fmt=6301)dskrec.ch(:llch)
c The above leaves the record unlocked during the spawn
c That way the subprocess can remove markings too.
c note filrst.com needs to reclaim space if disk lacks enough. DCL
c lexicals can tell if space enough exists. (f$getdvi "freeblocks" item)
c	kkk=lib$spawn(wrkarg(:lwarg),,,,,,istat)
	istat=jtspawn(wrkarg(:lwarg),2)
c remove the "need to move" flag unless we fail to move the file.
	if((istat.and.1).eq.0)then
	read(unit=2,fmt=6300,
     1  keyeq=cidwrk,keyid=0,
     1  iostat=kios)DSKREC.ch
	if(kios.eq.0.or.kios.eq.67)then
	if((istat.and.1).eq.0)dskrec.kflgs=
     1    dskrec.kflgs.or.ikflgs
	llch=ivlen(dskrec.ch,1712)
	rewrite(unit=2,fmt=6301)dskrec.ch(:llch)
	end if
	end if
	unlock(unit=2)
c if this was a r/o softlink we might return 5 which means to
c NOT do softlink after inswap.
	opnfilt=iinswp+kntall
	return
	end if
	unlock(unit=2)
	opnfilt=1+kntall
	return
9999	continue
	unlock(unit=2)
	opnfilt=1+kntall
	return
19999	continue
	unlock(unit=2)
	opnfilt=4+kntall
	return
29999	continue
c special cond'l softlink fake success. Ensures jtdriver can clr alter'd
c privs again.
	unlock(unit=2)
	opnfilt=7+kntall
	return
	end
	subroutine getid(ibuf,idwrk)
	byte idwrk(8)
	byte ibuf(256)
c scan ibuf for a file id override. Return it in idwrk if one
c exists.
	iloc=1
10	continue
	iop=ibuf(iloc)
	if(iop.le.0.or.iop.gt.7)return
	goto (100,200,300,400,500,600,700),iop
100	continue
200	continue
	iloc=iloc+1
	goto 10
300	continue
	iloc=iloc+6
	goto 10
400	continue
500	continue
	iloc=iloc+17
	goto 10
600	ilen=ibuf(iloc+1)
	iloc=iloc+ilen
	goto 10
700	continue
c found a "temp" record, so swap FIDs with it.
	isb=iloc+1
	do 710 n=1,6
	idwrk(n)=ibuf(isb+n)
710	continue
	idwrk(7)=0
	idwrk(8)=0
	iloc=iloc+16
c	goto 10
	return
	end
	subroutine chkac(isaccok,buf,dskrec,uace,mdace)
c see if access is OK
	integer*4 isaccok
	integer*4 buf(128),uace(64),mdace(64)
	integer*4 ifid(2)
	integer*4 rjcode
	common/rjcod/rjcode
	include '($jpidef)'
	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
c 8 = move by zip
c
	  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 
c
	  end map
	  map
	    character*1712 ch
	  end map
	 end union
	end structure
c
	record /jtdb/dskrec
	integer*4 iprv(2),sys$getjpiw
	external sys$getjpiw
        integer*4 iosb(2),jpiitm(3,7),KIOS
        integer*2 jp2itm(6,7)
        equivalence(jpiitm(1,1),jp2itm(1,1))
	character*20 clognm
	integer*4 clogln
	external lib$sys_trnlog
c	byte ttyspb(32),imgspb(256),unamb(32)
	integer*4 exttrnlnm
	external exttrnlnm
	integer*4 iuic,lluic
	common/kiuic/iuic
	integer*4 accporl
	character*256 imgspb
	character*32 ttyspb,unamb
	character*64 accpor
	integer*4 ttyspl,imgspl,unaml,lprvs
	common/jpijunk/ttyspb,ttyspl,imgspb,imgspl,unamb,
     1  unaml,accpor,accporl
c "globally-ok" images...
	integer*4 nefile
	character*512 efiles(32),efscr
	common/exfl/nefile,efiles
	include '($strdef)'
	integer*4 str$match_wild
	external str$match_wild
	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)
        jpiitm(1,7)=0
        jpiitm(2,7)=0
        jpiitm(3,7)=0
	isaccok=1
	rjcode=0
c get user/tty/image for error messages if any.
	if(buf(1).lt.0)kk=sys$getjpiw(%val(1),buf(13),,jpiitm,iosb,,)
	kkpid=buf(13)
	if(buf(1).ge.0)then
	kkpid=buf(24)
	kk=sys$getjpiw(%val(1),kkpid,,jpiitm,iosb,,)
	end if
	unaml=ivlen(unamb,16)
	ttyspl=ivlen(ttyspb,32)
	imgspl=ivlen(imgspb,256)
	accporl=ivlen(accpor,64)
c First check if this image matches the image we got from $getjpi just
c now...
	if(imgspl.lt.3)goto 833
	do 831 n831=1,32
	efscr=efiles(n831)
	lspec=ivlen(efscr,512)
	if(imgspb(:imgspl).eq.efscr(:lspec))goto 832
	lll=str$match_wild(imgspb(:imgspl),efscr(:lspec))
	if(lll.eq.str$_match)goto 832
831	continue
	lll=str$match_wild(imgspb(:imgspl),'*JTAUTHMAINT.EXE*')
	if(lll.eq.str$_match)goto 832
c Allow jtauthmaint to access files in any case to avoid hangs. Try
c to tighten this up later to be gcy$sys:jtauthmaint.exe;1 if we can
c or in any case to be more specific. We must avoid lockouts between
c jtauthmaint & jtopen for the database file.
	goto 833
832	continue
c One of our patterns matched the image we saw here, so we will let the
c access succeed, regardless of what else is going on.
	isaccok=1
	return
833	continue
c get time since midnight
	xx=secnds(0.)
	ihr=xx/3600.
	ihr=ihr+1 ! map to 1-24 range
	if(ihr.lt.0.or.ihr.gt.24)ihr=1
	if(dskrec.itim(ihr:ihr).eq.'U')goto 1000
c deny access if D hour code
	if(dskrec.itim(ihr:ihr).eq.'D')rjcode=jior(rjcode,1)
	if(dskrec.itim(ihr:ihr).eq.'D')goto 9000
c get original privs from ldt
	if(buf(1).le.0)call gtprv(buf(1),iprv)
	if(buf(1).ge.0)then
c If getjpi can get our caller's privs we can check them...
c skip priv check if delete
c	iprv(1)=0
c	iprv(2)=0
	ipcb=buf(22)
c get privs via kernel call since $getjpi seems not to.
	call jgtprvs(ipcb,iprv)
	end if
c check privs and reject access if user's original privs were too
c high. Note that privs checked are the original ones, not whatever
c the file might be forcing.
	iprv(1)=iprv(1).and..not.dskrec.maxprv(1)
	iprv(2)=iprv(2).and..not.dskrec.maxprv(2)
	if(iprv(1).ne.0.or.iprv(2).ne.0)rjcode=jior(rjcode,2)
	if(iprv(1).ne.0.or.iprv(2).ne.0)goto 9000
c get user name and so on via $getjpiw
	if(buf(1).lt.0)kk=sys$getjpiw(%val(1),buf(13),,jpiitm,iosb,,)
	kkpid=buf(13)
	if(buf(1).ge.0)then
	kkpid=buf(24)
	kk=sys$getjpiw(%val(1),kkpid,,jpiitm,iosb,,)
	iprv(1)=iprv(1).and..not.dskrec.maxprv(1)
	iprv(2)=iprv(2).and..not.dskrec.maxprv(2)
	if(iprv(1).ne.0.or.iprv(2).ne.0)rjcode=jior(rjcode,2)
	if(iprv(1).ne.0.or.iprv(2).ne.0)goto 9000
	end if
	unaml=ivlen(unamb,16)
	ttyspl=ivlen(ttyspb,32)
	imgspl=ivlen(imgspb,256)
	accporl=ivlen(accpor,64)
c now we have username
c check against superuser access. Superuser lists are B(user1,user2,user3...)
	igot=1
	call itmchk(unamb,unaml,'B(',dskrec.lists,igot)
	if(igot.ge.0.and.igot.ne.1)goto 10
c possible superuser access.
c test if r/o open and r/o only for s/u access.
	if((dskrec.kflgs.and.2).eq.0)goto 1000
c r/o access is all s/u should have. This match?
	iii=buf(8) ! how-open
	if(buf(1).ge.0)iii=0
	iii = iii.and.1
	if(iii.eq.1)goto 1000
c r/w open of some kind. Fall thru to normal checking.
10	continue
c check access time
	if(dskrec.itim(ihr:ihr).eq.'N')rjcode=jior(rjcode,1)
	if(dskrec.itim(ihr:ihr).eq.'N')goto 9000
	if(dskrec.itim(ihr:ihr).eq.'P')goto 1000
	if(dskrec.itim(ihr:ihr).eq.'Y')goto 20
	if(dskrec.itim(ihr:ihr).eq.'R'.or.
     1  dskrec.itim(ihr:ihr).eq.'X')then
	iii=buf(8) ! how-open
	if(buf(1).ge.0)iii=0
c 1 is read-only bit in fib$l_acctl
	iii = iii.and.1
	if(iii.eq.1)goto 1000
c if we test only r/o opens this means r/w opens are disallowed
c except by (previously tested) backup "superuser".
	if(dskrec.itim(ihr:ihr).eq.'X')goto 20
c if time code is X instead of R we allow r/o opens and test
c others normally. Could be handy to allow this.
	rjcode=jior(rjcode,1)
	goto 9000
	end if
20	continue
c is user on the ok list?
	call itmchk(unamb,unaml,'U(',dskrec.lists,igot)
	if(igot.eq.0)rjcode=jior(rjcode,8)
	if(igot.gt.0)goto 210
c see if the user is on the forbidden list
	call itmchk(unamb,unaml,'V(',dskrec.lists,igot)
	if(igot.gt.0)rjcode=jior(rjcode,4)
	if(igot.gt.0)goto 9000
210	continue
c is image on the permitted list?
	call itmchk(imgspb,imgspl,'I(',dskrec.lists,igot)
	if(igot.eq.0)rjcode=jior(rjcode,32)
	if(igot.gt.0)goto 310
c is the image he's using forbidden?
	call itmchk(imgspb,imgspl,'J(',dskrec.lists,igot)
	if(igot.gt.0)rjcode=jior(rjcode,16)
	if(igot.gt.0)goto 9000
310	continue
c is terminal on permitted list?
	call itmchk(ttyspb,ttyspl,'K(',dskrec.lists,igot)
	if(igot.gt.0)goto 50
c is accport on permitted list?
	call itmchk(accpor,accporl,'K(',dskrec.lists,igot)
	izzz=256
	if(igot.eq.0)rjcode=jior(rjcode,izzz)
	if(igot.gt.0)goto 50
c is terminal on forbidden list?
	call itmchk(ttyspb,ttyspl,'L(',dskrec.lists,igot)
	izzz=64
	if(igot.gt.0)rjcode=jior(rjcode,izzz)
	if(igot.gt.0)goto 9000
c Note that here the terminal isn't on the forbidden or the
c permitted list. See if the accport is.
c for terminals, test the accport info too, since LTAnnn: is not too
c helpful in general.
c is accport on forbidden list?
	call itmchk(accpor,accporl,'L(',dskrec.lists,igot)
	izzz=128
	if(igot.gt.0)rjcode=jior(rjcode,izzz)
	if(igot.gt.0)goto 9000
50	continue
c is there a checksum on the file?
	if(dskrec.chksum(1).eq.0.and.dskrec.chksum(2).eq.0)goto 30
c test the checksum and see if it matches.
c get the original filename if possible
	ilofn=index(dskrec.lists,'S(')
	if(ilofn.le.0.or.ilofn.gt.1536)goto 30
	ihfn=index(dskrec.lists(ilofn+2:),')')
	if(ihfn.le.0.or.(ihfn+ilofn).gt.1500)goto 30
	ic1=dskrec.chksum(1)
	ic2=dskrec.chksum(2)
c pass checksums into filck so it can shortcut the test if the file
c size has changed. (Store this in high word of ic1.)
	call filck(dskrec.lists(ilofn+2:ilofn+ihfn),ic1,ic2)
	izzz=512
	if(ic1.ne.dskrec.chksum(1))rjcode =jior(rjcode,izzz)
	if(ic1.ne.dskrec.chksum(1))goto 9000
	if(ic2.ne.dskrec.chksum(2))rjcode =jior(rjcode,izzz)
	if(ic2.ne.dskrec.chksum(2))goto 9000
30	continue
c is there a file password? If so we have a hash here that is non
c zero. See if a logical of form EZ$hexfileid contains our hashed
c password as stored.
c Note this implementation assumes the passwords are entered
c per system. We will have to alter this so that job table
c passwords for the relevant job are used, using the $trnlnm
c service more thoroughly. However, this lets us get started and
c says if the system hasn't got a password entered for the file
c in the appropriate table (use the group table mainly so this
c won't be too bad), it can't be accessed. This is somewhat reasonable
c also in emergency situations since anyone with the file password
c and sysnam priv can authorize use even with no group access
c by defining the password as a system thing.
c
c In practice this isn't as useful as one would like since "show logicals"
c will show the values...sort of.
	if(dskrec.pswd(1).eq.0.and.dskrec.pswd(2).eq.0)goto 1000
	ifid(1)=dskrec.ifid(1)
	ifid(2)=dskrec.ifid(2)
	iiii=(dskrec.ifid(2).and.65535)
	ifid(2)=iiii
	write (clognm,32)ifid
32	format('EZ$',Z8.8,Z4.4)
c iuic has file uic. Change our uic to match so group table will
c be the right one, then change back.
c first try process lnt
c If we find a password there, use it. Otherwise try once more
c to translate using the UIC of the target.
	istat=exttrnlnm(kkpid,,clognm(:15),'LNM$PROCESS_TABLE',
     1  clognm,clogln)
	if(istat.eq.1)goto 332
	call swpuic(iuic,imyuic)
	ii=lib$sys_trnlog(clognm(:15),clogln,clognm)
	call swpuic(imyuic,iii)
332	continue
c xor the logicals with random pattern to partly foil "sho log"
	do 35 n=1,16
	m=n+128
	ii=ichar(clognm(n:n))
	ii=ieor(ii,m)
c this ensures the value isn't printable ASCII, which will make it a little
c harder to crack.
	clognm(n:n)=char(ii)
35	continue
	read(clognm(1:8),33,err=9011)ih1
	read(clognm(9:16),33,err=9011)ih2
c Further confuse by xor with uic*3
	kuic=iuic*3
	ih1=ieor(ih1,kuic)
	ih2=ieor(ih2,kuic)
	goto 893
9011	continue
	izzz=1024
	rjcode =jior(rjcode,izzz)
	goto 9000
893	continue
c This lets us say logical name values are unique to UIC so one person
c cannot use another person's passwords unless he can get into that other
c person's account too. Not perfect, but not too bad either.
33	format(z8)
	izzz=1024
	if(dskrec.pswd(1).ne.ih1)rjcode =jior(rjcode,izzz)
	if(dskrec.pswd(1).ne.ih1)goto 9000
	if(dskrec.pswd(2).ne.ih2)rjcode =jior(rjcode,izzz)
	if(dskrec.pswd(2).ne.ih2)goto 9000
1000	continue
	isaccok=1
	return
9000	continue
	isaccok=0
	return
	end
c	call itmchk(ttyspb,ttyspl,'K(',dskrec.lists,igot)
	subroutine itmchk(selst,sell,bgnstr,lists,igot)
	character*256 selst
	character*2 bgnstr
	include '($strdef)'
	integer*4 sell,igot
	character*1536 lists,mylst
	integer*4 str$match_wild
	external str$match_wild
c find if patterns in lists match selst(:sell). Return igot=1 if so, else 0
c If the character & exists, skip the test...set igot = -1
	igot=0
	iptns=index(lists,bgnstr)
	if(iptns.le.0.or.iptns.ge.1536)goto 999
	mylst=lists(iptns+2:)
	myll=index(mylst,')')
	if(myll.le.0.or.myll.ge.1536)goto 999
	mylst=mylst(:myll-1) // ','
	if(index(mylst,'&').gt.0)then
	  igot = -1
	  return
	endif
c strip off comma delimited list elements one at a time.
10	continue
	ill=ivlen(mylst,1536)
	icomm=index(mylst,',')
	if(icomm.gt.ill.or.icomm.le.0)goto 999
	lll=str$match_wild(selst(:sell),mylst(:icomm-1))
	if(lll.eq.str$_match)goto 900
	if(icomm.ge.ill)goto 999
	mylst=mylst(icomm+1:)
	goto 10
900	continue
	igot=1
999	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
	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
	if (i2x(1).ne.i2tst(2))then
c file size changed. No need to read the codes.
	close(unit=10)
	ics1=i4tst+1000
	ics2=i2sv+511
	return
	endif
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 '($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 '($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
	integer*4 function delfilt(buf,vchn)
	integer*4 buf(100),vchn
	integer*4 bbuf(100)
c Insert a common field to allow control of capabilities
	integer*4 icapab(12)
	common/ilicc/icapab
	integer*4 rjcode
	common/rjcod/rjcode
c delete filter function. Should return even status if access
c is disallowed.
c buf+56 = size needed
c buf+8 = dvc name (counted)
c buf+88 = alloclass
c buf+92,96=nodename
c buf+60,64=fid
c Define our database info. Keep the info in a nice big ISAM file
c indexed by file ID.
	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
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 
c
	  end map
	  map
	    character*1712 ch
	  end map
	 end union
	end structure
	record /jtdb/dskrec
	byte wknm(16)
	integer*4 wkn4(4),idwrk(2),ldelc
	integer*4 deldo
	external deldo
	character*8 cidwrk
	integer*2 i2dw(4)
	equivalence(i2dw(1),idwrk(1))
	equivalence(idwrk(1),cidwrk)
	character*16 cwknm
	character*256 cw1,cw2,cwa1,dbnam,cdelc,dbnam2
	equivalence (cwknm,wknm(1),wkn4(1))
	character*256 dbnshr,delfnm
	character*512 ofilsp
	integer*4 lib$cvt_from_internal_time
	external lib$cvt_from_internal_time
	integer*4 ldbnshr,lib$fid_to_name
	external lib$fid_to_name
	common/dbns/ldbnshr,dbnshr
	integer*2 ufid(4)
	integer*4 ufid4(2)
	equivalence(ufid(1),ufid4(1))
	character*256 cwrkn,cwfid
	character*256 uace,mdace
	equivalence (cwrkn,cwknm)
	integer*4 lib$sys_trnlog,sys$check_access
	external lib$sys_trnlog,jtspawn,sys$check_access
	character*128 cdrok,dvcnm
	character*700 delshv
	character*32 cxlgn,rjasc
	integer*4 exttrnlnm
	external exttrnlnm
	integer*4 lcdrok,jdid(2)
c epid in buf+92, ipid in buf+88
c that's buf(23) & buf(24)
	integer*4 sys$getjpiw
	external sys$getjpiw
	integer*4 pidext,jpi3(6),iosb(2),jul,ccol
	integer*2 jpi32(12)
	logical lexist
	equivalence(jpi3(1),jpi32(1))
	integer*4 ipi3(12),idelsh
	integer*2 ipi32(24)
	equivalence(ipi3(1),ipi32(1))
	parameter lib$k_julian_date=20
	parameter lib$k_second_of_day=16
	include '($jpidef)'
	include '($acldef)'
	include '($chpdef)'
	include '($armdef)'
	include '($psldef)'
	character*12 jpiusr
	character*256 shlvfl
	integer*4 mymode,mode,majmode
	external mymode
	imspecial=0
c if imspecial is 1 this means deleting fid 5,20
c (that means 1310725 in id(1), 0 in id(2) )
	delfilt=1
	idelsh=0
c	icapab(1)= -1
c set up acc chk itmlst
	ipi32(1)=4
	ipi32(2)=chp$_access
	ipactyp=arm$m_delete
	ipi3(2)=%loc(ipactyp)
	ipi3(3)=0
	ipi32(7)=4
	ipi32(8)=chp$_FLAGS
	irwacx=chp$m_read+chp$m_write
	ipi3(5)=%loc(irwacx)
	ipi3(6)=0
	ipi3(7)=0
	ipi3(8)=0
	ipi3(9)=0
c set up item list to get username
	jpi32(1)=12
	jpi32(2)=jpi$_username
	jpi3(2)=%loc(jpiusr)
	jpi3(3)=%loc(jul)
	jpi3(4)=0
	jpi3(5)=0
	jpi3(6)=0
	pidext=buf(24)
c mymode returns mode bits. Meanings:
c Bit   Meaning
c 0-1   0 = use .COM file
c       1 = use rename mode
c       2 = use copy (callable cvt) mode
c       3 = copy and add softlink. No database file genn'd
c 2     If set don't delete ANYthing immediately
c 3     If set don't include only included names
c 4     If set, delete file if no room for rename/copy
c       If clear, leave file alone if copy area is full (return error though)
c 5     If set, no timetag on deleted files (use if using softlink...)
c 7	If set, delete files in shelf area as well, if they exist.
	mode=mymode()	
c 9     If set overrides bit 4 so del_shelved can be called, still fakes
c		success in user's delete
c 10    If set, inhibits delete of database entry when deleting via del_shelved
c 12	If set, then when one deletes FID (5,20,0) (which doesn't exist)
c		then run @gcy$sys:dps_process_deletes so that deletions
c		can be handled right then. (The sequential record is left
c		normally closed.) The delete of fid (5,20,0) is faked then.
c isolate "major mode", i.e., first 2 bits.
	majmode=mode .and. 3
	ldvcn=mod(buf(8),256)
c buf(8) = dvc name, counted
c 6 = unit no
	do 30 n=1,100
	bbuf(n)=buf(n)
30	continue
	wkn4(1)=buf(26)
	wkn4(2)=buf(27)
	cw1=cwrkn(2:wknm(1)+1) ! nodename, 6 chars or less
	ccol=index(cw1,':')
c strip any ":" from nodename
	if(ccol.gt.0.and.ccol.lt.8)cw1=cw1(:ccol-1)
	lcw1=ivlen(cw1,6)
	wkn4(1)=buf(3)
	wkn4(2)=buf(4)
	wkn4(3)=buf(5)
	wkn4(4)=buf(6)
	cw2=cwrkn(2:wknm(1)+1) ! device name
	lcw2=ivlen(cw2,22)
c Write name with alloc. class or nodename. Use nodename if allo
c class is zero.
	if(buf(25).eq.0)write(dvcnm,8100)cw1(:lcw1),cw2(:lcw2),
     1  buf(7)
8100	format(a,'$',a,i3.3,':')
	if(buf(25).ne.0)write(dvcnm,8101)buf(25),cw2(:lcw2),buf(7)
8101	format('$',i4.4,'$',a,i3.3,':')
	if(buf(25).eq.0)write(dbnam,100)cw1(:lcw1),cw2(:lcw2),buf(7)
100	format('JTD$DB:OP',a,a,i3.3,'.GDB')
	if(buf(25).ne.0)write(dbnam,101)buf(25),cw2(:lcw2),buf(7)
101	format('JTD$DB:OP',i3.3,a,i3.3,'.GDB')
	ldbn=ivlen(dbnam,256)
	if(buf(25).eq.0)write(dbnam2,9100)cw1(:lcw1),cw2(:lcw2),buf(7)
9100	format('JTD$DB:OP',a,'$',a,'$',i3.3,'.GDB')
	if(buf(25).ne.0)write(dbnam2,9101)buf(25),cw2(:lcw2),buf(7)
9101	format('JTD$DB:OP',i3.3,'$',a,'$',i3.3,'.GDB')
	ldbn2=ivlen(dbnam2,256)
	idwrk(1)=buf(16)
	idwrk(2)=buf(17)
c if FID is missing, grab it off the buffer by using the dir ID and
c the filename
	if(idwrk(1).eq.0)then
	  call fixfid(idwrk,bbuf(31),bbuf(32),bbuf,vchn)
c args are file ID loc, including did 1st word
c	DID 2nd + 3rd word
c	length of fname
c buffer (buffer+128 is start of text)
c	channel number to the disk to use
c Should return file id
	endif
c if imspecial is 1 this means deleting fid 5,20
c (that means 1310725 in id(1), 0 in id(2) )
c delete of FID (5,20,0) is impossible since file number 5 exists only
c as FID (5,5,0) on an ODS2 volume. Use as a flag.
	if(idwrk(1).eq.1310725.and.idwrk(2).eq.0)imspecial=1
c before opening, see if it's open now. If so just leave it. Else
c close & reopen.
	if(ldbnshr.le.0.or.dbnam(1:ldbn).ne.dbnshr(:ldbnshr))
     1 then
	ldbnshr=ldbn
	close(unit=2)
	dbnshr=dbnam(1:ldbn)
        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)
	endif
	iwc=10
8	continue
	i2dw(4)=0
        read(unit=2,fmt=6300,keyeq=cidwrk,
     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)
	iwc=iwc-1
	if(iwc.ge.0)goto 8
	end if
c kios indicates error. Just lose.
	goto 9999
10	continue
	ikflgs=dskrec.kflgs
c mask off flags that filewas moved.
	ikflgs=ikflgs.and.12
c make the access-test code a subroutine so the deletion code can test
c it too.
	isaccok=1
c flag this is a delete daemon call for chkac
	bbuf(1)=1
c buf(29)=1 if driver said we must check, but check all files delete
c access if we get here. For EACF the user can turn delete monitoring
c off completely if he wants not to have it.
	if(imspecial.eq.0)
     1  call chkac(isaccok,bbuf,dskrec,uace,mdace)
c isaccok returns not 1 if access should be denied, 1 if all's well.
c
	if(isaccok.eq.1)then
c Delete the database record if deletion is going to be OK.
c Since DEC checks are not passed yet, don't do this always.
c if logical GCY$DELMNT is the string OK, then allow prompt deletion.
	kkk=lib$sys_trnlog('GCY$DELMNT',lcdrok,cdrok)
	kkk=kkk.and.1
c let mode 8192 bit also indicate we can run this delete operation
	iijjii=mode.and.8192
	if ((kkk.eq.1.and.lcdrok.ge.2.and.
     1  cdrok(1:2) .eq. 'OK').or.(iijjii.ne.0))then
c see if vms would allow the delete.
	delfnm=' '
	ldfnm=1
	lldvc=ivlen(dvcnm,128)
	ufid4(1)=idwrk(1)
	ufid4(2)=idwrk(2)
	kkk=1
	if(imspecial.eq.0)
     1  kkk=lib$fid_to_name(dvcnm(:lldvc),idwrk,delfnm,ldfnm,
     1  ,iacps)
	kkk=kkk.and.1
	kkkk=iacps.and.1
	if(kkk.eq.0.or.kkkk.eq.0)then
c if the backtrace failed, pass a space only. Cmdfile can reject if
c we like, or can just allow the deletion.
	delfnm=' '
	ldfnm=1
	kk1=index(dskrec.lists,'S(')
C If we can't backtrace to get a filename, try using the date file value
c if THAT can be found.
	  if (kk1.gt.0)then
	  kk2=index(dskrec.lists(kk1:),')')
	  if (kk2.gt.0)then
	    kk2=kk2+kk1-1
	    delfnm=dskrec.lists(kk1+2:kk2-1)
	    ldfnm=kk2-kk1-2
	  endif
	  endif
	endif
	jpiusr=' '
c If there IS no such file (could have been deleted out from under us)
c then it's moot whether access is ok. Just claim all ok and let VMS
c fail the access
	inquire(file=delfnm(1:ldfnm),exist=lexist)
	if(.not.lexist)then
	  call tstulk
	  delfilt=1
	  return
	endif
	kkk=sys$getjpiw(%val(2),pidext,,jpi3,iosb,,)
	if(jpiusr(1:1).gt.' '.and.delfnm(1:1).gt.' ')then
c If we got a user name, do the test.
	kkk=1
	if(imspecial.eq.0)
     1  kkk=sys$check_access(acl$c_file,delfnm(:ldfnm),jpiusr,
     1  ipi3)
	kkk=kkk.and.1
c If the user lacks delete access, just claim that things are OK with
c EACF and so on, but do NOT move files around and just let the VMS
c access fail.
	if (kkk.eq.1)then
	  if((mode.and.128).ne.0)then
c Delete the database entry first.
c Find R(shelved file) part of record in the database first if we can.
	  shlvfl=' '
	  lshlvfl=0
	  kk1=index(dskrec.lists,'R(')
	  if (kk1.gt.0)then
	  kk2=index(dskrec.lists(kk1:),')')
	  if (kk2.gt.0)then
	    kk2=kk2+kk1-1
	    shlvfl=dskrec.lists(kk1+2:kk2-1)
	    lshlvfl=kk2-kk1-2
	    write(delshv,804)shlvfl(1:lshlvfl),delfnm(:ldfnm)
804	format('$@GCY$SYS:DEL_SHELVED ',A,' ',A)
	    LDELSHV=IVLEN(delshv,700)
	    idelsh=1
c this stores shelved filename in shlvfl(1:lshlvfl) if lshlvfl > 0
c so we can get it deleted later if the user so desires. Do so in a
c command script we spawn to allow user flexibility.
c pass delfnm(:ldfnm) too so procedure can figure the device out.
	  endif
	  endif
	  endif
	  if((mode.and.1024).eq.0)delete(unit=2)
c Now if the user wants it, we know that the shelved file is OK to
c delete so be sure THAT goes away too.
	endif
c end of "kkk.eq.1"
	endif
	endif
	endif
	unlock(unit=2)
c if EACF isn't licensed, just let things by regardless.
	if(iand(icapab(1),1).eq.0)goto 9999
c if no EACF license, don't reject any deletes.
	if(isaccok.ne.1)goto 9990
9999	continue
c Process deletions if we're doing that.
c eacf and hsm will need ultimately to use different logicals
c and I would treat the spawn capability next as a separate product
c differentiator.
	if((mode.and.4096).ne.0)then
	  if(imspecial.eq.1)then
	    call tstulk
	    kkk = lib$spawn('$@gcy$sys:dps_process_deletes',,,,,,kkkk)
	    delfilt=3
	    return
	  endif
	endif
c Allow operations on file if delete would be ok.
c However, check VMS access too so we don't move files to anywhere if
c the user lacks delete access to them.
c use $getuai...?
c naah... $getjpi is better.
c delfnm is scratch for filename
c 
c As a convenience, we'll allow a process logical in our caller to
c bypass deletion protection (for "delete it NOW, dammit!" situations)
c If the logical GCY$DELNOW is defined as "YES" in the caller's process
c table, then skip deletion protection.
c first test license for DPS
	if(iand(icapab(1),2).eq.0)goto 9880
c if DPS not licensed, just return
c
	kkk=exttrnlnm(pidext,,'GCY$DELNOW','LNM$PROCESS_TABLE',
     1   cxlgn,lcxlgn)
	kkk=kkk.and.1
	if((kkk.ne.0).and.lcxlgn.ge.3.and.
     1  cxlgn(1:3).eq.'YES')goto 9880
c
	delfnm=' '
	ldfnm=1
	lldvc=ivlen(dvcnm,128)
	ufid4(1)=idwrk(1)
	ufid4(2)=idwrk(2)
	kkk=lib$fid_to_name(dvcnm(:lldvc),idwrk,delfnm,ldfnm,
     1  ,iacps)
	kkk=kkk.and.1
	kkkk=iacps.and.1
	if(kkk.eq.0.or.kkkk.eq.0)then
c if the backtrace failed, pass a space only. Cmdfile can reject if
c we like, or can just allow the deletion.
	delfnm=' '
	ldfnm=1
	endif
	jpiusr=' '
	kkk=sys$getjpiw(%val(2),pidext,,jpi3,iosb,,)
	if(jpiusr(1:1).gt.' '.and.delfnm(1:1).gt.' ')then
c If we got a user name, do the test.
	kkk=sys$check_access(acl$c_file,delfnm(:ldfnm),jpiusr,
     1  ipi3)
	kkk=kkk.and.1
c If the user lacks delete access, just claim that things are OK with
c EACF and so on, but do NOT move files around and just let the VMS
c access fail.
c However if the logical GCY$DELFAL is Y then we will do an EACF type
c fail which will allow conditional softlinks if the VMS access is
c denied. Mind this only works where we can find the filename and when
c we can get the username. Otherwise we just let 'er rip...
	kkkk=lib$sys_trnlog('GCY$DELFAL',ldelc,cdelc)
c skip if the logical isn't 'Y' so we can control delete catching
c specially.
	if(kkk.eq.0.and.cdelc(1:1).ne.'Y')goto 9880
	if(kkk.eq.0)goto 9990
	endif
c
c do deletion-saving
	ii=lib$cvt_from_internal_time(lib$k_julian_date,ijul,)
	ii=lib$cvt_from_internal_time(lib$k_second_of_day,isec,)
	write(ofilsp(1:9),1002)ijul
1002	format(i9.9)
	write(ofilsp(10:14),1003)isec
1003	format(i5.5)
c now tack on original file ID so we stay unique diskwide.
	write(ofilsp(15:26),1004)ufid(1),ufid(2),ufid(3)
c now tack on the device name
	ofilsp=ofilsp(:26) // dvcnm(:lldvc-1) // '.SAV'
c now get overall length
	lofs=ivlen(ofilsp,128)
c Now record this deletion if mode allows
	ofilsp= 'delsav:' // ofilsp(:lofs)
	lofs=lofs+7
	write(cwfid,9898)dbnam2(1:ldbn2),idwrk(1),idwrk(2),
     1  delfnm(:ldfnm),ofilsp(:lofs)
	lcwfid=ivlen(cwfid,256)
9898	format('$@gcy$cm:fildel ',a,' ',z8.8,' ',z8.8,' ',a
     1  ,' ',a)
c Fire off cmd to move the file somewhere
	kkk=lib$sys_trnlog('GCY$DELSAV',ldelc,cdelc)
c skip if the logical isn't 'Y' so we can control delete catching
c specially.
	if(cdelc(1:1).ne.'Y')goto 9880
	istat=1
	if(majmode.eq.0)kkk=jtspawn(cwfid(:lcwfid),1)
c	if(majmode.eq.0)kkk=lib$spawn(cwfid(:lcwfid),,,,,,istat)
	if(majmode.eq.0)then
c Open file shared so other daemons can get at it.
	open(unit=14,file='gce$delseq:delrecs.seq',recl=512,
     1  form='formatted',carriagecontrol='list',access='append',
     2  status='old',shared,err=3980)
	goto 3981
3980	continue
c Open file shared so other daemons can get at it.
	open(unit=14,file='gce$delseq:delrecs.seq',recl=512,
     1  form='formatted',carriagecontrol='list',status='new',
     2  shared,err=3981)
3981	continue
c	ii=lib$cvt_from_internal_time(lib$k_julian_date,ijul,)
c	ii=lib$cvt_from_internal_time(lib$k_second_of_day,isec,)
c fill in filespec with time at high order, to the second
c Use delete time since that's what we'll track with.
	write(ofilsp(1:9),1002)ijul
	write(ofilsp(10:14),1003)isec
c now tack on original file ID so we stay unique diskwide.
	write(ofilsp(15:26),1004)ufid(1),ufid(2),ufid(3)
1004	format(3z4.4)
c now tack on the device name
	ofilsp=ofilsp(:26) // dvcnm(:lldvc-1) // '.SAV'
c now get overall length
	lofs=ivlen(ofilsp,128)
c Now record this deletion if mode allows
	ofilsp= 'delsav:' // ofilsp(:lofs)
	lofs=lofs+7
	write(14,1090)ofilsp(:lofs),dvcnm(:lldvc),
     1  delfnm(:ldfnm)
1090	format(a,',',a,',',a)
	close(unit=14)
	endif
	if(majmode.ne.0)istat=deldo(idwrk,mode,
     1  buf,dskrec.lists)
c if bit 2 (mask=4) of mode is set, then don't delete the
c file, but pretend we deleted it OK. This will allow use of a
c command file or the like that queues the files for deletion by
c a separate process, i.e., not necessarily in real time.
	if((istat.eq.3).or.((mode.and.4).ne.0))then
c fake success...
	delfilt=3
	goto 9997
	endif
9880	continue
	delfilt=1
	goto 9997
9990	continue
	delfilt=4096
	goto 9998
9997	continue
c mode 512 bit allows delete of shelved files.
	if (((mode.and.4).ne.0).and.((mode.and.512).eq.0))
     1  goto 9998
c If the mode bit for 128 is set, delete the shelved file too.
	if ((mode.and.128).eq.0)goto 9998
	if(idelsh.eq.0)goto 9998
c We have permission to delete the shelved file, and the identity of
c the file being deleted (container) AND that of the
	call tstulk
	kkk=lib$spawn(delshv(:ldelshv),,,,,,istat)
9998	continue
	return
	end
	integer*4 function extfilt(buf,vchn)
	integer*4 buf(32),vchn
	integer*4 bbuf(32)
c Insert a common field to allow control of capabilities
	integer*4 icapab(12)
	common/ilicc/icapab
	integer*4 rjcode
	common/rjcod/rjcode
c get space on device as needed.
c buf+56 = size needed
c buf+8 = dvc name (counted)
c buf+88 = alloclass
c buf+92,96=nodename
	character*512 wcmd
	integer*4 wkn4(4),ccol
	character*16 cwknm
	character*256 cw1,cw2,cwa1
	byte wknm(16)
	external lib$spawn
	equivalence (cwknm,wknm(1),wkn4(1))
	character*256 cwrkn
	character*256 uace,mdace
	equivalence (cwrkn,cwknm)
c	icapab(1) = -1
	ldvcn=mod(buf(8),256)
c buf(8) = dvc name, counted
c 6 = unit no
c
c extend control goes with DPS
	if(iand(icapab(1),2).eq.0)then
c if DPS not licensed, just return
	extfilt=1
	return
	endif
	do 30 n=1,32
	bbuf(n)=buf(n)
30	continue
	wkn4(1)=buf(24)
	wkn4(2)=buf(25)
	cw1=cwknm(2:wknm(1)+1) ! nodename, 6 chars or less
	ccol=index(cw1,':')
c strip any ":" from nodename
	if(ccol.gt.0.and.ccol.lt.8)cw1=cw1(:ccol-1)
	lcw1=ivlen(cw1,6)
	wkn4(1)=buf(3)
	wkn4(2)=buf(4)
	wkn4(3)=buf(5)
	wkn4(4)=buf(6)
	cw2=cwknm(2:wknm(1)+1) ! device name
	lcw2=ivlen(cw2,15)
c Write name with alloc. class or nodename. Use nodename if allo
c class is zero.
	if(buf(23).eq.0)write(wcmd,100)cw1(:lcw1),cw2(:lcw2),buf(7)
     1  ,buf(15)
100	format('$@GCY$CM:MAKSPC ',a,'$',a,i3.3,' ',i12)
	if(buf(23).ne.0)write(wcmd,101)buf(23),cw2(:lcw2),buf(7)
     1  ,buf(15)
101	format('$@GCY$CM:MAKSPC $',i3.3,'$',a,i3.3,' ',i12)
	ldbn=ivlen(WCMD,256)
c spawn a command to get space on the device. Just make a best
c effort here; if it can't get room, allocation will just fail.
	ixx=lib$spawn(wcmd(:ldbn),,,,,,istat)
	extfilt=1
	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
	subroutine getfnm(numfil,nums,nmax,ngot)
	character*(*) numfil
	integer*2 nums(nmax)
	integer*4 ngot,i4
	integer*2 i2(2)
	equivalence(i2(1),i4)
c read numfil to get file numbers to kernel-tag
c This file is just a list of file numbers to be tagged. To facilitate
c maintenance presume the list is generated by dir/file or some
c variant thereof. Skip lines unless "(" is seen and parse for
c 3 numbers, a file id.
	character*256 rec
	nnum=0
	open(unit=15,file=numfil,form='formatted',recl=256,
     1  status='old',readonly,err=999)
100	continue
	read(15,1000,end=900,err=900)rec
1000	format(a)
	if(index(rec,'(').le.0)goto 100
	llo=index(rec,'(')+1
	lhi=index(rec,')')-1
	if (lhi.le.llo)goto 100
c got ( ) in the right order. Try and read 3 pieces of id now.
	read(rec(llo:lhi),2000,err=100)iif1,iif2,iif3
2000	format(3i)
c record a file number. Take low 16 bits of file number only for large
c ones, using equivalence trick to avoid generating over or underflow errs
	i4=iif1
	nnum=nnum+1
	nums(nnum)=i2(1)
	ngot=ngot+1
	if (nnum.lt.nmax)goto 100
900	continue
c done. Close the data file.
	close(unit=15)
999	continue
	return
	end
	subroutine getfnb(numfil,nums,nmax,ngot)
	character*(*) numfil
	integer*2 nums(nmax)
	integer*4 ngot,i4
	integer*2 i2(2)
	equivalence(i2(1),i4)
c read numfil to get file numbers to kernel-tag
c This file is just a list of file numbers to be tagged. To facilitate
c maintenance presume the list is generated by dir/file or some
c variant thereof. Skip lines unless "(" is seen and parse for
c 3 numbers, a file id.
	character*256 rec
	nnum=0
	open(unit=15,file=numfil,form='formatted',recl=256,
     1  status='old',readonly,err=999)
100	continue
	read(15,1000,end=900,err=900)rec
1000	format(a)
	if(index(rec,'(').le.0)goto 100
	llo=index(rec,'(')+1
	lhi=index(rec,')')-1
	if (lhi.le.llo)goto 100
c got ( ) in the right order. Try and read 3 pieces of id now.
	read(rec(llo:lhi),2000,err=100)iif1,iif2,iif3
2000	format(3i)
c record a file number. Take low 16 bits of file number only for large
c ones, using equivalence trick to avoid generating over or underflow errs
	i4=iif1
	nnum=nnum+1
c set the bitmap bit so we can mark EVERYthing!!!
c (Note later we'll allow writing this whole map out in binary and
c load from that.)
	call vbset(nums,iif1)
c	nums(nnum)=i2(1)
	ngot=ngot+1
c	if (nnum.lt.nmax)goto 100
	goto 100
900	continue
c done. Close the data file.
	close(unit=15)
999	continue
	return
	end
	subroutine loglatch(igot)
c return igot=1 else 0
c see if access is OK
	integer*4 igot
	character*20 clognm
	character*80 wcmd
	integer*4 ii
	external lib$sys_trnlog,lib$set_logical
        external lib$get_foreign
	igot=0
c 
c now store the logical
c (note: if we need to make it a system or group logical, dcl can do this.)
c
	ii=lib$sys_trnlog('EACF_LE$$',kk,wcmd)
	if ((ii.and.1).NE.0)then
	igot=1
	return
	end if
	ii=lib$set_logical('EACF_LE$$','T','LNM$SYSTEM',,)
	return
	end
	subroutine getexf(efile)
	character*256 efile
c load "exempt" file specs
c Allows up to 32 "exempt" images to be loaded which can be tested
c so that opens BY those images will be allowed to pass with NO EACF
c controls. Do this for things like disk defraggers and the like which
c we don't want to interfere with and yet want security on. This allows
c the images to have free access, yet access TO those images can be
c controlled.
	integer*4 nefile
	character*512 efiles(32)
	common/exfl/nefile,efiles
	lefi=ivlen(efile,250)
	open(unit=20,file=efile(:lefi),recl=512,form='formatted',
     1  status='old',err=9999)
	nefile=0
	do 100 n=1,32
	read(20,1000,end=200,err=200)efiles(n)
1000	format(a)
	nefile=n
100	continue
200	continue
9999	continue
	close(unit=20)
	return
	end
	subroutine rj2asc(icode,imsg)
c convert rjcode binary codes to text
c (This also serves to document the codes)
	integer*4 icode
	character*32 imsg
	imsg=' '
	if((icode.and.0001).ne.0)imsg='Time of Day Access reject'
	if((icode.and.0002).ne.0)imsg='Privs too high for access'
	if((icode.and.0004).ne.0)imsg='User on forbid. user list'
	if((icode.and.0008).ne.0)imsg='User not on permit list'
	if((icode.and.0016).ne.0)imsg='Image on forbid. img list'
	if((icode.and.0032).ne.0)imsg='Image not on permit list'
	if((icode.and.0064).ne.0)imsg='Terminal on forbid list'
	if((icode.and.0128).ne.0)imsg='Accport on forbid list'
	if((icode.and.0256).ne.0)imsg='Term or accpor not permit'
	if((icode.and.0512).ne.0)imsg='File tamper checksum fail'
	if((icode.and.1024).ne.0)imsg='File password not entered'
	if((icode.and.2048).ne.0)imsg='User filter routine rejct'
	return
	end
	integer function igetcap
c Insert a common field to allow control of capabilities
	integer*4 imask,kkk
	integer*4 icapab(12)
	integer*4 jtglmsk
	external jtglmsk
	common/ilicc/icapab
	igetcap=0
	icapab(1) = -1
c call license code here if we have any
c bit 0 (mask=1) means EACF is licensed
c bit 1 (mask=2) means DPS is licensed
c bit 2 (mask=4) means HSM is licensed
	kkk = jtglmsk(imask)
c check magic number from the license system so we know if that has
c been tampered with. If someone replaces jtglmsk with some random
c routine, magic code is unlikely to come back and we detect it here
c and get no further. The return code "vector in use" is deliberately
c obscure and if anyone calls in with that error, we can know that
c they've been trying to disable licensing and treat them accordingly.
c Real license expiration errors are different.
	icapab(1) = imask
c Get the function mask from the license system. Initial default is that
c all capabilities are there, but licensor can change that.
	if (kkk.ne. 6712)call exit(588)
c ss$_vecinuse if the license seems to have been tampered with
	igetcap=icapab(1)
c if testing in jtdmn, no need to test here.
c However if we return any nonzero number it may mean something and
c so preserve it. Thus if user buys a license for undelete, leave
c that alone.
	if(icapab(1).eq.0)icapab(1)= -1
	return
	end
	subroutine setcap1
	integer*4 icapab(12)
	common/ilicc/icapab
	icapab(1) = -1
c set all capabilities on
	return
	end
	subroutine kgetks(key)
	character*(*) key
	integer*4 kints(6)
c convert key value to binary and call the key generator
	read(key,1,err=99)kints
1	format(6z8.8)
c OK, looks like the data was read in OK. Call the key generator and
c enter the key.
	call kgetki(kints)
	return
99	continue
	write(6,2)
2	format(' Key error. Key appears invalid in form. Unentered.')
	return
	end
	subroutine tstulk
c test for file open and if it is, be sure it has no record locks.
c Use to be sure no locks are held after a routine exits.
	logical isopn
	inquire (unit=2,opened=isopn)
	if (.not. isopn) return
	unlock (unit=2,err=999)
999	return
	end