module set_file_overide (main=main,
		addressing_mode(external=general)) =
begin

!+
! Abstract:
!
!	This procedure set the ownership of a file while the
!	file has been locked by another user.
!-
library	'sys$library:starlet';
library 'sys$library:tpamac';

own
	converted_uic;		! Converted UIC value

external routine
	lib$find_file,		! Find the full name of a file.
	lib$find_file_end,	! End the context for a lib$find_file
	cli$present,		! Verify the existance of an entity.
	cli$get_value,		! Get the value of that entity.
	lib$tparse;		! For parsing the UIC.

forward routine
	main ,			! Main entry point.  Errors are signaled.
	get_cli,		! Get the command argument
	set_file,		! set the file information.
	parse_uic;		! Parse out the UIC given by the user.

routine main  =
!+
! This routine is the main control.  It calls the various other routines
! to parse and then affect the other file attributes.
!
! Inputs:
!
!	None.
!
! Outputs:
!
!	None.
!
! Returns:
!
!	Status from all other functions.
!
!-
begin

local
	status,
	file_id : $bblock[6],
	uic_value,
	channel;

	status = get_cli(uic_value, channel, file_id[0,0,0,0]);
	if not .status then signal(.status);

	if .status then
		begin
		status = set_file(.uic_value, .channel, file_id[0,0,0,0]);
		if not .status then signal(.status);
        	end;

	return (.status or STS$M_INHIB_MSG);
end;

routine get_cli (uic : ref vector[1,long], 
		channel : ref vector[1,long],
		fid : ref $bblock) =
!+
! This routine obtains parameters from the command line and converts
! them into something useful for the ACP to use.
!
! Inputs:
!
!	UIC:	Address of a longword receive the value of the cli UIC
!	channel:Address of a longword to receive the disk channel
!	FID:	Address of a block to recieve the file identification.
!
! Implied Inputs:
!
!	From the users CLI, get the command line file name and UIC
!
! Outputs:
!
!	Input values are filled in by this routine.
!
! returns:
!
!	SS$_NORMAL, any status from CLI$GET_VALUE, LIB$ and $ASCTOID
!
!-
begin

bind	file_name_d = $descriptor('FILE_NAME'),
	uic_string_d = $descriptor('OWNER_UIC');
local
	status,
	iosb: vector[4,word],
	context,
	file_name : $bblock[dsc$k_d_bln],
	full_file_name: $bblock[dsc$k_d_bln],
	uic_string : $bblock[dsc$k_d_bln],
	disk_name : $bblock[dsc$k_d_bln],
	result_string : $bblock[nam$c_maxrss],
	fab:	$bblock[fab$c_bln],		! Allocate a $FAB structure.
	nam:	$bblock[nam$c_bln];		! Allocate a $NAM structure.

	$init_dyndesc(file_name);
	$init_dyndesc(full_file_name);
	$init_dyndesc(uic_string);
!+
! Get the value of the command line parameters.
!-
	if not (status = cli$get_value(file_name_d, file_name))
		then return .status;
	if not (status = cli$get_value(uic_string_d, uic_string))
		then
		begin
		local
			itmlst : $itmlst_decl(),
			my_uic;
		!
		! Since we did not specify an owner, assume us.
		!
		$itmlst_init(itmlst=itmlst,
			(itmcod=jpi$_uic, bufadr=.uic));
		status = $getjpiw(itmlst = itmlst,
				iosb=iosb  
				);
		if .status then status = .iosb[0];
		end
	else
		status = parse_uic(uic_string, .uic);

	if not .status then return .status;
!+
! Get the full file spec from lib$find_file and pass it to
! SYS$PARSE to get a DISK to assign a channel against.
! Then get the FID of the file we want to open.
!-
	if not (status = lib$find_file(file_name, full_file_name, context))
		then return .status;
	lib$find_file_end(context);
	$fab_init(fab=fab, 		! Initialize the structures
		fns=.full_file_name[dsc$w_length],
		fna=.full_file_name[dsc$a_pointer],
		nam=nam);
	$nam_init(nam=nam, ess=nam$c_maxrss, esa=result_string,
			rss=nam$c_maxrss, rsa=result_string);
	if not (status = $parse(fab=fab))
		then return .status;

	if not (status = $search(fab=fab))
		then return .status;

	fid[fid$w_num] = .nam[nam$w_fid_num];
	fid[fid$w_seq] = .nam[nam$w_fid_seq];
	fid[fid$w_rvn] = .nam[nam$w_fid_rvn];

!+
! Now create a string descriptor of the disk name
! and assign a channel to that disk.
!-
        disk_name[dsc$b_dtype] = dsc$k_dtype_t;
        disk_name[dsc$b_class] = dsc$k_class_s;
	disk_name[dsc$w_length] = .nam[nam$b_dev];
	disk_name[dsc$a_pointer] = .nam[nam$l_dev];

	return $assign(devnam=disk_name, chan=.channel);
	
end;

routine set_file(uic, channel, fid : ref $bblock) =
!+
! Given the input file channel and the FID
! this routine sets the file withthe value of the UIC.
!
! Inputs:
!
!	UIC:	longword containg the UIC of the file.
!	Channel: longword containing the channel of the disk
!	Fid:	Address of a FID block contianign the file id.
!
! Outputs:
!
!	None
!
! Returns:
!
!	Normal system service values or SS$_NORMAL
!-
begin
local
	status,
	iosb : 	vector[4, word],
	atr_list : $bblock[1*8+4],
	fib :	$bblock[fib$k_length],
	fib_desc : vector[2] initial (long (fib$k_length, fib));

	ch$fill(0, fib$k_length, fib);		! Clear the FIB block

	fib[fib$l_acctl] = FIB$M_WRITE OR FIB$M_NOLOCK;
	FIB[FIB$W_FID_NUM] = .FID[FID$W_NUM];
	FIB[FIB$W_FID_SEQ] = .FID[FID$W_SEQ];
	FIB[FIB$W_FID_RVN] = .FID[FID$W_RVN];

	ATR_LIST [ATR$W_SIZE] = ATR$S_UIC;
	ATR_LIST [ATR$W_TYPE] = ATR$C_UIC;
	ATR_LIST [ATR$L_ADDR] = UIC;
	ATR_LIST [8, 0, 32, 0] = 0;	! End of list
!+
! Open the file to gain access.
!-
	status = $qiow(chan=.channel,
			func=io$_access or io$m_access,
			iosb=iosb,
			p1=fib_desc);
	if .status then status = .iosb[0];
	if not .status then return .status;
!+
! Change the attribute on the deaccess of the file.
!-
	status = $qiow(chan=.channel,
			func=io$_deaccess,
			iosb=iosb,
			p1=fib_desc,
			p5=atr_list);
	if .status then status = .iosb[0];
	if not .status then return .status;

	return $dassgn(chan=.channel);


end;

!+
! Lib$Tparse macros (Code obtained from [CLIUTL]UTILSUBS.B32)
!-

!+
! Parse the UIC string and store the binary value.
!-
	$INIT_STATE	(UIC_STB, UIC_KTB);

	$STATE	(,
		(TPA$_IDENT,,,,CONVERTED_UIC)
		);
	$STATE	(,
		(TPA$_EOS,TPA$_EXIT)
		);

ROUTINE parse_uic (desc, uic) =
BEGIN

!+
!
! This routine takes an ASCII string of the form [m,n] and attempts to parse
! the pieces into a longword UIC.  If any errors are detected, an error is
! returned.
!
! Inputs
!	DESC - address of ASCII descriptor of UIC string
!
! Outputs
!	UIC  - the longword representation is returned here.
!
!-

MAP
	desc : REF $BBLOCK,
	uic : REF VECTOR;

	LOCAL
		TPARSE_BLOCK	: $BBLOCK [TPA$K_LENGTH0]	! TPARSE
		INITIAL (TPA$K_COUNT0,	!  PARAMETER
			TPA$M_BLANKS OR	!  BLOCK
			TPA$M_ABBREV),
	STATUS;					! Routine return status

	TPARSE_BLOCK[TPA$L_STRINGCNT] = .DESC[DSC$W_LENGTH];
	TPARSE_BLOCK[TPA$L_STRINGPTR] = .DESC[DSC$A_POINTER];

	IF NOT (STATUS = LIB$TPARSE (TPARSE_BLOCK, UIC_STB, UIC_KTB))
	THEN RETURN .STATUS;

	UIC[0] = .CONVERTED_UIC;			! MAKE THE UIC LONGWORD
	
RETURN 1;
END;


end
eludom