1 /* ******************************************************
  2    *                                                    *
  3    *                                                    *
  4    *    Copyright, (C) Honeywell Information Systems    *
  5    *    Inc., 1980.                                     *
  6    *                                                    *
  7    *                                                    *
  8    ****************************************************** */
  9 
 10 hunt: proc;
 11 
 12 /* HUNT - find a segment in a given subtree. */
 13 /* Modified 780905 by PG to terminate archive segments when finished with them. */
 14 /* Fixed to find secondary names and check for no r on an archive, 05/10/79 S. Herbst */
 15 /* Changed to call sweep_disk_$dir_list 05/29/79 S. Herbst */
 16 /* MCR 4264 fixed to complain about top node 01/07/80 S. Herbst */
 17 /* Implement as active function and fix for multiple archive names 05/14/80 S. Herbst */
 18 /* Fixed to work on the root 01/12/81 S. Herbst */
 19 /* Fixed not to stall when a damaged archive is hit, LA Newcomb, 3Nov1982 */
 20 /* Fixed to look at archive contents before the addmanes, LA Newcomb, 16Nov1982 */
 21 
 22 /* format:  style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */
 23 
 24 %include archive_header;
 25 %include branch_status;
 26 
 27 /* static */
 28 
 29 dcl  total                            fixed bin int static;
 30 dcl  R_ACCESS                         fixed bin (5) int static options (constant) init (01000b);
 31 dcl  S_ACCESS                         fixed bin (5) int static options (constant) init (01000b);
 32 
 33 dcl  arg                              char (arg_len) based (arg_ptr);
 34 dcl  return_arg                       char (return_len) varying based (return_ptr);
 35 dcl  dir_path                         char (168);
 36 dcl  starname                         char (32);
 37 
 38 dcl  (af_sw, allsw, archive_sw, firstsw, got_dir, got_starname) bit (1) aligned;
 39 
 40 dcl  (arg_ptr, header_ptr, return_ptr, segp) ptr;
 41 
 42 dcl  seg_mode                         fixed bin (5);
 43 dcl  (arg_count, arg_len, i, j, return_len) fixed bin;
 44 dcl  code                             fixed bin (35);
 45 
 46 dcl  error_table_$badopt              fixed bin (35) ext;
 47 dcl  error_table_$incorrect_access    fixed bin (35) ext;
 48 dcl  error_table_$no_s_permission     fixed bin (35) ext;
 49 dcl  error_table_$root                fixed bin (35) ext;
 50 dcl  error_table_$seg_busted          fixed bin (35) ext;
 51 
 52 dcl  complain                         entry variable options (variable);
 53 
 54 dcl  absolute_pathname_               entry (char (*), char (*), fixed bin (35));
 55 dcl  (active_fnc_err_, active_fnc_err_$suppress_name) entry options (variable);
 56 dcl  archive_util_$first_element      entry (ptr, fixed bin (35));
 57 dcl  archive_util_$next_element       entry (ptr, fixed bin (35));
 58 dcl  check_star_name_$entry           entry (char (*), fixed bin (35));
 59 dcl  (com_err_, com_err_$suppress_name) entry options (variable);
 60 dcl  cu_$af_return_arg                entry (fixed bin, ptr, fixed bin, fixed bin (35));
 61 dcl  cu_$arg_ptr                      entry (fixed bin, ptr, fixed bin, fixed bin (35));
 62 dcl  get_wdir_                        entry returns (char (168));
 63 dcl  hcs_$fs_get_mode                 entry (ptr, fixed bin (5), fixed bin (35));
 64 dcl  hcs_$initiate                    entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
 65 dcl  hcs_$status_                     entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
 66 dcl  hcs_$terminate_noname            entry (ptr, fixed bin (35));
 67 dcl  (ioa_, ioa_$rsnnl)               entry options (variable);
 68 dcl  match_star_name_                 entry (char (*), char (*), fixed bin (35));
 69 dcl  sweep_disk_$dir_list             entry (char (168), entry);
 70 
 71 dcl  (addr, fixed, length, null, rtrim, substr) builtin;
 72 dcl  (seg_fault_error, cleanup)       condition;
 73 %page;
 74           call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
 75           if code = 0 then do;
 76                af_sw = "1"b;
 77                complain = active_fnc_err_;
 78                return_arg = "";
 79           end;
 80           else do;
 81                af_sw = "0"b;
 82                complain = com_err_;
 83           end;
 84 
 85           allsw, firstsw, got_dir, got_starname = "0"b;
 86           archive_sw = "1"b;
 87 
 88           do i = 1 to arg_count;
 89 
 90                call cu_$arg_ptr (i, arg_ptr, arg_len, code);
 91 
 92                if substr (arg, 1, 1) ^= "-" then
 93                     if got_dir then do;
 94 USAGE:                   if af_sw then call active_fnc_err_$suppress_name (0, "hunt",
 95                                    "Usage:  [hunt starname {root_of_tree} {-control_arg}]");
 96                          else call com_err_$suppress_name (0, "hunt",
 97                                    "Usage:  hunt starname {root_of_tree} {-control_args}");
 98                          return;
 99                     end;
100                     else if got_starname then do;
101                          call absolute_pathname_ (arg, dir_path, code);
102                          if code ^= 0 then do;
103                               call complain (code, "hunt", "^a", arg);
104                               return;
105                          end;
106                          got_dir = "1"b;
107                     end;
108                     else do;
109                          starname = arg;
110                          call check_star_name_$entry (starname, code);
111                          if code ^= 0 & code ^= 1 & code ^= 2 then do;
112                               call complain (code, "hunt", "^a", starname);
113                               return;
114                          end;
115                          got_starname = "1"b;
116                     end;
117 
118 /* control arg */
119 
120                else if arg = "-all" | arg = "-a" then allsw = "1"b;
121                else if arg = "-first" | arg = "-ft" then firstsw = "1"b;
122                else if arg = "-archive" | arg = "-ac" then archive_sw = "1"b;
123                else if arg = "-no_archive" | arg = "-nac" then archive_sw = "0"b;
124                else do;
125                     call complain (error_table_$badopt, "hunt", "^a", arg);
126                     return;
127                end;
128           end;
129 
130           if ^got_starname then go to USAGE;
131           else if ^got_dir then dir_path = get_wdir_ ();
132 
133           call hcs_$status_ (dir_path, "", 1, addr (branch_status), null, code);
134           if code = error_table_$root then do;
135                code = 0;
136                branch_status.mode = "01000"b;
137           end;
138           if code ^= 0 & code ^= error_table_$no_s_permission & code ^= error_table_$incorrect_access then do;
139                call complain (code, "hunt", "^a", dir_path);
140                return;
141           end;
142           if fixed (branch_status.mode, 5) < S_ACCESS then do;
143                call complain (0, "hunt", "No s permission on ^a", dir_path);
144                return;
145           end;
146 
147           total = 0;
148 
149           segp = null ();                                   /* for cleaning up */
150           on cleanup begin;
151                     if segp ^= null () then
152                          call hcs_$terminate_noname (segp, code);
153                end;
154 
155           call sweep_disk_$dir_list (dir_path, counter);
156 
157 bust:     if ^af_sw then call ioa_ ("Total ^d", total);
158 
159           return;
160 %page;
161 counter: proc (sdn, sen, lvl, een, bptr, nptr);
162 
163 dcl  sdn                              char (168) aligned,   /* superior dir name */
164      sen                              char (32) aligned,    /* dirname */
165      lvl                              fixed bin,            /* distance from root */
166      een                              char (32),            /* entry name */
167      bptr                             ptr,                  /* ptr to info structure */
168      nptr                             ptr;                  /* ptr to names structure */
169 
170 dcl  xp                               char (168),
171      ename                            char (32),
172      (ni, xi)                         fixed bin;
173 
174 dcl  1 branch                         based (bptr) aligned, /* thing returned by star_long */
175        2 type                         bit (2) unal,
176        2 nname                        bit (16) unal,
177        2 nindex                       bit (18) unal,
178        2 dtm                          bit (36) unal,
179        2 dtu                          bit (36) unal,
180        2 mode                         bit (5) unal,
181        2 pad                          bit (13) unal,
182        2 records                      bit (18) unal;
183 
184 dcl  names                            (99 /* arbitrary */) char (32) aligned based (nptr);
185 
186 dcl  ecc                              fixed bin (35);
187 
188 dcl  (                                                      /* constants */
189      bty                              char (4) dim (0:3) init ("link", "seg", "dir", "??"),
190      SEG_TYPE                         fixed bin init (1)
191      )                                int static options (constant);
192 
193           call ioa_$rsnnl ("^a^[>^]^a", xp, xi, sdn, sdn ^= ">", sen);
194           if ^allsw then
195                if fixed (branch.type) ^= SEG_TYPE then
196                     return;
197           ecc = 1;                                          /* so loops will start */
198 %page;
199           if archive_sw then                                /* we are to check archive components */
200                if fixed (branch.type) = SEG_TYPE then do;   /* archive may only be a segment */
201 
202                     on seg_fault_error begin;               /* must handle damaged archives */
203                               call complain (error_table_$seg_busted, "hunt",
204                                    "^a^[>^]^a", xp, xp ^= ">", ename);
205                               go to check_storage_sys_name;
206                          end;
207 
208                     do ni = 1 to fixed (branch.nname) while (ecc ^= 0);
209 
210                          ename = names (fixed (branch.nindex) + ni - 1);
211 
212                          j = length (rtrim (ename));
213                          if j > 8 then
214                               if substr (ename, j - 7, 8) = ".archive" then do;
215                                    call hcs_$initiate (xp, ename, "", 0b, 0b, segp, ecc);
216                                    if segp = null then
217                                         go to check_storage_sys_name;
218                                    call hcs_$fs_get_mode (segp, seg_mode, ecc);
219                                    if ecc ^= 0 then
220                                         go to terminate_archive;
221                                    if seg_mode < R_ACCESS then
222                                         go to terminate_archive;
223                                    header_ptr = segp;
224                                    call archive_util_$first_element (header_ptr, ecc);
225                                    do while (ecc = 0);
226                                         call match_star_name_ ((header_ptr -> archive_header.name), starname, ecc);
227                                         if ecc = 0 then do;
228                                              total = total + 1;
229                                              if af_sw then do; /* append archive_path::component_name */
230                                                   if return_arg ^= "" then return_arg = return_arg || " ";
231                                                   if xp = ">" then return_arg = return_arg || ">";
232                                                   else return_arg = return_arg || rtrim (xp) || ">";
233                                                   return_arg = return_arg || rtrim (ename);
234                                                   return_arg = return_arg || "::";
235                                                   return_arg = return_arg || rtrim (header_ptr -> archive_header.name);
236                                              end;
237                                              else call ioa_ ("^a ^a^[>^]^a contains ^a", bty (fixed (branch.type)),
238                                                        xp, xp ^= ">", ename, header_ptr -> archive_header.name);
239                                              if firstsw then do;
240                                                   call hcs_$terminate_noname (segp, ecc);
241                                                   segp = null (); /* so cleanuyp doesn't get a crack at it */
242                                                   go to bust;
243                                              end;
244                                         end;
245                                         call archive_util_$next_element (header_ptr, ecc);
246                                    end;
247 terminate_archive:
248                                    call hcs_$terminate_noname (segp, ecc);
249                                    segp = null ();
250                                    go to check_storage_sys_name; /* done with the archive components */
251                               end;
252                     end;
253                end;
254 %page;
255 check_storage_sys_name:
256           ecc = 1;                                          /* so loop will go */
257           do ni = 1 to fixed (branch.nname) while (ecc ^= 0);
258                ename = names (fixed (branch.nindex) + ni - 1);
259                call match_star_name_ (ename, starname, ecc);
260                if ecc = 0 then do;
261                     total = total + 1;
262                     if af_sw then do;
263                          if return_arg ^= "" then return_arg = return_arg || " ";
264                          if xp ^= ">" then return_arg = return_arg || rtrim (xp);
265                          return_arg = return_arg || ">";
266                          return_arg = return_arg || rtrim (ename);
267                     end;
268                     else call ioa_ ("^a ^a^[>^]^a", bty (fixed (branch.type)), xp, xp ^= ">", ename);
269                     if firstsw then go to bust;
270                end;
271           end;
272 
273 
274           return;
275      end counter;
276 
277      end hunt;