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  /* Get args after pathname.  First, allocate enough room to hold maximum number of
144     argument pairs. */
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;         /* unpaired arguments */
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  /* first get the ACL that we're looking at */
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;          /* also frees add_dir_acl */
278  free segment_acl;                                          /* also frees dir_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; /* no spaces allowed */
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; /* third decimal point */
306 illegal:
307   call com_err_ (0, who, "Bad access name. ^a", arg);
308   goto return;
309   end;
310 end;
311 
312 
313 end;