c Registry info c c Arguments: c mskacc - Type of access requested. This is a bitmask where the bits c have values as follows: c 1 - read access requested c 2 - write access requested c 4 - delete access requested c 8 - Control access requested c 16 - Execute access requested c 32 - Change Owner access requested c 64 - forbidden (corresponds to ACL "No Access" bit) c 128 - forbidden (corresponds to ACL "inheritable" bit c for directories) c 256 - forbidden (corresponds to ACL "system" bit) c c ACL entries are 8 bytes long each and have these bits in their low c longword, with an identifier or UIC in the high c longword. The special pseudo UIC values have the c following meanings: c -1 = "everybody", i.e., an ACE applying to -1 applies to all c possible users c -2 = "owner", applies to file owner (as recorded in the registry, c not necessarily the VMS owner). c c c iuic - UIC of user requesting the access. This is just the VMS UIC for c simplicity. The registry handled herein contains the group c members this user belongs to (though -1 is implicit) and c the user's default system and user ACLs, if any. c This does require that VMS users be coordinated with NT users, c but for sensible operation this is needed anyway. c c ifid - File ID of the file for which access check is requested. If the c file does not exist, its parent access is checked (via idid). This c is the case for create as a general matter. This returns with a unique c file ID value for created files so that when the file is created c the record can be read and written to the correct FID value. c d idid - directory ID for directory containing the file. This is treated as c the file's parent (and is initialized in this way) for when a file c is created. c defacl - returns with the default ACL for a user (both system and user) c from either the user's database in the registry, or from the c inheritable parts of the ACL of the parent. (In fact this may c return the entire record, but it is not heavily used bu callers c since for new files, file ID (5,0) is filled in with all data c so this "reserved" file's entry can be just copied once a file c has actually been created. The record may contain a command, which c is spawned if present when the file is accessed. This facility c is more of a placeholder than anything else. Currently there c is no attempt to run the routine in the context of the user c accessing the file. A non-demo system would need to do this, or c abandon the effort. c c regnam is a string that contains a base filename for this device's c registry files. We can append _user or _ntfile or similar c strings to get the filenames we need. c c c c PROGRAM NTUFMNT c c Maintain NT security model user and/or file records. c This program is intended to be the maintaining engine which controls c the contents of the NT check routine's "user" and "file" databases c c As such, it must check the "control" access rights a user has c before allowing modification. In real NT, there would also be c the possibility of override privs for a user. For this demo version c however we won't bother with this, but will instead presume that anyone c coming in with a "system" class UIC has this privilege, or that a user c with "SYS" in his name is authorized. Owners of files are also allowed c full access, regardless. c c The routine may be run by a systems person and he can enter system c ACL elements etc., or by a user himself in which case he can create c or modify records for files he owns. c c It is presumed and required, to keep things halfway sensible, that c the VMS UIC value can be used to identify a user and that files c will be marked by VMS as owned by that user if they are to be c accessed. This means the VMS code for identifying a user will basically c be used. If we need to directly authenticate users on other nodes c we will have to connect to authenticators on the source systems. c c This routine is intended as a skeleton demo of sorts, however, so c that it isn't intended to contain EVERYTHING the final system will, just c a start at it. integer*4 iosb(2),jpiitm(3,7),KIOS integer*2 jp2itm(6,7) equivalence(jpiitm(1,1),jp2itm(1,1)) integer*2 ifid(4),idid(4) integer*4 i4fid(2),i4did(2) equivalence(ifid(1),i4fid(1)) equivalence(idid(1),i4did(1)) integer*4 filsiz common/ffiidd/ifid,filsiz,idid integer*4 mskacc,iuic,fgetfid external fgetfid integer*4 defacl(512) character*256 regnam external lib$spawn integer*4 def2(512),deflen character*256 defcmd equivalence(defcmd,def2(448)) equivalence(deflen,def2(447)) character*256 dfc,dfc2 integer*4 idfc(64) integer*2 i2dfc(128) equivalence(idfc(1),dfc,i2dfc(1)) c Define our database info. Keep the info in nice big ISAM files c indexed by file ID for files, by UIC for user file. structure /jtus/ union map integer*4 uic ! UIC = ISAM index integer*4 ifid(2) ! file ID integer*4 idid(2) ! directory ID integer*4 kflgs ! flags for file treatment c flags: 1 = use DID's ace etc. c 2 = command exists c To avoid wasting space we pack the ACE and command into a large byte c array, so that the file need not be filled with blanks we don't c need. The area contains the user's group list, his default ACE, if c any, and his default command for file opening if any (and usually c there will be none here). integer*2 grplst,grplen integer*2 acedef,acelen,defcmd,deflen ! subscripts of lists, or 0 if missing Integer*4 ACEs(399) ! misc. stuff, all encoded in a string end map map character*1632 ch end map end union end structure record /jtus/usrrec record /jtus/usrwrc structure /jtfl/ union map character*32 fidnam !file id / dvcname c integer*4 ifid(2) ! file ID = ISAM index integer*4 uic ! UIC integer*4 idid(2) ! directory ID integer*4 kflgs ! flags for file treatment c flags: 1 = use DID's ace etc. c 2 = command exists c To avoid wasting space we pack the ACE and command into a large byte c array, so that the file need not be filled with blanks we don't c need. The area contains the user's group list, his default ACE, if c any, and his default command for file opening if any. integer*2 grplst,grplen integer*2 acedef,acelen,defcmd,deflen ! subscripts of lists, or 0 c if missing c We in fact store these lists in longword chunks so make 'em easy to c get at without (yet) abother union. integer*4 ACEs(399) ! misc. stuff, all encoded in a string end map map character*1712 ch end map map integer*4 i4ch end map end union end structure c record max size = 1632/4 = 408 longs in size. record /jtfl/filrec record /jtfl/filwrk c Note: c The code in ntchk will deal with telling whether some access is OK or c not, according to NT rules (at least approximately). It is presumed c that utilities that can alter the data in the registry files will c be written, but that they will use this routine (or a clone thereof) c and check for control access permission (or "being owner" permission c or the like) prior to making changes. They should also check the NT c idea of "privileges" before proceeding. It is further presumed that c something like normal EACF access checks will keep the database c files from being accessible by anything except these trusted images. c c Use $getjpi to read privs, uic, etc. include '($dvidef)' include '($jpidef)' include '($acldef)' include '($acedef)' integer*4 ownuic common/fown/ownuic integer*4 accporl,iprv(2),lprvs common/kiuic/iuic Integer*4 lib$sys_trnlog,lib$get_foreign External lib$sys_trnlog,lib$get_foreign character*256 imgspb,rgu,rgf character*512 wrkarg,wrkfnm integer*4 ccol,lluic,cmdlen integer*4 unaml,ttyspl,imgspl character*32 ttyspb,unamb,rjasc character*64 accpor,wrkchr common/jpijunk/ttyspb,ttyspl,imgspb,imgspl,unamb 1 ,unaml,accpor,accporl integer*4 sys$getjpiw external sys$getjpiw character*250 cmdlin jp2itm(1,1)=32 c find where this user is jp2itm(2,1)=JPI$_TT_PHYDEVNAM jpiitm(2,1)=%loc(ttyspb) jpiitm(3,1)=%loc(ttyspl) jp2itm(1,2)=256 c find what he's running (not really needed...he's running this) jp2itm(2,2)=JPI$_IMAGNAME jpiitm(2,2)=%loc(imgspb) jpiitm(3,2)=%loc(imgspl) jp2itm(1,3)=32 c get his username to look for SYS in it. jp2itm(2,3)=JPI$_USERNAME jpiitm(2,3)=%loc(unamb) jpiitm(3,3)=%loc(unaml) c Find where he is if on VT or LAT etc. 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 Get his UIC c jpiitm(1,5)=0 jp2itm(1,5)=4 jp2itm(2,5)=JPI$_UIC jpiitm(2,5)=%loc(iuic) jpiitm(3,5)=%loc(lluic) c Get his privs 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 Read all this stuff. If we cannot, exit. kk=sys$getjpiw(%val(1),,,jpiitm,iosb,,) if((kk.and.1).eq.0)goto 9999 c c USAGE: c c NTAUTH U=UIC (or U) c sets up a user record after displaying what'sthere. c c NTAUTH F=filespec c sets up a file record after displaying what's there. c (bailout will be there.) c User record must exist before file record can be handled. c c Call with filename set as for authmaint, i.e. using f$search to get c the full filespec including device. (Again, a final utility needs c a bit more sophistication.) c c This is intended to be quick 'n' dirty but workable. NOT, repeat, NOT c elegant. c 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 c Get database info. First getthe files open. if((cmdlin(1:2).eq.'U=').or.(cmdlin(1:2).eq.'F=')) 1 goto 6009 goto 6999 6009 continue c Following are the filenames. rgu='GCY$CM:NTREGIST.REG_USR' rgf='GCY$CM:NTREGIST.REG_FIL' lnrg=23 open(unit=12,file=rgu(:lnrg),organization='INDEXED', 1 access='keyed',shared,recordtype='variable', 2 recl=1632,form='formatted',blocksize=16384,buffercount=3, 3 key=(1:4:integer),status='unknown',err=9998) open(unit=13,file=rgf(:lnrg),organization='INDEXED', 1 access='keyed',shared,recordtype='variable', 2 recl=1712,form='formatted',blocksize=16384,buffercount=3, 3 key=(1:32:character),status='unknown',err=9998) if(cmdlin(1:2).eq. 'U=')then c user record setup c uic is gg,uu isysu=0 if ((iuic.and.65535).lt.8)then isysu=1 c system user. Ask again for uic write(6,100)iuic 100 format('$Curr. UIC=',z8.8,' Enter new one if desired, hex>') read(5,101,err=105)kkuic 101 format(z) iuic=kkuic 105 continue endif c now iuic should be desired uic. 140 continue read(unit=12,fmt=6300,keyeq=iuic,keyid=0, 1 iostat=kios)usrrec.ch 6300 format(a) c Wait if the record is busy if(kios.eq.52) then c locked record...wait & retry xtim=4.0 call lib$wait(xtim) goto 140 end if igotu=0 if(kios.eq.0)igotu=1 c Now we have this user record (or none) c If none, create one later. if(igotu.eq.0)then c Create a default record usrrec.uic=iuic usrrec.grplst=0 usrrec.grplen=0 usrrec.kflgs=0 usrrec.acedef=0 usrrec.acelen=0 usrrec.defcmd=0 usrrec.deflen=0 write(unit=12,fmt=6300)usrrec.ch(1:40) goto 140 endif c c The following rather ugly code is designed to fill in the c fields for ACEs, groups etc. c c first find what groups this user is in. These are just longs that c hold uic or identifier values. ipos=1 iini=1 200 continue write(6,3330) 3330 format('$ Enter group, hex, 0 to end:') read(5,101)kgp if(kgp.ne.0)then usrrec.aces(ipos)=kgp ipos=ipos+1 endif usrrec.grplst=1 usrrec.grplen=usrrec.grplen+4 if (kgp.ne.0)goto 200 iini=ipos write(6,3331) 3331 format(' RWDCEONIS = rd,wrt,del,ctl,exe,OwnChg,NoAcc,Inh,Sys') 202 continue c get ace in c wrkarg is char*64 Write(6,3332) 3332 format('$Enter def ACE flags or Q if done:') read(5,6300)wrkarg IQT=0 jflgs=0 if (index(wrkarg,'X').gt.0.or.index(wrkarg,'x').gt.0)iqt=1 if (index(wrkarg,'Q').gt.0.or.index(wrkarg,'q').gt.0)iqt=1 if(iqt .eq. 0)then if(index(wrkarg,'R').gt.0.or.index(wrkarg,'r').gt.0) 1 jflgs=jflgs+1 if(index(wrkarg,'W').gt.0.or.index(wrkarg,'w').gt.0) 1 jflgs=jflgs+2 if(index(wrkarg,'D').gt.0.or.index(wrkarg,'d').gt.0) 1 jflgs=jflgs+4 if(index(wrkarg,'C').gt.0.or.index(wrkarg,'c').gt.0) 1 jflgs=jflgs+8 if(index(wrkarg,'E').gt.0.or.index(wrkarg,'e').gt.0) 1 jflgs=jflgs+16 if(index(wrkarg,'O').gt.0.or.index(wrkarg,'o').gt.0) 1 jflgs=jflgs+32 if(index(wrkarg,'N').gt.0.or.index(wrkarg,'n').gt.0) 1 jflgs=jflgs+64 if(index(wrkarg,'I').gt.0.or.index(wrkarg,'i').gt.0) 1 jflgs=jflgs+128 if(index(wrkarg,'S').gt.0.or.index(wrkarg,'s').gt.0) 1 jflgs=jflgs+256 write(6,3333) 3333 format('$ Enter user/grp ID or -1=all, -2=own, hex (z8):') read(5,101)kgp if(kgp.ne.0.and.jflgs.ne.0)then usrrec.aces(ipos)=jflgs ipos=ipos+1 usrrec.aces(ipos)=kgp ipos=ipos+1 usrrec.acelen=usrrec.acelen+8 endif endif usrrec.acedef=iini*4 + 1 iini=ipos c Now get the default command if any write(6,3334) 3334 format('$Want a command [Y/N][N]:') read(5,6300)wrkarg if(wrkarg(1:1).eq.'Y')then write(6,3335) 3335 format('$Enter cmd:') read(5,6300)dfc ldc=ivlen(dfc,255) if(ldc.gt.3)then ildc=(ldc+3)/4 do 40 n=1,ildc usrrec.aces(ipos)=idfc(n) ipos=ipos+1 40 continue usrrec.deflen=ldc usrrec.defcmd=iini*4+1 endif endif c Write out all that has been set into the record here. lur=ivlen(usrrec.ch,1632) rewrite(unit=12,fmt=6300)usrrec.ch(1:lur) endif ! u= if(cmdlin(1:2).eq.'F=')then c file record setup dfc2=cmdlin(3:) ldfc=ivlen(dfc2,255) isysu=0 if ((iuic.and.65535).lt.8)then isysu=1 c system user. Ask again for uic write(6,100)iuic read(5,101,err=405)kkuic iuic=kkuic 405 continue endif c get the file id. c use useropen to get file ID ifid(1)=0 ifid(2)=0 ifid(3)=0 ifid(4)=0 open(unit=3,file=dfc2(:ldfc),err=9898,status='old', 1 useropen=fgetfid,readonly) 9898 continue close(unit=3) c Now ifid has the file id...if it got anywhere. if(ifid(1).ne.0.or.ifid(2).ne.0.or.ifid(3).ne.0.or.ifid(4) 1 .ne.0)then c fid is nonzero, so go ahead. c create the index. i2dfc(1)=ifid(1) i2dfc(2)=ifid(2) i2dfc(3)=ifid(3) i2dfc(4)=ifid(4) c we use 64 bits for fid internally. icl=index(dfc2,':') - 1 if (icl.gt.0)dfc2=dfc2(1:icl) dfc(9:32)=dfc2(1:24) c c index is now prepared. c 240 continue read(unit=13,fmt=6300,keyeq=dfc(1:32),keyid=0, 1 iostat=kios)filrec.ch c Wait if the record is busy if(kios.eq.52) then c locked record...wait & retry xtim=4.0 call lib$wait(xtim) goto 240 end if igotf=0 if(kios.eq.0)igotf=1 c if no record is there, build a default. if(igotf.eq.0)then filrec.fidnam=dfc(1:32) filrec.uic=iuic c Put in the parent directory ID too. c (At least we can get that automatically!) filrec.idid(1)=i4did(1) filrec.idid(2)=i4did(2) filrec.kflgs=0 filrec.grplst=0 filrec.grplen=0 filrec.acedef=0 filrec.acelen=0 filrec.defcmd=0 filrec.deflen=0 write(unit=13,fmt=6300)filrec.ch(1:64) goto 240 endif !igotf c Now we have a default record anyhow. c No group list here...just get the ACE if any. iini=1 ipos=1 write(6,3336) 3336 format(' RWDCEONIS = rd,wrt,del,ctl,exe,OwnChg,NoAcc,Inh,Sys') 402 continue c get ace in c wrkarg is char*64 Write(6,3337) 3337 format('$Enter def ACE flags or Q if done:') read(5,6300)wrkarg IQT=0 jflgs=0 if (index(wrkarg,'X').gt.0.or.index(wrkarg,'x').gt.0)iqt=1 if (index(wrkarg,'Q').gt.0.or.index(wrkarg,'q').gt.0)iqt=1 if(iqt .eq. 0)then if(index(wrkarg,'R').gt.0.or.index(wrkarg,'r').gt.0) 1 jflgs=jflgs+1 if(index(wrkarg,'W').gt.0.or.index(wrkarg,'w').gt.0) 1 jflgs=jflgs+2 if(index(wrkarg,'D').gt.0.or.index(wrkarg,'d').gt.0) 1 jflgs=jflgs+4 if(index(wrkarg,'C').gt.0.or.index(wrkarg,'c').gt.0) 1 jflgs=jflgs+8 if(index(wrkarg,'E').gt.0.or.index(wrkarg,'e').gt.0) 1 jflgs=jflgs+16 if(index(wrkarg,'O').gt.0.or.index(wrkarg,'o').gt.0) 1 jflgs=jflgs+32 if(index(wrkarg,'N').gt.0.or.index(wrkarg,'n').gt.0) 1 jflgs=jflgs+64 if(index(wrkarg,'I').gt.0.or.index(wrkarg,'i').gt.0) 1 jflgs=jflgs+128 if(index(wrkarg,'S').gt.0.or.index(wrkarg,'s').gt.0) 1 jflgs=jflgs+256 write(6,3338) 3338 format('$ Enter user/grp ID or -1=all, -2=own, hex (z8):') read(5,101)kgp if(kgp.ne.0.and.jflgs.ne.0)then filrec.aces(ipos)=jflgs ipos=ipos+1 filrec.aces(ipos)=kgp ipos=ipos+1 filrec.acelen=filrec.acelen+8 endif endif filrec.acedef=iini*4 + 1 iini=ipos c Now get the default command if any write(6,3339) 3339 format('$Want a command [Y/N][N]:') read(5,6300)wrkarg if(wrkarg(1:1).eq.'Y')then write(6,3340) 3340 format('$Enter cmd:') read(5,6300)dfc ldc=ivlen(dfc,255) if(ldc.gt.3)then ildc=(ldc+3)/4 do 2402 n=1,ildc filrec.aces(ipos)=idfc(n) ipos=ipos+1 2402 continue c set up start & size of default command. filrec.deflen=ldc filrec.defcmd=iini*4+1 endif endif c Write out all that has been set into the record here. lur=ivlen(filrec.ch,1632) rewrite(unit=13,fmt=6300)filrec.ch(1:lur) endif !fid nonzero endif !f= 6999 continue 9998 continue close(unit=12) close(unit=13) 9999 continue call exit 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),idid(4) integer*4 filsiz,sys$open external sys$open common/ffiidd/ifid,filsiz,idid 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 getfiddid(fab,ifid,idid) 9999 fgetfid=istat 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 c------------------------------------------------------------ c Call this routine as a useropen to find a file's owner UIC. c Then close the file. Presumes privs. Integer Function Priv_UserOpen(FAB,RAB,Unit) c open a system file with privilege. Include '($RMSDEF)/nolist' Include '($SYSSRVNAM)/nolist' Include '($FABDEF)/nolist' Include '($RABDEF)/nolist' Include '($xabDEF)' Include '($XABPRODEF)' Record /FABDEF/Fab, /RABDEF/ rab Record /XABPRODEF1/ xabpro Integer*4 LUIC Common /xab_uic/ LUIC common/fown/ownuic External XABSET, XABGET Integer Privilege(2) /0,0/ c Byte FAB$B(0:119) c Integer RAB(30) c Integer*4 Sys$Open, Sys$Connect ![rph] 01-06-88 Integer Unit c set Logical name access to EXEC mode FAB.FAB$B_ACMODES = FAB.FAB$B_ACMODES .or. 1 1 c 1 ( (1) * 2**FAB$V_LNM_MODE) ! require EXEC mode c fab$V_lnm_mode = 0 so omit ref since define includes double def it c set up xab c If (FlgUIC .ne. 0 ) then Call XABSET( %VAL (fab.FAB$L_XAB)) c EndIf c open file iii = Sys$Open(FAB) c If (FlgUIC .ne. 0) then If (iii .eq. rms$_NORMAL) then iii= SYS$DISPLAY(fab) Call XABGET (%VAL ( fab.FAB$L_XAB)) OwnUIC=LUIC End IF c End if c End If If ( .not. iii ) Then Priv_UserOpen = iii Return EndIf c connect Priv_UserOpen = Sys$Connect(RAB) Return End SUBROUTINE XABGET ( xabpro ) C c INCLUDE 'XABPRODEF.INC' Include '($XABPRODEF)' C RECORD /XABPRODEF1/ xabpro C INTEGER*4 l_uic C COMMON /XAB_UIC/ l_uic C l_uic = xabpro.XAB$L_UIC 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 XABSET ( xabpro ) C PARAMETER XAB$C_PRO = '00000013'X ! xabpro id code PARAMETER XAB$M_NOREAD = '00000001'X PARAMETER XAB$M_NOWRITE = '00000002'X PARAMETER XAB$M_NOEXE = '00000004'X PARAMETER XAB$M_NODEL = '00000008'X STRUCTURE /XABPRODEF/ UNION MAP PARAMETER XAB$S_NOREAD = 1 PARAMETER XAB$V_NOREAD = 0 ! deny read access PARAMETER XAB$S_NOWRITE = 1 PARAMETER XAB$V_NOWRITE = 1 ! deny write access PARAMETER XAB$S_NOEXE = 1 PARAMETER XAB$V_NOEXE = 2 ! deny execution access PARAMETER XAB$S_NODEL = 1 PARAMETER XAB$V_NODEL = 3 ! deny delete access BYTE %FILL (1) END MAP END UNION END STRUCTURE ! XABPRODEF PARAMETER XAB$M_PROPAGATE = '00000001'X PARAMETER XAB$K_PROLEN_V3 = '00000010'X ! V3a xabpro length PARAMETER XAB$C_PROLEN_V3 = '00000010'X ! V3a xabpro length PARAMETER XAB$K_PROLEN = '00000058'X ! xabpro length PARAMETER XAB$C_PROLEN = '00000058'X ! xabpro length STRUCTURE /XABPRODEF1/ BYTE XABPRODEF$$_FILL_1 BYTE XABPRODEF$$_FILL_2 INTEGER*2 XABPRODEF$$_FILL_3 INTEGER*4 XABPRODEF$$_FILL_4 ! HAS SAME COD, BLN, SPARE AND NXT FIELD ! THESE 4 FIELDS ARE COMMON TO ALL XABS AND ! HAVE BEEN DEFINED BY $XABDEF UNION MAP INTEGER*2 XAB$W_PRO ! protection mask END MAP MAP PARAMETER XAB$S_SYS = 4 PARAMETER XAB$V_SYS = 0 ! system PARAMETER XAB$S_OWN = 4 PARAMETER XAB$V_OWN = 4 ! owner PARAMETER XAB$S_GRP = 4 PARAMETER XAB$V_GRP = 8 ! group PARAMETER XAB$S_WLD = 4 PARAMETER XAB$V_WLD = 12 BYTE %FILL (2) ! world END MAP END UNION BYTE XAB$B_MTACC ! Magtape access control char. UNION MAP BYTE XAB$B_PROT_OPT ! XABPRO options field END MAP MAP PARAMETER XAB$S_PROPAGATE = 1 PARAMETER XAB$V_PROPAGATE = 0 ! Propagate security attributes on $ENTER and $RENAME BYTE %FILL (1) END MAP END UNION UNION MAP INTEGER*4 XAB$L_UIC ! uic code END MAP MAP INTEGER*2 XAB$W_MBM ! member code INTEGER*2 XAB$W_GRP ! group code END MAP END UNION UNION MAP INTEGER*4 XAB$Q_PROT_MODE(2) ! eventually may be a quadword END MAP MAP BYTE XAB$B_PROT_MODE ! but currently only a byte END MAP END UNION INTEGER*4 XAB$L_ACLBUF ! address of user's ACL buffer INTEGER*2 XAB$W_ACLSIZ ! size of user's ACL buffer INTEGER*2 XAB$W_ACLLEN ! return length of entire ACL INTEGER*4 XAB$L_ACLCTX ! ACL context field INTEGER*4 XAB$L_ACLSTS ! ACL return err status INTEGER*4 XABPRODEF$$_FILL_10 ! spare INTEGER*4 XABPRODEF$$_FILL_11 ! spare INTEGER*4 XABPRODEF$$_FILL_12 ! spare INTEGER*4 XABPRODEF$$_FILL_13 ! spare INTEGER*4 XABPRODEF$$_FILL_14 ! spare INTEGER*4 XABPRODEF$$_FILL_15 ! spare INTEGER*4 XABPRODEF$$_FILL_16 ! spare INTEGER*4 XABPRODEF$$_FILL_17 ! spare INTEGER*4 XABPRODEF$$_FILL_18 ! spare INTEGER*4 XABPRODEF$$_FILL_19 ! spare INTEGER*4 XABPRODEF$$_FILL_20 ! spare INTEGER*4 XABPRODEF$$_FILL_21 ! spare END STRUCTURE ! XABPRODEF1 C RECORD /XABPRODEF1/ xabpro C INTEGER*4 l_uic C COMMON /XAB_UIC/ l_uic C xabpro.XABPRODEF$$_FILL_1 = XAB$C_PRO ! Type of XAB block. xabpro.XABPRODEF$$_FILL_2 = XAB$C_PROLEN ! Length of PRO XAB. C xabpro.XABPRODEF$$_FILL_4 = 0 ! Next XAB address. RETURN END