1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4         *                                                         *
  5         * Copyright (c) 1972 by Massachusetts Institute of        *
  6         * Technology and Honeywell Information Systems, Inc.      *
  7         *                                                         *
  8         *********************************************************** */
  9 
 10 
 11 
 12 
 13 /****^  HISTORY COMMENTS:
 14   1) change(86-05-02,Elhard), approve(86-05-02,MCR7391),
 15      audit(86-09-04,DGHowe), install(86-11-20,MR12.0-1222):
 16      Modified to find object MSFs when searching manually and to properly
 17      display pathnames for MSF targets.
 18                                                    END HISTORY COMMENTS */
 19 
 20 
 21 where: wh: procedure options (variable);
 22 
 23 /* This command prints the primary pathname of the first segment or
 24    entry point with a given name found using the object segment search rules.
 25 
 26    Usage:
 27    where names -control_args-
 28 
 29    where control_args are:
 30 
 31    -all, -a             list all segments or entry points in the search path.
 32    -inhibit_error, -ihe supress error message when segment not found and returns null string as AF.
 33    -entry_point, -ep    look for name$name when name does not contain a $.
 34    -segment, -sm, -file look for the file named name even if name contains a $.
 35 
 36    The default is to look for an entry point if name contains a $, file otherwise.
 37 
 38    Usage as an active function:
 39 
 40    [where name -control_arg-]
 41 
 42    where control_arg is either -entry_point (-ep) or -file (-segment, -sm).
 43 */
 44 /* Written 3/5/76 by Steve Herbst */
 45 /* Entry point feature added 12/3/76 by S. Herbst */
 46 /* fixed to show orig not copy if uninitiated seg has copysw on 03/20/80 S. Herbst */
 47 /* Modified: 06/06/80, W. Olin Sibert, to add where -brief */
 48 /* Fixed to work on gates 07/15/81 S. Herbst */
 49 /* Fixed bugs and made -brief -all work 10/06/82 S. Herbst */
 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,                                 /* from hcs_$get_search_rules */
 62     2 rule_count fixed bin,
 63     2 rule (21) char (168);
 64 
 65 dcl 1 search_dirs (21),                                     /* directories to search through */
 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); /* if called as active function */
 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);            /* com_err_ or active_fnc_err_ */
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 /* ^L */
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;             /* a refname we should locate */
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;                      /* must get search rules, to locate manually */
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;                              /* find all the genuine directories */
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 /* ^L */
244 
245           do refname_idx = 1 to refname_count;              /* Now, decide what to do with each of out reference name */
246 
247                name = refnames (refname_idx);
248 
249                idx = index (name, "$");
250                if (idx ^= 0) & ^all_segments then do;       /* name$entry */
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;            /* -entry_point specified */
258                     entry_point = "1"b;
259                     entry_point_name = name;
260                end;
261 
262                else do;
263                     entry_point = "0"b;                     /* reference name */
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 /* ^L */
278 
279                if ^search_manually then do;                 /* locate by the usual (linker) mechanism */
280 
281                     terminate = "0"b;
282                     call hcs_$fs_get_seg_ptr (name, seg_ptr, code); /* already initiated? */
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;                       /* just assign it to the return arg, and punt */
315                          return_arg = out_str;
316                          goto MAIN_RETURN;
317                     end;
318 
319                     else call ioa_ ("^a", out_str);
320                end;                                         /* of searching non-manually (via hcs_$make_ptr) */
321 
322 /* ^L */
323 
324                else do;                                     /* we must search for the segment manually */
325                                                             /* Note that this is never done for an AF. */
326                     if (idx > 1) & some_output & all_sw then          /* separate -all outputs by a blank line */
327                          call ioa_ ("");
328 
329                     some_output, some_segs = "0"b;
330 
331                     if try_initiated_segs then do;          /* search rules contained "initiated_segments" */
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;                               /* of successfully finding segment by refname */
351                     end;                                    /* of trying "initiated_segments" */
352 
353                     do dir_idx = 1 to dir_count;            /* try to initiate in each of the dirs in the search rules */
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;                               /* end of case for being able to initiate segment */
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;                               /* end of MSF indirection */
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;            /* print each path only once */
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;          /* print formatted line */
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;                               /* of case for unable to initiate segment */
429                     end;                                    /* of loop through dirs in search rules */
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;                                         /* of case for searching manually */
437 NEXT:     end;                                              /* end of refname loop */
438 
439 MAIN_RETURN:
440           call clean_up;
441           return;
442 
443 /* ^L */
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 /* This internal procedure gets the pathname of a segment found.  If  */
465 /* the segment is an MSF component, it backs up 1 level.              */
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 /* This internal procedure looks for an external definition. */
484 
485           call hcs_$fs_get_mode (seg_ptr, fmode, code);
486           if fmode < R_ACCESS_BIN then do;                  /* inner ring seg: gate? */
487                                                             /* make sure make_ptr finds this one */
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;                 /* only print each path once */
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;