module setprot (main = go,
    		ident = '01') =
begin

!++
!
! Set protection on a file, with wild carding.
!
! Neal Lippman, 8/10/80
!
!--

library 'sys$library:lib';

literal
    true = 1,
    false = 0;

macro
    descriptor [] =
		uplit long(word(%charcount(%string(%remaining)),0),
				uplit byte(%string(%remaining))) %,

    tell [] =
    		(
    		external routine lib$put_output : addressing_mode(absolute);
    		lib$put_output(descriptor(%remaining))
    		)%
;

bind
    wildstring = uplit byte('*.*');

own 
    filename : vector[63,byte],
    file_len : word,
    protection : word,
    xab : block[xab$c_prolen,byte],		!xab for protection
    res_name : vector [nam$c_maxrss, byte],	!resultant name
    exp_name : vector [nam$c_maxrss, byte],	!expanded name
    nam_block : $nam (				!name block
	    rsa = res_name, 			!result name addr
	    rss = nam$c_maxrss, 		!result name size
	    esa = exp_name, 			!expanded name addr
	    ess = nam$c_maxrss),		!exanded name size
    fab : $fab(
    		dna=wildstring, !wild card everything
    		dns=3,
    		fac=<put,get>,	!need write access to set prot
    		fna=filename,	!put filename here
    		fop=nam,	!name block open
    		nam=nam_block,	!name block for search and parse
    		xab=xab
    		),
    file_desc : vector[2,long] initial(63,filename),
    prot_string : vector[4,byte],
    prot_desc : vector[2,long] initial(4,prot_string);



forward routine
    get_prot : novalue,
    go;
    
external routine 
    str$upcase : addressing_mode(general),
    lib$get_input : addressing_mode(absolute);



routine go =
(

local 
    istat, 
    got_prot : byte;

got_prot = false;

xab[xab$b_cod] = xab$c_pro;	!make us a protection xab
xab[xab$b_bln] = xab$c_prolen;	!and set its length
xab[xab$w_grp] = 0;
xab[xab$w_mbm] = 0;
xab[xab$l_nxt] = 0;


while true do
(


!get the file name


    lib$get_input(file_desc,descriptor('  File(s): '),file_len);
    
    if .file_len eql 0 then return 1; !exit if no file spec

    fab[fab$b_fns] = .file_len<0,8>;

    istat = $rms_parse (fab = fab);		!parse the file spec

    if not .istat then
    	(
    	tell('%Error parsing file specification');
    	return .istat		!exit to system with error code
    	);

    if .got_prot eql true then
    	(
    	local 
    		ans : byte,
    		desc : vector[2,long];
    	desc[0] = 1;
    	desc[1] = ans;
    	lib$get_input(desc,descriptor('Use same protection [Y/N]? '));
    	if (.ans geq %c'a') and (.ans leq %c'z') then ans = .ans -%x'20';
    	if .ans neq %c'Y' then got_prot = false
    	);

    while true do 				!loop through all files...
    	(
    	istat = $rms_search (fab = fab);	!search for file
    	if .istat eql rms$_nmf then exitloop;	!no more files?
    	if not .istat then
						!some other error?
    		(
		tell ('%Error searching for file');
		return .istat
    		);

    	if .got_prot eql false then 	!get the protection if we don't
    					!have one for this file spec
    		(
    		get_prot();
    		got_prot = true
    		);

    	istat = $rms_open(fab = fab);	!open the file
    	
    	if .istat neq rms$_normal then
    		(
    		tell ('%Error opening file');
    		return .istat
    		);


!close the file, setting protection:
	xab[xab$w_pro] = .protection;
	istat = $rms_close(fab = fab);

	if .istat neq rms$_normal then
		(
		tell ('%Error closing file');
		return .istat
		);

    	if not .nam_block [nam$v_wildcard] then exitloop;

    	);	!end of search loop

);	!end of main loop

1
);	!end of the routine


routine get_prot : novalue =
(

!
!set the four protection fields in protection
!

local
    prot_len : word;

map
    protection : bitvector[16];

literal			!define bit numbers for protections
    sysr = 0,
    sysw = 1,   
    syse = 2,
    sysd = 3,
    ownr = 4,
    ownw = 5,
    owne = 6,
    ownd = 7,
    grpr = 8,
    grpw = 9,
    grpe = 10,
    grpd = 11,
    wldr = 12,
    wldw = 13,
    wlde = 14,
    wldd = 15;

incr i from 0 to 15 do
    protection[.i] = 1;	!deny access initially


lib$get_input(prot_desc,descriptor('	System: '),prot_len);
str$upcase(prot_desc,prot_desc);
if not ch$fail(ch$find_ch(.prot_len,prot_string,%c'R')) then
    protection[sysr] = 0;
if not ch$fail(ch$find_ch(.prot_len,prot_string,%c'W')) then
    protection[sysw] = 0;
if not ch$fail(ch$find_ch(.prot_len,prot_string,%c'E')) then
    protection[syse] = 0;
if not ch$fail(ch$find_ch(.prot_len,prot_string,%c'D')) then
    protection[sysd] = 0;

lib$get_input(prot_desc,descriptor('	Owner:  '),prot_len);
str$upcase(prot_desc,prot_desc);
if not ch$fail(ch$find_ch(.prot_len,prot_string,%c'R')) then
    protection[ownr] = 0;
if not ch$fail(ch$find_ch(.prot_len,prot_string,%c'W')) then
    protection[ownw] = 0;
if not ch$fail(ch$find_ch(.prot_len,prot_string,%c'E')) then
    protection[owne] = 0;
if not ch$fail(ch$find_ch(.prot_len,prot_string,%c'D')) then
    protection[ownd] = 0;

lib$get_input(prot_desc,descriptor('	Group:  '),prot_len);
str$upcase(prot_desc,prot_desc);
if not ch$fail(ch$find_ch(.prot_len,prot_string,%c'R')) then
    protection[grpr] = 0;
if not ch$fail(ch$find_ch(.prot_len,prot_string,%c'W')) then
    protection[grpw] = 0;
if not ch$fail(ch$find_ch(.prot_len,prot_string,%c'E')) then
    protection[grpe] = 0;
if not ch$fail(ch$find_ch(.prot_len,prot_string,%c'D')) then
    protection[grpd] = 0;

lib$get_input(prot_desc,descriptor('	World:  '),prot_len);
str$upcase(prot_desc,prot_desc);
if not ch$fail(ch$find_ch(.prot_len,prot_string,%c'R')) then
    protection[wldr] = 0;
if not ch$fail(ch$find_ch(.prot_len,prot_string,%c'W')) then
    protection[wldw] = 0;
if not ch$fail(ch$find_ch(.prot_len,prot_string,%c'E')) then
    protection[wlde] = 0;
if not ch$fail(ch$find_ch(.prot_len,prot_string,%c'D')) then
    protection[wldd] = 0;


return
);

end
eludom