1 allaccess:          proc(pathname);
  2 
  3 /*        This program prints out the names of all the processes that have immediate access to a segment
  4           or a directory, and all the processes that can force access through w privilege over a superior
  5           directory in the hierarchy.  The single argument is the path name of the segment or directory
  6           whose access is to be checked.
  7 
  8           Written by Leo J. Rotenberg  August 1971
  9           Modified to filter CACLs and improve output filtering  October 1971
 10           Modified to eliminate filtering of exceptions and correctly filter equal access control names  March 1972
 11           Modified to adapt to file system changes --the end of e access--  December 1972
 12           Translated to Version 2 PL/I  January 1973
 13           Changed  by E. Stone December 1973 to prepare for removal of Cacls
 14           */
 15 
 16           dcl dcl_area area based(areap);
 17           dcl 1 acl(100) aligned based,
 18                 2 userid char(32) aligned,
 19                 2 pack aligned,
 20                     (3 mode bit(5),
 21                     3 reterr bit(13),
 22                     3 (rb1,rb2,rb3) bit(6)) unaligned;
 23           dcl 1 bead aligned based,
 24                   2 next ptr,
 25                   2 cnt fixed bin,
 26                   2 bacl(totcnt) aligned,
 27                     3 caclt bit(1) aligned, /* acl or cacl */
 28                     3 userid char(32) aligned,
 29                     3 broken aligned,
 30                       4 pers char(30),  /* <-- */
 31                       4 l1 fixed bin,   /* length of based varying string */
 32                       4 proj char(30),
 33                       4 l2 fixed bin,  /* similarly */
 34                       4 tag char(1),
 35                       4 pe_star bit(1),
 36                       4 pr_star bit(1),
 37                       4 tag_star bit(1),
 38                     3 pack aligned,
 39                       (4 mode bit(5),
 40                       4 reterr bit(13),
 41                       4 (rb1,rb2,rb3) bit(6)) unaligned;
 42           dcl x bit(36) based;  /* to move and compare packs */
 43 
 44           dcl 1 link aligned,
 45                     (2 type bit(2),
 46                     2 nnames fixed bin(15),
 47                     2 nrp bit(18),
 48                     2 dtem bit(36),
 49                     2 dtd bit(36),
 50                     2 pnl fixed bin(17),
 51                     2 pnrp bit(18)) unaligned;
 52           dcl names(link.nnames) char(32) aligned based(ptr(areap,fixed(link.nrp)));
 53           dcl path char(link.pnl) aligned based(ptr(areap,fixed(link.pnrp)));
 54 
 55           dcl       pathname char(*),
 56                     dirname char(168),
 57                     ename char(32),
 58                     (dirp,entp,argp) ptr,
 59                     (argl,code) fixed bin,
 60                     (areap,aclp) ptr,
 61                     aclcnt fixed bin,
 62                     caclp ptr,
 63                     caclcnt fixed bin;
 64           dcl       (total,tj) fixed bin,
 65                     type fixed bin(2), /* 0=link 1=seg 2=dir */
 66                     bitcnt fixed bin(24), /* somebody cares */
 67                     breakid char(40) varying,
 68                     (j,k) fixed bin;
 69           dcl       (headp,tailp,beadp,new_bead) ptr,
 70                     totcnt fixed bin,
 71                     tempname char(168);
 72           dcl       first bit(1),
 73                     first_type fixed bin(2),
 74                     num_link fixed bin;
 75           dcl       (pers,proj) char(30) varying,
 76                     tag char(1);
 77           dcl       time_str char(24);
 78 
 79           dcl       (addr,fixed,index,length,null,substr,ptr,max) builtin,
 80                     com_err_ ext entry options(variable),
 81                     error_table_$obsolete_function ext fixed bin,
 82                     expand_path_ ext entry(ptr,fixed bin,ptr,ptr,fixed bin),
 83                     freen_ ext entry(ptr),
 84                     hcs_$acl_list ext entry(char(*),char(*),ptr,fixed bin,ptr,fixed bin),
 85                     hcs_$status_minf ext entry(char(*),char(*),fixed bin(1),fixed bin(2),fixed bin(24),fixed bin),
 86                     ioa_ ext entry options(variable),
 87                     get_system_free_area_ entry returns(ptr);
 88           dcl       hcs_$status_ ext entry(char(*),char(*),fixed bin(1),ptr,ptr,fixed bin),
 89                     clock_ ext entry returns(fixed bin(71)),
 90                     date_time_ ext entry(fixed bin(71),char(*));
 91 
 92           areap = get_system_free_area_();
 93           aclp = null;
 94           caclp = null;
 95           headp = null;
 96           tailp = null;
 97           total = 0;
 98           first = "1"b;
 99           num_link = 0;
100           argp = addr(tempname);
101           dirp = addr(dirname);
102           entp = addr(ename);
103           tempname = pathname;
104           argl = length(pathname);
105 
106 get_loop: call expand_path_(argp,argl,dirp,entp,code);
107           if code ^= 0 then do;
108                     call com_err_(code,"allaccess",tempname);
109                     return;
110                     end;
111           call hcs_$status_minf(dirname,ename,0,type,bitcnt,code);
112           if code ^= 0 then do;
113                     call com_err_(code,"allaccess",ename);
114                     return;
115                     end;
116           if type = 0 then do;  /* chase the link */
117                     call hcs_$status_(dirname,ename,0,addr(link),areap,code);
118                     if code ^= 0 then do;
119                               call com_err_(code,"allaccess",ename);
120                               go to all_over;
121                               end;
122                     call freen_(addr(names));
123                     tempname = substr(path,1,link.pnl);
124                     argl = link.pnl;
125                     call freen_(addr(path));
126                     num_link = num_link + 1;
127                     if num_link > 10 then do;
128                               call ioa_("allaccess:  Probable link loop.");
129                               go to all_over;
130                               end;
131                     go to get_loop;
132                     end;
133           if first then do;  /* save type of object */
134                     first_type = type;
135                     first = "0"b;
136                     end;
137 
138           call hcs_$acl_list(dirname,ename,aclp,aclcnt,areap,code);
139           if code ^= 0 then do;  /* code = 0 implies all reterr's = 0 */
140                     call com_err_(code,"allaccess",ename);
141                     go to all_over;
142                     end;
143           call hcs_$acl_list(dirname,"",caclp,caclcnt,areap,code);
144           if code ^= 0 then if code ^= error_table_$obsolete_function then do;
145                     call com_err_(code,"allaccess",dirname);
146                     go to all_over;
147                     end;
148           else do;
149                     caclp = null;
150                     caclcnt = 0;
151                     end;
152           totcnt = aclcnt + caclcnt;
153           if totcnt = 0 then do;
154                     call ioa_("allaccess: Empty ACL.");
155                     go to all_over;
156                     end;
157 
158           allocate bead set(new_bead) in(dcl_area);
159           if headp = null then headp = new_bead;
160           else tailp->bead.next = new_bead;
161           tailp = new_bead;
162           new_bead->bead.next = null;  /* put ACL and CACL together in bead */
163           new_bead->bead.cnt = aclcnt;
164           if aclcnt > 0 then do j = 1 to aclcnt;
165                     new_bead->bacl(j).userid = aclp->acl(j).userid;
166                     k = index(aclp->acl(j).userid,".");
167                     new_bead->bacl(j).pers = substr(aclp->acl(j).userid,1,k-1);
168                     new_bead->bacl(j).l1 = k-1;
169                     breakid = substr(aclp->acl(j).userid,k+1,32-k);
170                     k = index(breakid,".");
171                     new_bead->bacl(j).proj = substr(breakid,1,k-1);
172                     new_bead->bacl(j).l2 = k-1;
173                     new_bead->bacl(j).tag = substr(breakid,k+1,1);
174                     new_bead->bacl(j).pe_star = new_bead->bacl(j).pers = "*";
175                     new_bead->bacl(j).pr_star = new_bead->bacl(j).proj = "*";
176                     new_bead->bacl(j).tag_star = new_bead->bacl(j).tag = "*";
177                     new_bead->bacl(j).caclt = "0"b;
178                     addr(new_bead->bacl(j).pack)->x = addr(aclp->acl(j).pack)->x;
179                     if type = 2 then new_bead->bacl(j).rb1,new_bead->bacl(j).rb2,new_bead->bacl(j).rb3 = "000000"b;
180                     end;
181 
182           if caclcnt > 0 then do j = 1 to caclcnt;
183                     k = index(caclp->acl(j).userid,".");
184                     pers = substr(caclp->acl(j).userid,1,k-1);
185                     breakid = substr(caclp->acl(j).userid,k+1,32-k);
186                     k = index(breakid,".");
187                     proj = substr(breakid,1,k-1);
188                     tag = substr(breakid,k+1,1);
189                     if aclcnt > 0 then do k = 1 to aclcnt;  /* try to find blocking term in ACL */
190                               if new_bead->bacl(k).pe_star |
191                                         substr(new_bead->bacl(k).pers,1,new_bead->bacl(k).l1) = pers
192                               then if new_bead->bacl(k).pr_star |
193                                         substr(new_bead->bacl(k).proj,1,new_bead->bacl(k).l2) = proj
194                               then if new_bead->bacl(k).tag_star | new_bead->bacl(k).tag = tag
195                               then go to off_it;
196                               end;
197                     k,new_bead->bead.cnt = new_bead->bead.cnt + 1;  /* add term from CACL */
198                     new_bead->bacl(k).userid = caclp->acl(j).userid;
199                     new_bead->bacl(k).caclt = "1"b;
200                     addr(new_bead->bacl(k).pack)->x = addr(caclp->acl(j).pack)->x;
201                     if type = 2 then new_bead->bacl(k).rb1,new_bead->bacl(k).rb2,new_bead->bacl(k).rb3 = "000000"b;
202                     new_bead->bacl(k).pers = pers;
203                     new_bead->bacl(k).l1 = length(pers);
204                     new_bead->bacl(k).proj = proj;
205                     new_bead->bacl(k).l2 = length(proj);
206                     new_bead->bacl(k).tag = tag;
207                     new_bead->bacl(k).pe_star = pers = "*";
208                     new_bead->bacl(k).pr_star = proj = "*";
209                     new_bead->bacl(k).tag_star = tag = "*";
210 off_it:             end;
211           if aclp ^= null then do;  call freen_(aclp);  aclp = null;  end;
212           if caclp ^= null then do;  call freen_(caclp);  caclp = null;  end;
213           total = total + new_bead->bead.cnt;
214 
215           if substr(dirname,1,2) ^= "> " then do;  /* loop until a bead is built from a branch of the Root */
216                     tempname = dirname;
217                     argl = index(tempname," ")-1;
218                     num_link = 0;
219                     go to get_loop;
220                     end;
221 
222           call date_time_(clock_(),time_str);
223           call ioa_("^/^-^R^a^B  ^a^/^/Immediate Access^/",pathname,time_str);
224           beadp = headp->bead.next;
225           if beadp ^= null then total = max(total,beadp->bead.cnt * headp->bead.cnt);
226 
227           begin;
228 
229           dcl 1 out(total) aligned,
230                     2 tag char(1),
231                     2 pe_star bit(1),
232                     2 pr_star bit(1),
233                     2 tag_star bit(1),
234                     2 intersect bit(1),
235                     2 caclt bit(1),
236                     2 pack aligned,
237                       (3 mode bit(5),
238                       3 reterr bit(13),
239                       3 (rb1,rb2,rb3) bit(6)) unaligned,
240                     2 include bit(1);
241           dcl 1 ous(total) aligned,  /* the compiler made me do this */
242                     2 pers char(30) varying;
243           dcl 1 our(total) aligned,
244                     2 proj char(30) varying;
245 
246 addnm:    procedure(p,i);  /* add an access name to the filtering array */
247 
248           declare   p ptr,
249                     i fixed bin;
250 
251           tj = tj + 1;
252                     ous(tj).pers = substr(p->bacl(i).pers,1,p->bacl(i).l1);
253                     our(tj).proj = substr(p->bacl(i).proj,1,p->bacl(i).l2);
254                     out(tj).tag = p->bacl(i).tag;
255                     out(tj).pe_star = p->bacl(i).pe_star;
256                     out(tj).pr_star = p->bacl(i).pr_star;
257                     out(tj).tag_star = p->bacl(i).tag_star;
258           out(tj).intersect = "0"b;
259           out(tj).caclt = p->bacl(i).caclt;
260           addr(out(tj).pack)->x = addr(p->bacl(i).pack)->x;
261           out(tj).include = "1"b;
262           return;
263           end addnm;
264 
265 filter:   procedure;  /* eliminate special-case access names with equivalent access privileges */
266                               /* don't eliminate exceptions */
267           dcl (k,j) fixed bin,
268               (included,exception) bit(1);
269 
270           if tj >= 2 then do k = 1 to tj-1;
271                     if out(k).include then do;
272                               included,exception = "0"b;
273                               do j = k+1 to tj;  if out(j).include
274                                         then if out(j).pe_star | ous(j).pers = ous(k).pers
275                                         then if out(j).pr_star | our(j).proj = our(k).proj
276                                         then if out(j).tag_star | out(j).tag = out(k).tag then do;
277                                                   included = "1"b;
278                                                   if addr(out(j).pack)->x ^= addr(out(k).pack)->x
279                                                   then exception = "1"b;
280                                                   end;
281                                         end;
282                               if included & ^exception then out(k).include = "0"b;
283                               end;
284                     end;
285           return;
286           end filter;
287 
288           tj = 0;
289           if first_type = 1 then do; /* segment */
290                               do k = 1 to headp->bead.cnt;
291                                         call addnm(headp,k);
292                                         end;
293                               call filter;
294                               do k = 1 to tj;  if out(k).include then do;
295                                         breakid = ous(k).pers || "." || our(k).proj || "." || out(k).tag || " ";
296                                         if out(k).caclt then breakid = breakid || "c";
297 /* Call was removed due to bug in compiler in passing structures to procedures.
298                                         call acl_line(breakid,out(k).pack);
299  When the bug is fixed, the following statement should be remove and replaced by the call. */
300                                         call ioa_("^5a  ^d,^d,^d^-^a",mod_ch(out(k).pack.mode),
301                                         fixed(out(k).pack.rb1,6),fixed(out(k).pack.rb2,6),fixed(out(k).pack.rb3,6),breakid);
302                                         end;  end;
303                               go to force;
304                     end;
305 
306           else if first_type = 2 then do;  /* directory */
307                     do k = 1 to headp->bead.cnt;
308                               call addnm(headp,k);
309                               end;
310                     call filter;
311                     do k = 1 to tj;  if out(k).include then do;
312                               breakid = ous(k).pers || "." || our(k).proj || "." || out(k).tag || " ";
313                               if out(k).caclt then breakid = breakid || "c";
314                               call ioa_("^5a^-^a",mod_ch(out(k).pack.mode),breakid);
315                               end;  end;
316                     end;
317 
318 force:    call ioa_("^/Can Force Access^/");
319           if beadp = null then do;
320                     call ioa_("none^/");
321                     go to all_over;
322                     end;
323 
324           tj = 0;
325           do while(beadp ^= null);  /* find all processes that can force access */
326                     do k = 1 to beadp->bead.cnt;
327                               if substr(beadp->bead.bacl(k).pack.mode,4,1)  /* term with w */
328                               then call addnm(beadp,k);
329                               end;
330                     beadp = beadp->bead.next;
331                     end;
332 
333           do k = 1 to tj;  if out(k).include then
334                     do j = 1 to tj;  if out(j).include & j ^= k
335                               then if out(j).pe_star | ous(j).pers = ous(k).pers
336                               then if out(j).pr_star | our(j).proj = our(k).proj
337                               then if out(j).tag_star | out(j).tag = out(k).tag then do;
338                                         out(k).include = "0"b;
339                                         go to end_kk;
340                                         end;
341                               end;
342 end_kk:             end;
343 
344           do k = 1 to tj;  if out(k).include then do;
345                     breakid = ous(k).pers || "." || our(k).proj || "." || out(k).tag || " ";
346                     if out(k).intersect then breakid = breakid || "d";
347                     call ioa_("^a",breakid);
348                     end;  end;
349           end;  /* leave the begin block:  free out */
350 
351           call ioa_("");
352 all_over: if aclp ^= null then call freen_(aclp);
353           if caclp ^= null then call freen_(caclp);
354           do while(headp ^= null);
355                     new_bead = headp->bead.next;
356                     call freen_(headp);
357                     headp = new_bead;
358                     end;
359           return;
360 
361 /* Remove when compiler bug is fixed
362 acl_line: procedure(name,pack);  /* print mode, ring numbers, access name for segment */
363 /* Remove when compiler bug is fixed.
364 
365           dcl       name char(40) varying,
366                     1 pack aligned,
367                      (2 mode bit(5),
368                       2 reterr bit(13),
369                       2 (rb1,rb2,rb3) bit(6)) unaligned;
370           call ioa_("^5a  ^d,^d,^d^-^a",mod_ch(pack.mode),fixed(pack.rb1,6),fixed(pack.rb2,6),fixed(pack.rb3,6),name);
371           return;
372           end acl_line;
373  Remove when compiler bug is fixed. */
374 
375 mod_ch:   procedure(bits) returns(char(5));  /* convert mode bits to mnemonic characters "trewa" */
376 
377           dcl       bits bit(5),
378                     mode char(5) aligned,
379                     (num,k) fixed bin;
380           dcl       mchars char(5) aligned int static init("trewa");
381           mode = "     ";
382           num = 1;
383           do k = 1 to 5;
384                     if substr(bits,k,1) then do;
385                               substr(mode,num,1) = substr(mchars,k,1);
386                               num = num + 1;
387                               end;
388                     end;
389           if num = 1 then mode = "null ";
390           return(mode);
391           end mod_ch;
392 
393           end allaccess;