1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21 where: wh: procedure options (variable);
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52 %include access_mode_values;
53
54 %include branch_status;
55
56 %include object_info;
57 dcl 1 obj_info like object_info;
58
59 dcl refnames (32) char (168);
60
61 dcl 1 search_rules aligned,
62 2 rule_count fixed bin,
63 2 rule (21) char (168);
64
65 dcl 1 search_dirs (21),
66 2 dir char (168),
67 2 uid bit (36),
68 2 rule_number fixed bin;
69
70 dcl area area based (area_ptr);
71
72 dcl arg char (arg_len) based (arg_ptr);
73 dcl return_arg char (return_len) varying based (return_ptr);
74 dcl primary_name char (32) aligned based;
75 dcl (dn, entry_point_name, name) char (168);
76 dcl (en, unique_name) char (32);
77 dcl out_str char (256);
78 dcl type fixed bin (2);
79
80 dcl (af_sw, all_sw, brief_sw, long_sw, all_entry_points, all_segments, entry_point, inhibit_error, printed_sw,
81 search_manually, some_output, some_segs, terminate, try_initiated_segs, dir_found) bit (1) aligned;
82
83 dcl (area_ptr, arg_ptr, entry_point_ptr, names_ptr, return_ptr, seg_ptr) ptr;
84
85 dcl fmode fixed bin (5);
86 dcl (arg_count, arg_len, dir_count, refname_count, return_len) fixed bin;
87 dcl (argno, dir_idx, idx, refname_idx, uid_idx) fixed bin;
88 dcl bit_count fixed bin (24);
89 dcl code fixed bin (35);
90
91 dcl (error_table_$badopt,
92 error_table_$inconsistent,
93 error_table_$dirseg,
94 error_table_$no_dir,
95 error_table_$no_s_permission,
96 error_table_$noentry,
97 error_table_$entlong,
98 error_table_$not_act_fnc) fixed bin (35) external static;
99
100 dcl complain entry variable options (variable);
101 dcl get_arg variable entry (fixed bin, ptr, fixed bin, fixed bin (35));
102
103 dcl active_fnc_err_ entry options (variable);
104 dcl com_err_ entry options (variable);
105 dcl cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
106 dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
107 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
108 dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35));
109 dcl get_definition_ entry (ptr, char (*), char (*), ptr, fixed bin (35));
110 dcl get_system_free_area_ entry returns (ptr);
111 dcl get_wdir_ entry returns (char (168));
112 dcl hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35));
113 dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
114 dcl hcs_$get_search_rules entry (ptr);
115 dcl hcs_$fs_get_seg_ptr entry (char (*), ptr, fixed bin (35));
116 dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
117 dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35));
118 dcl hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
119 dcl hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
120 dcl hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
121 dcl hcs_$status_mins entry (ptr, fixed bin(2), fixed bin(24), fixed bin(35));
122 dcl hcs_$terminate_name entry (char (*), fixed bin (35));
123 dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
124 dcl ioa_ entry options (variable);
125 dcl ioa_$rsnnl entry options (variable);
126 dcl ioa_$nnl entry options (variable);
127 dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35));
128 dcl pathname_ entry (char (*), char (*)) returns (char (168));
129 dcl unique_chars_ entry (bit (*)) returns (char (15));
130
131 dcl WHOAMI char (32) internal static options (constant) init ("where");
132
133 dcl cleanup condition;
134
135 dcl (addr, bit, char, hbound, index, length, null, ptr, rtrim, substr) builtin;
136
137
138
139 all_sw, all_entry_points, all_segments, brief_sw = "0"b;
140 inhibit_error, long_sw, search_manually, some_output = "0"b;
141 names_ptr = null ();
142 area_ptr = get_system_free_area_ ();
143
144 call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
145 if code = error_table_$not_act_fnc then do;
146 af_sw = "0"b;
147 complain = com_err_;
148 get_arg = cu_$arg_ptr;
149 end;
150 else do;
151 af_sw = "1"b;
152 complain = active_fnc_err_;
153 get_arg = cu_$af_arg_ptr;
154 return_arg = "";
155 end;
156
157 if arg_count = 0 then do;
158 USAGE: if af_sw then call active_fnc_err_ (0, WHOAMI, "Usage: [^a refname {-control_args}]", WHOAMI);
159 else call com_err_ (0, WHOAMI, "Usage: ^a refnames {-control_args}", WHOAMI);
160 goto MAIN_RETURN;
161 end;
162
163 on condition (cleanup) call clean_up;
164
165 refname_count = 0;
166
167 do argno = 1 to arg_count;
168 call get_arg (argno, arg_ptr, arg_len, code);
169
170 if char (arg, 1) ^= "-" then do;
171 refname_count = refname_count+1;
172 if refname_count > hbound (refnames, 1) then do;
173 call complain (0, WHOAMI, "Too many reference names specified. Max is ^d.",
174 hbound (refnames, 1));
175 goto MAIN_RETURN;
176 end;
177
178 refnames (refname_count) = arg;
179 end;
180
181 else if (arg = "-all" | arg = "-a") then
182 if af_sw then do;
183 AF_BAD_OPT:
184 call complain (0, WHOAMI, "Control arg not allowed for the active function. ^a", arg);
185 return;
186 end;
187 else all_sw = "1"b;
188
189 else if (arg = "-long" | arg = "-lg") then
190 if af_sw then go to AF_BAD_OPT;
191 else do;
192 long_sw = "1"b;
193 brief_sw = "0"b;
194 end;
195
196 else if (arg = "-brief" | arg = "-bf") then
197 if af_sw then go to AF_BAD_OPT;
198 else do;
199 brief_sw = "1"b;
200 long_sw = "0"b;
201 end;
202
203 else if (arg = "-entry_point") | (arg = "-ep") then all_entry_points = "1"b;
204 else if (arg = "-file") | (arg = "-segment") | (arg = "-sm") then all_segments = "1"b;
205
206 else if (arg = "-inhibit_error") | (arg = "-ihe") then inhibit_error = "1"b;
207 else if (arg = "-no_inhibit_error") | (arg = "-nihe") then inhibit_error = "0"b;
208 else do;
209 call complain (error_table_$badopt, WHOAMI, "^a", arg);
210 goto MAIN_RETURN;
211 end;
212 end;
213
214 if refname_count = 0 | (af_sw & refname_count > 1) then
215 goto USAGE;
216
217 if all_entry_points & all_segments then do;
218 call complain (error_table_$inconsistent, WHOAMI, "-segment and -entry_point");
219 goto MAIN_RETURN;
220 end;
221
222 if all_sw & ^brief_sw then long_sw = "1"b;
223
224 if long_sw | all_sw then do;
225
226 search_manually = "1"b;
227
228 call hcs_$get_search_rules (addr (search_rules));
229 dir_count = 0;
230 try_initiated_segs = "0"b;
231
232 do idx = 1 to rule_count;
233 if rule (idx) = "initiated_segments" then try_initiated_segs = "1"b;
234 else if rule (idx) ^= "referencing_dir" then do;
235 dir_count = dir_count + 1;
236 if rule (idx) = "working_dir" then dir (dir_count) = get_wdir_ ();
237 else dir (dir_count) = rule (idx);
238 rule_number (dir_count) = idx;
239 end;
240 end;
241 end;
242
243
244
245 do refname_idx = 1 to refname_count;
246
247 name = refnames (refname_idx);
248
249 idx = index (name, "$");
250 if (idx ^= 0) & ^all_segments then do;
251 entry_point_name = substr (name, idx + 1);
252 name = substr (name, 1, idx - 1);
253 if entry_point_name = "" then entry_point = "0"b;
254 else entry_point = "1"b;
255 end;
256
257 else if all_entry_points then do;
258 entry_point = "1"b;
259 entry_point_name = name;
260 end;
261
262 else do;
263 entry_point = "0"b;
264 entry_point_name = "";
265 end;
266
267 if length (rtrim (name)) > 32 then do;
268 call complain (error_table_$entlong, WHOAMI, "^a", name);
269 goto NEXT;
270 end;
271
272 else if length (rtrim (entry_point_name)) > 32 then do;
273 call complain (error_table_$entlong, WHOAMI, "^a", entry_point_name);
274 goto NEXT;
275 end;
276
277
278
279 if ^search_manually then do;
280
281 terminate = "0"b;
282 call hcs_$fs_get_seg_ptr (name, seg_ptr, code);
283 if seg_ptr = null then do;
284 terminate = "1"b;
285 call hcs_$make_ptr (null (), name, "", seg_ptr, code);
286 if code ^= 0 then do;
287 if ^inhibit_error then call complain (code, WHOAMI, "^a", name);
288 goto NEXT;
289 end;
290 end;
291
292 call get_pathname (seg_ptr, dn, en, code);
293 if code ^= 0 then do;
294 call complain (code, WHOAMI, "^a", name);
295 goto NEXT;
296 end;
297
298 if entry_point then do;
299
300 call find_entry_point;
301
302 if terminate then call hcs_$terminate_name (name, (0));
303 if code ^= 0 then do;
304 call complain (code, WHOAMI, "^a$^a", pathname_ (dn, en), entry_point_name);
305 goto NEXT;
306 end;
307 end;
308
309 else if terminate then call hcs_$terminate_name (name, code);
310
311 call ioa_$rsnnl ("^a^[$^a^;^s^]", out_str, (0),
312 pathname_ (dn, en), entry_point, entry_point_name);
313
314 if af_sw then do;
315 return_arg = out_str;
316 goto MAIN_RETURN;
317 end;
318
319 else call ioa_ ("^a", out_str);
320 end;
321
322
323
324 else do;
325 Note
326 if (idx > 1) & some_output & all_sw then
327 call ioa_ ("");
328
329 some_output, some_segs = "0"b;
330
331 if try_initiated_segs then do;
332 dir_idx = 0;
333 call hcs_$fs_get_seg_ptr (name, seg_ptr, code);
334 if seg_ptr ^= null () then do;
335 some_segs = "1"b;
336 call get_pathname (seg_ptr, dn, en, code);
337 if code ^= 0 then call complain (code, WHOAMI, "^a", name);
338
339 else do;
340 if entry_point then call find_entry_point ();
341
342 if code ^= 0 then call complain (code, WHOAMI,
343 "^a$^a Search rule ""initiated_segments""",
344 pathname_ (dn, en), entry_point_name);
345
346 else call print_pathname ();
347
348 if ^all_sw then go to NEXT;
349 end;
350 end;
351 end;
352
353 do dir_idx = 1 to dir_count;
354 dir_found = "0"b;
355 call hcs_$initiate (dir (dir_idx), name, "", 0, 1, seg_ptr, code);
356 INITIATED: if seg_ptr ^= null then do;
357 some_segs = "1"b;
358 call get_pathname (seg_ptr, dn, en, code);
359 if code ^= 0 then do;
360 code = 0;
361 dn = dir (dir_idx);
362 en = substr (name, 1, 32);
363 end;
364
365 if entry_point then call find_entry_point ();
366 if code ^= 0 then call complain (code, WHOAMI, "^a$^a (Search rule ""^a"")",
367 pathname_ (dn, en), entry_point_name, rule (rule_number (dir_idx)));
368
369 else call print_pathname ();
370
371 call hcs_$terminate_noname (seg_ptr, (0));
372 if ^all_sw then go to NEXT;
373 end;
374
375 else if code = error_table_$dirseg & ^dir_found then do;
376 call hcs_$status_minf (dir (dir_idx), name, 1, type, bit_count, code);
377 if code = 0 & type = 2 & bit_count > 0 then do;
378 dn = pathname_ (dir (dir_idx), name);
379 en = "0";
380 dir_found = "1"b;
381 call hcs_$initiate (dn, en, "", 0, 0, seg_ptr, code);
382 goto INITIATED;
383 end;
384 end;
385
386 else if code ^= error_table_$noentry & code ^= error_table_$no_dir &
387 code ^= error_table_$dirseg then do;
388
389 some_output, some_segs = "1"b;
390
391 if entry_point then call complain (code, WHOAMI, "^a (Search rule ""^a"")",
392 pathname_ (dir (dir_idx), name), rule (rule_number (dir_idx)));
393
394 else do;
395 if brief_sw & all_sw then do;
396 call hcs_$status_long (dir (dir_idx), name, 1, addr (branch_status), null, code);
397 uid (dir_idx) = branch_status.unique_id;
398 printed_sw = "0"b;
399 do uid_idx = 1 to dir_idx - 1;
400 if uid (uid_idx) = branch_status.unique_id then printed_sw = "1"b;
401 end;
402 if ^printed_sw then call ioa_ ("^a", pathname_ (dir (dir_idx), name));
403 end;
404 else do;
405 call hcs_$status_ (dir (dir_idx), name, 1, addr (branch_status), area_ptr, code);
406 if code = 0 then do;
407 names_ptr = ptr (area_ptr, branch_status.names_rel_pointer);
408 if long_sw then call ioa_ ("^a (^a) Search rule ""^a""",
409 pathname_ (dir (dir_idx), (names_ptr -> primary_name)),
410 get_mode_letters (branch_status.mode), rule (rule_number (dir_idx)));
411 else call ioa_ ("^a", pathname_ (dir (dir_idx), name));
412
413 if ^all_sw then go to NEXT;
414 end;
415
416 else if code = error_table_$no_s_permission then
417 call complain (0, WHOAMI,
418 "No status permission on ^a (Search rule ""^a"")",
419 dir (dir_idx), rule (rule_number (dir_idx)));
420
421 else if code ^= error_table_$noentry then
422 call complain (code, WHOAMI, "^a (Search rule ""^a"")",
423 dir (dir_idx), rule (rule_number (dir_idx)));
424
425 else some_output = "0"b;
426 end;
427 end;
428 end;
429 end;
430
431 if ^some_output & ^inhibit_error then
432 if entry_point & some_segs then call complain (0, WHOAMI, "Entry point not found. ^a$^a",
433 name, entry_point_name);
434 else call complain (0, WHOAMI, "Segment not found. ^a", name);
435
436 end;
437 NEXT: end;
438
439 MAIN_RETURN:
440 call clean_up;
441 return;
442
443
444
445
446 clean_up: proc;
447
448 if names_ptr ^= null then free names_ptr -> primary_name in (area);
449
450 end clean_up;
451
452
453 get_pathname: proc (seg_ptr, dn, en, code);
454
455 dcl seg_ptr ptr parameter;
456 dcl dn char (*) parameter;
457 dcl en char (*) parameter;
458 dcl code fixed bin (35) parameter;
459 dcl cdn char (168);
460 dcl cen char (32);
461 dcl type fixed bin (2);
462 dcl bc fixed bin (24);
463
464
465
466
467 call hcs_$fs_get_path_name (seg_ptr, dn, (0), en, code);
468 if code ^= 0
469 then return;
470 call hcs_$status_minf (dn, "", 1, type, bc, code);
471 if type = 2 & bc > 0 & code = 0
472 then do;
473 call expand_pathname_ (dn, cdn, cen, code);
474 dn = cdn;
475 en = cen;
476 end;
477
478 end get_pathname;
479
480
481 find_entry_point: proc;
482
483
484
485 call hcs_$fs_get_mode (seg_ptr, fmode, code);
486 if fmode < R_ACCESS_BIN then do;
487
488 unique_name = unique_chars_ ("0"b);
489 call hcs_$initiate (dn, en, unique_name, 0, 1, seg_ptr, code);
490 call hcs_$make_ptr (null, unique_name, entry_point_name, entry_point_ptr, code);
491 call hcs_$terminate_name (unique_name, 0);
492 end;
493 else do;
494 call hcs_$status_mins (seg_ptr, (0), bit_count, code);
495 call object_info_$brief (seg_ptr, bit_count, addr (obj_info), code);
496 if code ^= 0 then return;
497 call get_definition_ (obj_info.defp, name, entry_point_name, null, code);
498 end;
499
500 end find_entry_point;
501
502
503 print_pathname: proc;
504
505 some_output = "1"b;
506 call hcs_$fs_get_mode (seg_ptr, fmode, code);
507 if code ^= 0 then fmode = 0;
508
509 if long_sw then do;
510 call ioa_$nnl ("^a^[$^a^;^s^] (^a) Search rule ",
511 pathname_ (dn, en), entry_point, entry_point_name, get_mode_letters (bit (fmode)));
512 if dir_idx = 0 then call ioa_ ("""initiated_segments""");
513 else call ioa_ ("""^a""", rule (rule_number (dir_idx)));
514 end;
515 else do;
516 call hcs_$status_long (dn, en, 1, addr (branch_status), null, code);
517 uid (dir_idx) = branch_status.unique_id;
518 printed_sw = "0"b;
519 do uid_idx = 1 to dir_idx-1;
520 if uid (uid_idx) = branch_status.unique_id then printed_sw = "1"b;
521 end;
522 if ^printed_sw then call ioa_ ("^a", pathname_ (dn, en));
523 end;
524
525 end print_pathname;
526
527
528 get_mode_letters: proc (mode_bits) returns (char (4)varying);
529
530 dcl mode_bits bit (5);
531 dcl amode char (4) varying;
532
533 amode = "";
534 if substr (mode_bits, 2, 1) ^= "0"b then amode = "r";
535 if substr (mode_bits, 3, 1) ^= "0"b then amode = amode||"e";
536 if substr (mode_bits, 4, 1) ^= "0"b then amode = amode||"w";
537 if amode = "" then amode = "null";
538 return (amode);
539
540 end get_mode_letters;
541
542 end where;