PROGRAM OWN

*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K105
*	August 1983	   Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*128 FILE_NAME
	INTEGER*2 FID(3),DID(3),LAST_DID(3)
	LOGICAL*4 USER_HAS_PRIV,SYSTEM_USER,LOG,CONFIRM

	COMMON /FIDS/ LAST_DID,DID,FID
	COMMON /FILE/ FILE_NAME_LEN,FILE_NAME

	COMMON /USER_DATA_/ PID,USER_STAT,PROCESS_UIC

	SYSTEM_USER = USER_HAS_PRIV('SYSPRV')

	SYSTEM_USER = SYSTEM_USER .OR. (UIC/'10000'X .LE. '10'O)

	LOG     = CLI$PRESENT('LOG')
	CONFIRM = CLI$PRESENT('CONFIRM')

10	CALL GET_A_FILE_NAME('P1',FILE_NAME,FILE_NAME_LEN,' ',*100,*110)

	CALL PROCESS_DEVICE(FILE_NAME(1:FILE_NAME_LEN))

	CALL COMPUTE_FID_AND_DID(FILE_NAME(1:FILE_NAME_LEN),FID,DID,*10)

	IF (DID(1).NE.LAST_DID(1) .OR. DID(2).NE.LAST_DID(2) .OR.
	1					DID(3).NE.LAST_DID(3)) THEN

	    CALL DETERMINE_FILE_OWNER(DID,DIR_UIC)

	    IF (DIR_UIC.NE.PROCESS_UIC .AND. .NOT.SYSTEM_USER) GO TO 120

	    LAST_DID(1) = DID(1)
	    LAST_DID(2) = DID(2)
	    LAST_DID(3) = DID(3)

	ENDIF

	CALL DETERMINE_FILE_OWNER(FID,FILE_UIC)

	IF (FILE_UIC.NE.DIR_UIC) THEN

	    IF (CONFIRM)
	1	CALL CONFIRM_IT(FILE_NAME(1:FILE_NAME_LEN),FILE_UIC,*10)

	    CALL SET_FILE_OWNER(FID,DIR_UIC)

	    IF (LOG) PRINT 1000,FILE_NAME(1:FILE_NAME_LEN)

	ENDIF

	GO TO 10

100	CALL EXIT

110	CALL ERROR(1)
	GO TO 10

120	CALL ERROR(2)
	CALL EXIT

1000	FORMAT (' You now own ',A)

	END
	SUBROUTINE PROCESS_DEVICE(FILE_NAME)

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) FILE_NAME
	CHARACTER*128 LAST_DEV
	INTEGER*2 LAST_DID(3)
	INTEGER*4 LAST_DEV_LEN / -1 /

	COMMON /FIDS/ LAST_DID

	DEV_LEN = INDEX(FILE_NAME,':')

	IF (DEV_LEN.NE.LAST_DEV_LEN .OR.
	1	FILE_NAME(1:DEV_LEN).NE.LAST_DEV(1:LAST_DEV_LEN)) THEN

	    CALL ASSIGN_DEVICE(FILE_NAME(1:DEV_LEN))

	    LAST_DEV_LEN = DEV_LEN

	    LAST_DEV(1:LAST_DEV_LEN) = FILE_NAME(1:DEV_LEN)

	    LAST_DID(1) = 0			! Prevent concidental match
	    LAST_DID(2) = 0			!  of Directory IDs on dif-
	    LAST_DID(3) = 0			!  ferent devices.

	ENDIF

	END
	SUBROUTINE ASSIGN_DEVICE(DEVICE_NAME)

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) DEVICE_NAME

	INTEGER*2 CHAN / 0 /

	COMMON /CHAN_/ CHAN

	IF (CHAN.NE.0) THEN

	    STATUS = SYS$DASSGN(%VAL(CHAN))

	    IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	ENDIF

	STATUS = SYS$ASSIGN(DEVICE_NAME,CHAN,,)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	END
	SUBROUTINE COMPUTE_FID_AND_DID(FILE_NAME,FID,DID,*)

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) FILE_NAME
	INTEGER*2 FID(3),DID(3)

	INTEGER*4 FAB(20) / '5003'X,6*0,'02000000'X,12*0 /
	INTEGER*2 NAM(48) / '6002'X,47*0 /

	FAB(11) = %LOC(NAM)
	FAB(12) = %LOC(FILE_NAME)
	FAB(14) = LEN(FILE_NAME)

	STATUS=SYS$OPEN(FAB)

	IF (.NOT.STATUS) THEN

	    CALL ERROR(3)

	    RETURN 1

	ENDIF

	DO I=1,3

	    FID(I) = NAM(18+I)

	    DID(I) = NAM(21+I)

	ENDDO

	STATUS = SYS$CLOSE(FAB)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	END
	SUBROUTINE CONFIRM_IT(FILE_NAME,FILE_UIC,*)

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) FILE_NAME
	CHARACTER*1   REPLY

	GROUP  = FILE_UIC/'10000'X
	MEMBER = IAND(FILE_UIC,'FFFF'X)

	PRINT 1000,FILE_NAME,GROUP,MEMBER

	READ (*,1001,END=100) REPLY

	IF (REPLY.NE.'Y'.AND.REPLY.NE.'y') RETURN 1

	RETURN

100	CALL EXIT				! Ctrl\Z was entered.

1000	FORMAT ('$',A,', change owner from [',O3.3,',',O3.3,
	1						']? (Y or N): ')
1001	FORMAT (A)

	END
	SUBROUTINE DETERMINE_FILE_OWNER(FID,UIC)

*	CHAN must be the channel assigned to the file's device.

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( ATR$C_UIC = '15'X )

	INTEGER*4 UIC
	INTEGER*2 FID(3),IOSB(4),CHAN
	CHARACTER*10 FIB

	INTEGER*4 ATR(3)  / 3*0 /
	INTEGER*2 FIB_(5) / 5*0 /

	COMMON /CHAN_/ CHAN

	EQUIVALENCE (FIB,FIB_)

	EXTERNAL IO$_ACCESS

	FIB_(3) = FID(1)
	FIB_(4) = FID(2)
	FIB_(5) = FID(3)

	ATR(1) = IOR(4,ISHFT(ATR$C_UIC,16))
	ATR(2) = %LOC(UIC)

	STATUS=SYS$QIOW(,%VAL(CHAN),IO$_ACCESS,IOSB,,,FIB,,,,ATR,)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1)))

	END
	SUBROUTINE SET_FILE_OWNER(FID,UIC)

*	CHAN must be the channel assigned to the file's device.

	IMPLICIT INTEGER (A-Z)

	PARAMETER ( ATR$C_UIC = '15'X )

	INTEGER*4 UIC,UIC_
	INTEGER*2 FID(3),IOSB(4),CHAN
	CHARACTER*10 FIB

	INTEGER*4 ATR(3)  / 3*0 /
	INTEGER*2 FIB_(5) / 5*0 /

	COMMON /CHAN_/ CHAN

	EQUIVALENCE (FIB,FIB_)

	EXTERNAL IO$_MODIFY

	UIC_ = UIC		! Make sure UIC is writable

	FIB_(3) = FID(1)
	FIB_(4) = FID(2)
	FIB_(5) = FID(3)

	ATR(1) = IOR(4,ISHFT(ATR$C_UIC,16))
	ATR(2) = %LOC(UIC_)

	STATUS=SYS$QIOW(,%VAL(CHAN),IO$_MODIFY,IOSB,,,FIB,,,,ATR,)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1)))

	END
	SUBROUTINE ERROR(ORDINAL)

	IMPLICIT INTEGER (A-Z)

	CHARACTER*128 FILE_NAME,VALUE

	COMMON /FILE/ FILE_NAME_LEN,FILE_NAME
	COMMON /GET_FILE_NAME/ LEN,VALUE

	IF (ORDINAL.EQ.1) THEN

	    PRINT 1000,VALUE(1:LEN)

	ELSE IF (ORDINAL.EQ.2) THEN

	    COL = INDEX(FILE_NAME(1:FILE_NAME_LEN),']')

	    PRINT 1001,FILE_NAME(1:COL)

	ELSE IF (ORDINAL.EQ.3) THEN

	    PRINT 1002,FILE_NAME(1:FILE_NAME_LEN)

	ENDIF

1000	FORMAT (' No files found for ',A)
1001	FORMAT (' You do not own directory',A/' OWN Command terminated.')
1002	FORMAT (' Cannot open file ',A)

	END