1 /* format: style4,delnl,insnl,^ifthendo */
  2 imft_convert_acs:
  3      procedure ();
  4 
  5 /* Finds all segments and the targets of all links in the working directory with names that match
  6    **.imft.acs, and changes all instances of "r" on their ACLs to "w" and vice versa.
  7    Written for conversion to Version 3 of IMFT, at which point the meanings of the
  8    ACL terms on ACSs were reversed.
  9    To make sure that each ACS is converted exactly once, an indexed vfile is maintained whose keys
 10    are the UIDs of segments whose ACLs have been converted.
 11 */
 12 
 13 /* Written April 5, 1983 by Robert Coren */
 14 
 15 
 16 dcl  area_ptr pointer;
 17 dcl  dirname char (168);
 18 dcl  ename char (32);
 19 dcl  real_dirname char (168);
 20 dcl  real_ename char (32);
 21 dcl  code fixed bin (35);
 22 dcl  i fixed bin;
 23 dcl  target_type fixed bin (2);
 24 
 25 dcl  1 auto_status_branch aligned like status_branch;
 26 
 27 dcl  com_err_ entry options (variable);
 28 dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
 29 dcl  get_system_free_area_ entry () returns (ptr);
 30 dcl  get_wdir_ entry () returns (char (168));
 31 dcl  hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35));
 32 dcl  hcs_$list_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35));
 33 dcl  hcs_$replace_acl entry (char (*), char (*), ptr, fixed bin, bit (1), fixed bin (35));
 34 dcl  hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
 35 dcl  hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
 36 dcl  hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
 37 dcl  iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
 38 dcl  iox_$close entry (ptr, fixed bin (35));
 39 dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
 40 dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
 41 dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
 42 dcl  pathname_ entry (char (*), char (*)) returns (char (168));
 43 
 44 dcl  (
 45      error_table_$key_duplication,
 46      error_table_$nomatch,
 47      error_table_$noentry,
 48      error_table_$too_many_args
 49      ) fixed bin (35) external static;
 50 
 51 dcl  static_iocbp pointer internal static;
 52 dcl  1 static_ak_info internal static aligned,
 53        2 header like ak_info.header,
 54        2 key char (4);
 55 
 56 dcl  NAME char (16) internal static options (constant) init ("imft_convert_acs");
 57 dcl  IMFT_ACS char (8) internal static options (constant) init ("imft_acs");
 58 dcl  ACS_LIST_FILE char (13) internal static options (constant) init ("imft_acs_list");
 59 dcl  SYSCTL_DIR char (17) internal static options (constant) init (">system_control_1");
 60 
 61 dcl  acs_list_dir char (152) internal static init (">system_control_1");
 62 
 63 dcl  (bool, null, rtrim, unspec) builtin;
 64 dcl  cleanup condition;
 65 
 66           star_entry_ptr, star_names_ptr = null ();
 67           dirname = get_wdir_ ();
 68           area_ptr = get_system_free_area_ ();
 69 
 70           on cleanup
 71                begin;
 72                     if star_names_ptr ^= null ()
 73                     then free star_names;
 74                     if star_entry_ptr ^= null ()
 75                     then free star_entries;
 76                end;
 77 
 78           call hcs_$star_ (dirname, "**.imft.acs", star_ALL_ENTRIES, area_ptr, star_entry_count, star_entry_ptr,
 79                star_names_ptr, code);
 80           if code = error_table_$nomatch
 81           then return;                                      /* if there are none, then this directory isn't interesting */
 82 
 83           if code ^= 0
 84           then do;                                          /* any other error is worth reporting */
 85                call com_err_ (code, NAME, "Could not list entries in ^a", dirname);
 86                return;
 87           end;
 88 
 89           do i = 1 to star_entry_count;
 90                if star_entries (i).type = star_DIRECTORY
 91                then ;                                       /* directories with such a name are unlikely, but ignore them anyway */
 92 
 93                else do;
 94                     ename = star_names (star_entries (i).nindex);
 95                     if star_entries (i).type = star_LINK
 96                     then do;                                /* get its target */
 97                          call hcs_$get_link_target (dirname, ename, real_dirname, real_ename, code);
 98                          if code = 0
 99                          then do;
100                               call hcs_$status_minf (real_dirname, real_ename, 1, target_type, (0), code);
101                               if /* tree */ code ^= 0
102                               then call com_err_ (code, NAME, "Could not get entry type of ^a",
103                                         pathname_ (real_dirname, real_ename));
104                               else if target_type = star_DIRECTORY
105                                    then ;
106                                    else call convert_acl (real_dirname, real_ename);
107                          end;
108 
109                          else if code ^= error_table_$noentry
110                                                             /* null links are uninteresting, but anything else should eb reported */
111                          then call com_err_ (code, NAME, "Could not get target of ^a", pathname_ (dirname, ename));
112                     end;
113 
114                     else call convert_acl (dirname, ename);
115                end;
116           end;
117 
118           free star_names;
119           free star_entries;
120 
121           return;
122 %page;
123 /* entry to attach and open the vfile containing the list of already-processed segments */
124 
125 imft_open_acs_list:
126      entry;
127 
128           call iox_$attach_name (IMFT_ACS, static_iocbp, "vfile_ " || rtrim (pathname_ (acs_list_dir, ACS_LIST_FILE)),
129                null (), code);
130           if code ^= 0
131           then do;
132                call com_err_ (code, NAME, "Could not attach ^a", pathname_ (acs_list_dir, ACS_LIST_FILE));
133                return;
134           end;
135 
136           call iox_$open (static_iocbp, Keyed_sequential_update, "0"b, code);
137           if code ^= 0
138           then do;
139                call com_err_ (code, NAME, "Could not open ^a", pathname_ (acs_list_dir, ACS_LIST_FILE));
140                return;
141           end;
142 
143           unspec (static_ak_info) = ""b;
144           static_ak_info.input_key, static_ak_info.input_desc = "1"b;
145           static_ak_info.key_len = 4;
146 
147           return;
148 
149 
150 /* entry to close and detach the vfile */
151 
152 imft_close_acs_list:
153      entry;
154 
155           call iox_$close (static_iocbp, code);
156           call iox_$detach_iocb (static_iocbp, code);
157           return;
158 
159 
160 /* entry to change the directory in which the ACS list is kept */
161 
162 imft_test_acs_list:
163      entry;
164 
165 dcl  nargs fixed bin;
166 dcl  argp pointer;
167 dcl  argl fixed bin (21);
168 
169 dcl  arg char (argl) based (argp);
170 
171 dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
172 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
173 
174           call cu_$arg_count (nargs, code);
175           if code ^= 0
176           then do;
177                call com_err_ (code, NAME);
178                return;
179           end;
180 
181           if nargs > 1
182           then do;
183                call com_err_ (error_table_$too_many_args, NAME, "^/Usage: imft_test_acs_list {dir_path}");
184                return;
185           end;
186 
187           if nargs = 1
188           then do;
189                call cu_$arg_ptr (1, argp, argl, code);
190                call expand_pathname_ (arg, dirname, ename, code);
191                if code ^= 0
192                then do;
193                     call com_err_ (code, NAME, arg);
194                     return;
195                end;
196 
197                acs_list_dir = pathname_ (dirname, ename);
198           end;
199 
200           else acs_list_dir = SYSCTL_DIR;                   /* no argument means restore the default */
201 
202           return;
203 %page;
204 convert_acl:
205      procedure (P_dirname, P_ename);
206 
207 /* Given a directory and entry name, picks up the ACL of the segment
208    and changes all instances of "r" access to "w" and vice versa */
209 
210 dcl  P_dirname char (*) parameter;
211 dcl  P_ename char (*) parameter;
212 
213 dcl  dirname char (168);
214 dcl  ename char (32);
215 dcl  rw_check bit (3);
216 dcl  i fixed bin;
217 dcl  already_done bit (1);
218 
219           dirname = P_dirname;
220           ename = P_ename;
221 
222           call hcs_$status_long (dirname, ename, 1, addr (auto_status_branch), null (), code);
223                                                             /* in order to get unique ID */
224           if code ^= 0
225           then do;
226                call com_err_ (code, NAME, "Could not get unique ID of ^a", pathname_ (dirname, ename));
227                return;
228           end;
229 
230           call update_acs_list (auto_status_branch.uid, already_done, code);
231           if code ^= 0
232           then do;
233                call com_err_ (code, NAME, "Could not update ACS list with ^a", pathname_ (dirname, ename));
234                return;
235           end;
236 
237           if already_done                                   /* then don't do it again */
238           then return;
239 
240           call hcs_$list_acl (dirname, ename, area_ptr, acl_ptr, null (), acl_count, code);
241           if code ^= 0
242           then do;
243                call com_err_ (code, NAME, "Could not list ACL of ^a", pathname_ (dirname, ename));
244                return;
245           end;
246 
247           on cleanup free segment_acl_array;
248 
249           do i = 1 to acl_count;
250                rw_check = segment_acl_array (i).mode & RW_ACCESS;
251                                                             /* find current state of r and w */
252                if rw_check = RW_ACCESS | rw_check = N_ACCESS
253                then ;                                       /* if both on or both off, leave it alone */
254                else segment_acl_array (i).mode = bool (segment_acl_array (i).mode, RW_ACCESS, "0110"b);
255                                                             /* switch R and W, leave anything else alone */
256           end;
257 
258           call hcs_$replace_acl (dirname, ename, acl_ptr, acl_count, "1"b, code);
259           if code ^= 0
260           then call com_err_ (code, NAME, "Could not replace ACL on ^a", pathname_ (dirname, ename));
261 
262           free segment_acl_array;
263           return;
264 
265      end convert_acl;
266 %page;
267 /* add a key to the index corresponding to the unique ID of the current segment,
268    or return an indication that it is already there
269 */
270 
271 update_acs_list:
272      procedure (P_uid, P_already_done, P_code);
273 
274 dcl  P_uid bit (36) parameter;
275 dcl  P_already_done bit (1) parameter;
276 dcl  P_code fixed bin (35) parameter;
277 
278           unspec (static_ak_info.key) = P_uid;
279           call iox_$control (static_iocbp, "add_key", addr (static_ak_info), P_code);
280 
281           if P_code = error_table_$key_duplication          /* this means it's already there */
282           then do;
283                P_code = 0;
284                P_already_done = "1"b;
285           end;
286 
287           else if P_code = 0
288           then P_already_done = "0"b;
289 
290           return;
291 
292      end update_acs_list;
293 %page;
294 %include acl_structures;
295 %page;
296 %include access_mode_values;
297 %page;
298 %include star_structures;
299 %page;
300 %include status_structures;
301 %page;
302 %include iox_modes;
303 %page;
304 %include ak_info;
305 
306      end imft_convert_acs;