1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1988                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         * Copyright (c) 1972 by Massachusetts Institute of        *
  8         * Technology and Honeywell Information Systems, Inc.      *
  9         *                                                         *
 10         *********************************************************** */
 11 
 12 
 13 
 14 
 15 /****^  HISTORY COMMENTS:
 16   1) change(87-10-06,Parisek), approve(88-02-03,MCR7845),
 17      audit(88-04-12,Lippard), install(88-04-26,MR12.2-1043):
 18      Implement multi-segment file application for possible >256K disk_stat
 19      segment.
 20                                                    END HISTORY COMMENTS */
 21 
 22 
 23 /* format: style4 */
 24 sweep:
 25      procedure options (variable);
 26 
 27 /* This procedure does a "getquota" on all directories and puts the returned values in a file.
 28    The quota, used, and time-page product figures for both segments and directories are recorded.
 29    Output segment is "disk_stat" unless "-of PATH" is specified.
 30    Root node is ">" unless a non-control arg is encountered.
 31    If a directory has no quota, the subtree under it is not scanned, since quota must be in an
 32    unbroken chain (so we need not look at all directories).
 33    The program attempts to give itself access as needed and clean up later.
 34    THVV
 35 */
 36 
 37 /* Modified June 1975 by J. C. Whitmore for setting directory privilege. */
 38 /* Modified April 1976 by THVV and TAC to implement recording of directory pages used under NSS */
 39 /* Modified December 1980 by C. Hornig for connection failures */
 40 /* Modified 83-09-25 by E. N. Kittlitz, per SGH (UNCA) to clean up AST if privileged */
 41 
 42 dcl  path char (168) init (">");
 43 dcl  dn char (168) init (get_wdir_ ());
 44 dcl  pdir char (168) init (get_pdir_ ());
 45 dcl  en char (32) init ("disk_stat");
 46 dcl  areap ptr;
 47 dcl  fcbp ptr;
 48 dcl  (quota, tot_dquota, tot_squota) fixed bin (35) init (0); /* GLOBAL variables, total quota */
 49 dcl  (used, tot_dused, tot_sused) fixed bin (35) init (0);  /* GLOBAL variables, total use */
 50 dcl  hpriv bit (1) aligned;
 51 dcl  ppriv bit (1) aligned;
 52 dcl  seg_ptr ptr;
 53 dcl  uid bit (36) aligned;
 54 dcl  (n, tn) fixed bin;                                     /* GLOBAL variable, number of dirs */
 55 dcl  bitc fixed bin (24);
 56 dcl  an fixed bin;
 57 dcl  ap ptr;                                                /* ptr to arg */
 58 dcl  al fixed bin;                                          /* lth of arg */
 59 dcl  bchr char (al) based (ap) unaligned;
 60 dcl  ec fixed bin (35);                                     /* err code */
 61 dcl  starting_level fixed bin;                              /* level in hierarchy where the sweep starts (root = 0) */
 62 dcl  (i, j) fixed bin;
 63 dcl  bfsw bit (1) aligned init ("1"b);                      /* default to brief mode */
 64 dcl  pddsw bit (1) aligned init ("0"b);                     /* default is to omit >pdd from the sweep */
 65 dcl  priv_off bit (1) aligned;                              /* flag to tell that system privileges are off */
 66 dcl  priv_set fixed bin (35);                               /* this will be zero if we set system privileges */
 67 dcl  cpx fixed bin;
 68 
 69 dcl  (addr, clock, index, null, rtrim, substr, sum) builtin;
 70 
 71 dcl  (cleanup, linkage_error, seg_fault_error) condition;
 72 
 73 %include disk_stat;
 74 
 75 dcl  com_err_ entry options (variable);
 76 dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
 77 dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
 78 dcl  ioa_ entry options (variable);
 79 dcl  get_system_free_area_ entry () returns (ptr);
 80 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
 81 dcl  (get_pdir_, get_wdir_) entry () returns (char (168));
 82 dcl  get_group_id_ entry () returns (char (32));
 83 dcl  hcs_$get_uid_seg entry (ptr, bit (36) aligned, fixed bin (35));
 84 dcl  hcs_$quota_read
 85           entry (char (*), fixed bin, fixed bin (71), fixed bin (35), bit (36), fixed bin (1), fixed bin, fixed bin (35));
 86 dcl  hcs_$dir_quota_read
 87           entry (char (*), fixed bin, fixed bin (71), fixed bin (35), bit (36), fixed bin (1), fixed bin, fixed bin (35));
 88 dcl  hphcs_$quota_read
 89           entry (char (*), fixed bin, fixed bin (71), fixed bin (35), bit (36), fixed bin (1), fixed bin, fixed bin (35));
 90 dcl  hphcs_$dir_quota_read
 91           entry (char (*), fixed bin, fixed bin (71), fixed bin (35), bit (36), fixed bin (1), fixed bin, fixed bin (35));
 92 dcl  hphcs_$deactivate entry (bit (36) aligned, fixed bin (35));
 93 dcl  msf_manager_$close entry (ptr);
 94 dcl  msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
 95 dcl  msf_manager_$msf_get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
 96 dcl  msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35));
 97 dcl  system_privilege_$dir_priv_on entry (fixed bin (35));
 98 dcl  system_privilege_$dir_priv_off entry (fixed bin (35));
 99 dcl  phcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
100 dcl  phcs_$terminate_noname entry (ptr, fixed bin (35));
101 dcl  hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
102 dcl  hcs_$delete_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
103 dcl  hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35));
104 dcl  hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
105 dcl  hphcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
106 
107 dcl  (
108      error_table_$badopt,
109      error_table_$noarg
110      ) ext fixed bin (35);
111 
112 dcl  1 acla aligned,
113        2 userid char (32),
114        2 mode bit (36),
115        2 rcode fixed bin (35);
116 
117 dcl  1 acld aligned,
118        2 userid char (32),
119        2 rcode fixed bin (35);
120 dcl  cp_array (0:4) ptr;
121 
122 %page;
123           ec = 0;
124           do an = 1 by 1 while (ec = 0);
125                call cu_$arg_ptr (an, ap, al, ec);
126                if ec = 0 then do;
127                     if /* case */ substr (bchr, 1, 1) ^= "-" then do;
128                          call absolute_pathname_ (bchr, path, ec);
129                          if ec ^= 0 then do;
130                               call com_err_ (ec, "sweep", "^a", bchr);
131                               return;
132                          end;
133                     end;
134                     else if bchr = "-bf" then bfsw = "1"b;
135                     else if bchr = "-brief" then bfsw = "1"b;
136                     else if bchr = "-lg" then bfsw = "0"b;
137                     else if bchr = "-long" then bfsw = "0"b;
138                     else if bchr = "-pdd" then pddsw = "1"b;
139                     else if bchr = "-of" | bchr = "-output_file" then do;
140                          an = an + 1;
141                          call cu_$arg_ptr (an, ap, al, ec);
142                          if ec ^= 0 then do;
143                               call com_err_ (error_table_$noarg, "sweep", "after ""-output_file""");
144                               return;
145                          end;
146                          call expand_pathname_ (bchr, dn, en, ec);
147                          if ec ^= 0 then do;
148                               call com_err_ (ec, "sweep", "^a", bchr);
149                               return;
150                          end;
151                     end;
152                     else do;
153                          call com_err_ (error_table_$badopt, "sweep", "^a", bchr);
154                          return;
155                     end;
156                end;
157           end;
158 
159           priv_off = "1"b;                                  /* assume that we don't have dir privilege */
160           priv_set = 1;                                     /* and that we did not set dir priv */
161           hpriv = "0"b;
162           ppriv = "0"b;
163           on cleanup
164                begin;                                       /* so we can undo what we did */
165                     if priv_set = 0 then call system_privilege_$dir_priv_off (priv_set);
166                end;
167 
168 /*        Now we will try to set dir privilege so we can look at each dir in the system. */
169 
170           on linkage_error go to revert_handler;            /* in case of no access to system_privilege_ */
171 
172           call system_privilege_$dir_priv_on (priv_set);    /* try to set it */
173           priv_off = "0"b;                                  /* privileges are on now for sure */
174 revert_handler:
175           revert linkage_error;                             /* it was only to catch system_privilege_ error */
176           on linkage_error go to revert1;
177           call hphcs_$star_ (">", "**", 0, null (), 0, null (), null (), 0);
178           hpriv = "1"b;                                     /* Didn't fault, so im super */
179 revert1:
180           revert linkage_error;
181 
182           on linkage_error goto revert2;
183           call phcs_$initiate (">", "", "", 0, 0, null (), 0);
184           ppriv = "1"b;
185 revert2:  revert linkage_error;
186 
187           if priv_off then do;                              /* see if we now have the dir priv */
188                if bfsw
189                then call com_err_ (0, "sweep",              /* give this message if we supress others */
190                          "Unable to set directory privilege. Access to storage system may not be complete.");
191                priv_set = 1;                                /* just to be safe */
192           end;
193 
194           cp_array (*), fcbp, sp = null ();
195           cpx = 0;
196           call msf_manager_$open (dn, en, fcbp, ec);
197           if fcbp = null () then do;
198                call com_err_ (ec, "sweep", "");
199                return;
200           end;
201 
202           call msf_manager_$get_ptr (fcbp, cpx, "1"b, cp_array (0), 0, ec);
203           if cp_array (0) = null () then do;
204                call com_err_ (ec, "sweep", "^a", en);
205                return;
206           end;
207           if ec ^= 0 then do;
208                call com_err_ (ec, "sweep", "");
209                return;
210           end;
211 
212           sp = cp_array (0);
213           n, tn = 0;                                        /* Start with no directories. */
214 
215           acla.userid = get_group_id_ ();
216           acld.userid = acla.userid;
217           acla.mode = "111"b;
218 
219           areap = get_system_free_area_ ();
220 
221 /* Compute starting level, so that a given directory will always have the same level number,
222    no matter where the sweep starts */
223 
224           i = 2;                                            /* skip the leading ">" since the root is level zero */
225           j = 1;                                            /* just to get past the "while" the first time */
226           do starting_level = -1 by 1                       /* count ">"s in path */
227                while (j ^= 0);                              /* and quit when there are no more */
228                j = index (substr (path, i), ">");           /* look for one */
229                if j ^= 0
230                then                                         /* if there was one */
231                     i = i + j;                              /* move past it */
232           end;                                              /* increment starting_level, then go test j */
233                                                             /* for root, we fall thru after setting starting_level to zero */
234 
235           call process (path, starting_level);              /* Looks innocent ... */
236 
237           if cpx > 0 then do;
238                sp = cp_array (0);
239                tn = tn + n;
240           end;
241           else tn = n;                                      /* to set dents below */
242           disk_stat.dtime = clock ();                       /* read clock */
243           quota = tot_dquota + tot_squota;
244           used = tot_dused + tot_sused;
245           call ioa_ ("^d/^d", quota, used);                 /* type total */
246           call ioa_ ("dir: ^d/^d", tot_dquota, tot_dused);
247           call ioa_ ("seg: ^d/^d", tot_squota, tot_sused);
248           disk_stat.dents = tn;
249           if fcbp ^= null then call msf_manager_$close (fcbp);
250           bitc = 36 * (lodh + tn * lode);                   /* Compute bit count. */
251           call hcs_$set_bc (dn, en, bitc, ec);              /* ... */
252 
253           if priv_set = 0 then call system_privilege_$dir_priv_off (priv_set);
254                                                             /* reset if we did it */
255 
256           return;                                           /* Done. */
257 %page;
258 process:
259      procedure (apth, lvl);
260 
261 /* internal doit procedure */
262 
263 dcl  apth char (168),                                       /* path of tree to process */
264      lvl fixed bin;                                         /* recursion level */
265 
266 dcl  npth char (168),                                       /* new path for recursion */
267      ddn char (168),                                        /* ... for expand */
268      een char (32),                                         /* ... */
269      error_table_$nomatch fixed bin (35) ext,
270      (stpp, dtpp) fixed bin (71),                           /* args for quota_read */
271      updatime fixed bin (35),
272      (squota, dquota, sused, dused) fixed bin,
273      slvid bit (36),
274      (dquota_sw, squota_sw) fixed bin (1),
275      ifail fixed bin,
276      ecc fixed bin (35),
277      (ii, nix) fixed bin;                                   /* indices */
278 dcl  sys_info$max_seg_size fixed bin (35) ext static;
279 
280           star_entry_ptr, star_names_ptr = null ();
281           on cleanup
282                begin;                                       /* get ready to undo everything */
283                     if star_names_ptr ^= null then free star_names;
284                     if star_entry_ptr ^= null then free star_entries;
285                     if ifail = 0 then call hcs_$delete_dir_acl_entries (ddn, een, addr (acld), 1, ecc);
286                end;
287 
288           call expand_pathname_ (apth, ddn, een, ecc);
289           if ecc ^= 0 then do;
290                call com_err_ (ecc, "sweep", "^a", apth);
291                return;
292           end;
293 
294           if hpriv
295           then ifail = 2;
296           else do;
297                call hcs_$add_dir_acl_entries (ddn, een, addr (acla), 1, ecc);
298                if ecc ^= 0
299                then ifail = 1;
300                else ifail = 0;
301           end;
302 
303           on seg_fault_error goto pexit;
304 
305           if hpriv
306           then call hphcs_$dir_quota_read (apth, dquota, dtpp, updatime, slvid, dquota_sw, dused, ecc);
307           else call hcs_$dir_quota_read (apth, dquota, dtpp, updatime, slvid, dquota_sw, dused, ecc);
308           if ecc ^= 0 then goto gq_err;
309 
310           if hpriv
311           then call hphcs_$quota_read (apth, squota, stpp, updatime, slvid, squota_sw, sused, ecc);
312           else call hcs_$quota_read (apth, squota, stpp, updatime, slvid, squota_sw, sused, ecc);
313           if ecc ^= 0 then do;
314 gq_err:
315                if ^bfsw then call com_err_ (ecc, "sweep", "getquota on ^a", apth);
316                go to pexit;
317           end;
318 
319           if dquota_sw + squota_sw ^= 0 then do;            /* if either dir quota or seg quota nonzero,
320                                                                add it in and keep recursing */
321                tot_dused = tot_dused + dused;               /* add up global use */
322                tot_sused = tot_sused + sused;
323                tot_dquota = tot_dquota + dquota;            /* and global quota */
324                tot_squota = tot_squota + squota;
325 
326                if (lodh + (n+1) * lode) > sys_info$max_seg_size then do;
327                     cpx = cpx + 1;
328                     call msf_manager_$msf_get_ptr (fcbp, cpx, "1"b, cp_array (cpx), 0, ec);
329                     if ec ^= 0 then do;
330                          call com_err_ (ec, "sweep", "Cannot expand MSF for ^a", en);
331                          goto pexit;
332                     end;
333                     sp = cp_array (cpx);
334                     tn = tn + n;
335                     n = 0;
336                end;
337                n = n + 1;                                   /* allocate a new slot */
338                disk_stat.spth (n) = apth;                   /* fill in path name */
339                disk_stat.sqta (n) = squota;                 /* segment quota */
340                disk_stat.dqta (n) = dquota;                 /* directory quota */
341 
342                if squota = 0 then stpp = 0;                 /* clear possible garbage, in case the */
343                if dquota = 0 then dtpp = 0;                 /* storage system is not careful about doing so */
344 
345                disk_stat.suse (n) = sused;                  /* segment pages used */
346                disk_stat.duse (n) = dused;                  /* directory pages used */
347                disk_stat.slvid (n) = slvid;                 /* son's lvid */
348                disk_stat.stpp (n) = stpp;                   /* segment time-page product */
349                disk_stat.dtpp (n) = dtpp;                   /* directory time-page product */
350                disk_stat.slev (n) = lvl;                    /* .. recursion level */
351 
352                if hpriv
353                then call hphcs_$star_ (apth, "**", star_BRANCHES_ONLY, areap, star_entry_count, star_entry_ptr,
354                          star_names_ptr, ecc);
355                else call hcs_$star_ (apth, "**", star_BRANCHES_ONLY, areap, star_entry_count, star_entry_ptr,
356                          star_names_ptr, ecc);
357                revert seg_fault_error;
358                if ecc = error_table_$nomatch then go to pexit;
359                                                             /* Get all names. If none, go. */
360                if ecc ^= 0 then do;                         /* If any other error from star, name it. */
361                     if ^bfsw then call com_err_ (ecc, "sweep", "star on ^a", apth);
362                     go to pexit;
363                end;
364 inloop:
365                do ii = 1 to star_entry_count;               /* Now do all branches, look for sub-dirs. */
366                     if star_entries (ii).type = star_DIRECTORY then do;
367                          nix = star_entries (ii).nindex;
368                          if apth ^= ">"                     /* Fabricate path name. */
369                          then npth = rtrim (apth) || ">" || star_names (nix);
370                          else do;                           /* The root is special. */
371                               npth = ">" || star_names (nix);
372                               if ^pddsw
373                               then                          /* unless user said to sweep >pdd */
374                                    if (npth = ">process_dir_dir")
375                                                             /* if this is >pdd */
376                                         | (npth = ">pdd") | (substr (npth, 1, 6) = ">pdd.!")
377                                    then goto nopdir;
378                          end;
379                          call process (npth, lvl + 1);      /* recursion here */
380 nopdir:
381                     end;
382                end inloop;
383                free star_names;
384                free star_entries;
385           end;
386 pexit:
387           if ppriv & hpriv then                             /* if privileged, prepare to clean up */
388                call phcs_$initiate (ddn, een, "", 0, 0, seg_ptr, ecc);
389           else seg_ptr = null;
390 
391           if (ifail = 0) & (apth ^= pdir) & ^pddsw
392           then                                              /* don't deny user access to his own pdir */
393                call hcs_$delete_dir_acl_entries (ddn, een, addr (acld), 1, ecc);
394 
395           if seg_ptr ^= null then do;                       /* now hardcore can't possibly want to touch the thing */
396                call hcs_$get_uid_seg (seg_ptr, uid, ecc);
397                if ecc = 0 then call hphcs_$deactivate (uid, ecc);
398                call phcs_$terminate_noname (seg_ptr, ecc);
399           end;
400           ecc = 0;
401 %page;
402 %include star_structures;
403 
404      end process;                                           /* Whew. */
405 %include access_mode_values;
406 %page;
407 
408      end sweep;