1 change_acl: proc;
2
3 dcl who char(32);
4
5 dcl 1 segment_acl (acl_count) aligned based (acl_ptr),
6 2 access_name char(32),
7 2 modes bit(36),
8 2 zero_pad bit(36),
9 2 status_code fixed bin(35);
10
11 dcl 1 dir_acl (acl_count) aligned based (acl_ptr),
12 2 access_name char(32),
13 2 dir_modes bit(36),
14 2 status_code fixed bin(35);
15
16 dcl 1 add_segment_acl (acl_count) like segment_acl aligned based (add_acl_ptr);
17 dcl 1 add_dir_acl (acl_count) like dir_acl aligned based (add_acl_ptr);
18 dcl add_acl_ptr ptr init(null);
19
20 dcl 1 entries (ecount) based (eptr),
21 (2 type bit(2),
22 2 nnames fixed bin(15),
23 2 nindex fixed bin(17)) unaligned;
24
25 dcl names(1) char(32) aligned based (nptr);
26
27 dcl cleanup condition;
28 dcl matching_name (max_names) char(32) aligned based (matching_name_ptr);
29 dcl new_name (max_names) char(32) aligned based (new_name_ptr);
30 dcl max_names fixed bin;
31 dcl n_names fixed bin init(0);
32 dcl (matching_name_ptr, new_name_ptr) ptr init(null);
33 dcl odd bit(1) init ("1"b);
34 dcl acl_count fixed bin;
35 dcl acl_ptr ptr init(null);
36 dcl (i, j) fixed bin;
37 dcl add_acl_count fixed bin;
38 dcl seg_inacl bit(1);
39 dcl dir_inacl bit(1);
40 dcl (brief, replace) bit(1) init("0"b) aligned;
41 dcl (segsw, dirsw) bit(1) aligned init("0"b);
42 dcl stars bit(1) aligned init("0"b);
43 dcl at_least_one_match bit(1) aligned init("0"b);
44 dcl type bit(2) aligned;
45 dcl kind char(10);
46 dcl dn char(168);
47 dcl en char(32);
48 dcl new_group_id_ entry (char(32) aligned, char(32) aligned) returns (char(32));
49 dcl match_group_id_ entry (char(32) aligned, char(32) aligned) returns (bit(1));
50 dcl area_ptr ptr;
51 dcl area area based (area_ptr);
52 dcl check_star_name_$entry entry (char(*), fixed bin(35));
53 dcl com_err_ entry options (variable);
54 dcl cu_$arg_count entry (fixed bin);
55 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin(35));
56 dcl expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin(35));
57 dcl get_ring_ entry returns (fixed bin(6));
58 dcl get_system_free_area_ entry returns (ptr);
59 dcl get_wdir_ entry returns (char(168) aligned);
60 dcl hcs_$add_acl_entries entry (char(*), char(*), ptr, fixed bin, fixed bin(35));
61 dcl hcs_$add_dir_acl_entries entry (char(*), char(*), ptr, fixed bin, fixed bin(35));
62 dcl hcs_$add_dir_inacl_entries entry (char(*), char(*), ptr, fixed bin, fixed bin, fixed bin(35));
63 dcl hcs_$add_inacl_entries entry (char(*), char(*), ptr, fixed bin, fixed bin, fixed bin(35));
64 dcl hcs_$list_acl entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35));
65 dcl hcs_$list_dir_acl entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35));
66 dcl hcs_$list_dir_inacl entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin, fixed bin(35));
67 dcl hcs_$list_inacl entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin, fixed bin(35));
68 dcl hcs_$replace_acl entry (char(*), char(*), ptr, fixed bin, bit(1), fixed bin(35));
69 dcl hcs_$replace_dir_acl entry (char(*), char(*), ptr, fixed bin, bit(1), fixed bin(35));
70 dcl hcs_$replace_dir_inacl entry (char(*), char(*), ptr, fixed bin, bit(1) aligned, fixed bin, fixed bin(35));
71 dcl hcs_$replace_inacl entry (char(*), char(*), ptr, fixed bin, bit(1), fixed bin, fixed bin(35));
72 dcl hcs_$star_ entry (char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr, fixed bin(35));
73 dcl arg char(arglen) based(argptr);
74 dcl dirname char(168) aligned;
75 dcl ename char(32) aligned;
76 dcl eindex fixed bin;
77 dcl ecount fixed bin;
78 dcl (eptr, nptr) init(null) ptr;
79 dcl arglen fixed bin;
80 dcl argptr ptr;
81 dcl argno fixed bin;
82 dcl nargs fixed bin;
83 dcl code fixed bin(35);
84 dcl error_table_$badopt external fixed bin(35);
85 dcl error_table_$noentry external fixed bin(35);
86 dcl error_table_$nomatch external fixed bin(35);
87 dcl error_table_$notadir external fixed bin(35);
88 dcl error_table_$noarg external fixed bin(35);
89 dcl error_table_$user_not_found external fixed bin(35);
90 dcl null builtin;
91
92 who = "change_acl";
93 dir_inacl, seg_inacl = "0"b;
94 goto common;
95
96 change_iacl_dir: entry;
97
98 who = "change_iacl_dir";
99 dir_inacl = "1"b;
100 seg_inacl = "0"b;
101 goto common;
102
103 change_iacl_seg: entry;
104
105 who = "change_iacl_seg";
106 seg_inacl = "1"b;
107 dir_inacl = "0"b;
108
109 common:
110 on cleanup call cleanup_proc;
111 call cu_$arg_count (nargs);
112 if nargs < 3 then do;
113 u: call com_err_ (error_table_$noarg, who, "^/Usage is: change_acl path match_id_1 new_id_1 ... match_id_n new_id_n -control_args-^/control_args: -brief, -segment, -directory, -replace");
114 call cleanup_proc;
115 return;
116 end;
117
118 call cu_$arg_ptr (1, argptr, arglen, code);
119 if arg = "-working_directory" | arg = "-wd" then do;
120 dn = get_wdir_();
121 argptr = addr(dn);
122 arglen = 168;
123 end;
124 call expand_path_ (argptr, arglen, addr(dirname), addr(ename), code);
125 if code ^= 0 then goto argerr;
126 dn = dirname;
127 en = ename;
128 call check_star_name_$entry (en, code);
129 if code = 0
130 then stars = "0"b;
131 else if code = 1 | code = 2
132 then stars = "1"b;
133 else goto argerr;
134
135 area_ptr = get_system_free_area_();
136
137 call hcs_$star_ (dn, en, 3, area_ptr, ecount, eptr, nptr, code);
138 if code ^= 0 then do;
139 if ^stars & code = error_table_$nomatch then code = error_table_$noentry;
140 goto patherr;
141 end;
142
143
144
145
146 max_names = divide (nargs-1, 2, 17, 0);
147 allocate matching_name, new_name in (area);
148
149 do argno = 2 to nargs;
150 call cu_$arg_ptr (argno, argptr, arglen, code);
151 if arg = "-brief" | arg = "-bf"
152 then brief = "1"b;
153 else if arg = "-replace" | arg = "-rp"
154 then replace = "1"b;
155 else if arg = "-segment" | arg = "-sm" then do;
156 if dir_inacl | seg_inacl then goto badopt;
157 segsw = "1"b;
158 end;
159 else if arg = "-directory" | arg = "-dr" then do;
160 if dir_inacl | seg_inacl then goto badopt;
161 dirsw = "1"b;
162 end;
163 else do;
164 if arglen ^= 0 then if substr (arg, 1, 1) = "-" then do;
165 badopt: code = error_table_$badopt;
166 argerr: call com_err_ (code, who, arg);
167 call cleanup_proc;
168 return;
169 end;
170 call check_access_name;
171 if odd then do;
172 n_names = n_names + 1;
173 matching_name(n_names) = arg;
174 end;
175 else new_name(n_names) = arg;
176 odd = ^odd;
177 end;
178 end;
179
180 if ^odd then goto u;
181 if ^(segsw | dirsw) then segsw, dirsw = "1"b;
182
183 do eindex = 1 to ecount;
184 en = names(entries(eindex).nindex);
185 type = entries(eindex).type;
186 if type = "00"b & ^stars then do;
187 call com_err_ (0, who, "^a>^a is a link.", dirname, en);
188 call cleanup_proc;
189 return;
190 end;
191 if type = "01"b & (dir_inacl | seg_inacl | (dirsw & ^segsw)) & ^stars then do;
192 code = error_table_$notadir;
193 patherr:
194 call com_err_ (code, who, "^a>^a", dirname, en);
195 call cleanup_proc;
196 return;
197 end;
198 if type = "10"b & (segsw & ^dirsw) & ^stars then do;
199 call com_err_ (0, who, "Entry is not a segment. ^a>^a", dirname, en);
200 call cleanup_proc;
201 return;
202 end;
203
204 if ^seg_inacl & ^dir_inacl & ((type = "01"b & ^segsw) | (type = "10"b & ^dirsw)) then goto do_nothing;
205 if (type = "01"b & (seg_inacl | dir_inacl)) | (type = "00"b) then goto do_nothing;
206
207 at_least_one_match = "1"b;
208
209
210
211 if type = "01"b
212 then call hcs_$list_acl (dn, en, area_ptr, acl_ptr, null(), acl_count, code);
213 else if seg_inacl
214 then call hcs_$list_inacl (dn, en, area_ptr, acl_ptr, null, acl_count, get_ring_(), code);
215 else if dir_inacl
216 then call hcs_$list_dir_inacl (dn, en, area_ptr, acl_ptr, null, acl_count, get_ring_(), code);
217 else call hcs_$list_dir_acl (dn, en, area_ptr, acl_ptr, null, acl_count, code);
218
219 add_acl_count = 0;
220
221 if ^replace then
222 if type = "01"b | seg_inacl
223 then allocate add_segment_acl in (area) set (add_acl_ptr);
224 else allocate add_dir_acl in (area) set (add_acl_ptr);
225
226 do i = 1 to acl_count;
227 do j = 1 to n_names;
228 if type = "01"b | seg_inacl then do;
229 if match_group_id_ (segment_acl(i).access_name, matching_name(j)) then do;
230 add_acl_count = add_acl_count + 1;
231 if replace
232 then segment_acl(i).access_name = new_group_id_ (segment_acl(i).access_name, new_name(j));
233 else do;
234 add_segment_acl(add_acl_count) = segment_acl(i);
235 add_segment_acl(add_acl_count).access_name = new_group_id_ (segment_acl(i).access_name, new_name(j));
236 end;
237 end;
238 end;
239 else do;
240 if match_group_id_ (dir_acl(i).access_name, matching_name(j)) then do;
241 add_acl_count = add_acl_count + 1;
242 if replace
243 then dir_acl(i).access_name = new_group_id_ (dir_acl(i).access_name, new_name(j));
244 else do;
245 add_dir_acl(add_acl_count) = dir_acl(i);
246 add_dir_acl(add_acl_count).access_name = new_group_id_ (dir_acl(i).access_name, new_name(j));
247 end;
248 end;
249 end;
250 end;
251 end;
252
253 if add_acl_count = 0 & ^brief
254 then call com_err_ (error_table_$user_not_found, who, "^a for ^a>^a.", matching_name, dirname, en);
255
256 if replace then
257 if type = "01"b
258 then call hcs_$replace_acl (dn, en, addr(segment_acl), acl_count, "1"b, code);
259 else if seg_inacl
260 then call hcs_$replace_inacl (dn, en, addr(segment_acl), acl_count, "1"b, get_ring_(), code);
261 else if dir_inacl
262 then call hcs_$replace_dir_inacl (dn, en, addr(dir_acl), acl_count, "1"b, get_ring_(), code);
263 else call hcs_$replace_dir_acl (dn, en, addr(dir_acl), acl_count, "1"b, code);
264 else if type = "01"b
265 then call hcs_$add_acl_entries (dn, en, addr(add_segment_acl), add_acl_count, code);
266 else if seg_inacl
267 then call hcs_$add_inacl_entries (dn, en, addr(add_segment_acl), add_acl_count, get_ring_(), code);
268 else if dir_inacl
269 then call hcs_$add_dir_inacl_entries (dn, en, addr(add_dir_acl), add_acl_count, get_ring_(), code);
270 else call hcs_$add_dir_acl_entries (dn, en, addr(add_dir_acl), add_acl_count, code);
271
272 if code ^= 0 then do;
273 if seg_inacl | dir_inacl then kind = "initial ACL"; else kind = "ACL";
274 call com_err_ (code, who, "Couldn't change ^a of ^a>^a.", kind, dirname, en);
275 end;
276
277 if add_acl_ptr ^= null then free add_segment_acl;
278 free segment_acl;
279 add_acl_ptr, acl_ptr = null;
280 do_nothing: end;
281
282 if ^at_least_one_match then do;
283 code = error_table_$nomatch;
284 en = ename;
285 goto patherr;
286 end;
287
288 return: call cleanup_proc;
289
290 cleanup_proc: proc;
291 dcl p ptr;
292 dcl x based (p);
293 do p = matching_name_ptr, new_name_ptr, eptr, nptr, add_acl_ptr, acl_ptr;
294 if p ^= null then free x;
295 end;
296 end;
297
298 check_access_name: proc;
299 dcl (i, j) fixed bin;
300 if index (arg, " ") ^= 0 then goto illegal;
301 i = index (arg, ".");
302 if i = arglen | i = 0 then return;
303 j = search (substr (arg, i+1), ".");
304 if j = 0 | j + i = arglen then return;
305 if index (substr (arg, i+j+1), ".") ^= 0 then do;
306 illegal:
307 call com_err_ (0, who, "Bad access name. ^a", arg);
308 goto return;
309 end;
310 end;
311
312
313 end;