1
2
3
4
5
6
7
8
9
10 hunt: proc;
11
12
13
14
15
16
17
18
19
20
21
22
23
24 %include archive_header;
25 %include branch_status;
26
27
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
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 ();
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,
164 sen char (32) aligned,
165 lvl fixed bin,
166 een char (32),
167 bptr ptr,
168 nptr ptr;
169
170 dcl xp char (168),
171 ename char (32),
172 (ni, xi) fixed bin;
173
174 dcl 1 branch based (bptr) aligned,
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 ) char (32) aligned based (nptr);
185
186 dcl ecc fixed bin (35);
187
188 dcl (
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;
198 %page;
199 if archive_sw then
200 if fixed (branch.type) = SEG_TYPE then do;
201
202 on seg_fault_error begin;
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;
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 ();
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;
251 end;
252 end;
253 end;
254 %page;
255 check_storage_sys_name:
256 ecc = 1;
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;