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 execute_search_rules_: proc (rname, switches, dirname, ename, type, bit_count, code);
 12 
 13 /*   Arguments */
 14 
 15 dcl  rname char (32);
 16 dcl  switches bit (8) aligned;                              /* chase_sw,target_sw,priname_sw,known_sw,
 17                                                                link_sw,error_sw,show_sw,noref_sw */
 18 dcl  dirname char (168);
 19 dcl  ename char (32);
 20 dcl  type fixed bin (2);
 21 dcl  bit_count fixed bin (24);
 22 dcl  code fixed bin (35);
 23 
 24 
 25 /*    External Entries     */
 26 
 27 dcl  get_default_wdir_ ext entry returns (char (168) aligned);
 28 dcl  get_pdir_ ext entry returns (char (168) aligned);
 29 dcl  get_wdir_ ext entry returns (char (168) aligned);
 30 dcl  get_system_free_area_ ext entry returns (ptr);
 31 
 32 dcl  cu_$stack_frame_ptr ext entry (ptr);
 33 dcl  hcs_$fs_get_seg_ptr ext entry (char (*), ptr, fixed bin (35));
 34 dcl  hcs_$fs_get_path_name ext entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
 35 dcl  hcs_$initiate ext entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
 36 dcl  hcs_$get_link_target ext entry (char (*), char (*), char (*), char (*), fixed bin (35));
 37 dcl  hcs_$terminate_noname ext entry (ptr, fixed bin (35));
 38 
 39 
 40 dcl  hcs_$get_search_rules ext entry (ptr);
 41 
 42 dcl  hcs_$status_long ext entry
 43     (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
 44 
 45 dcl  hcs_$status_minf ext entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
 46      fixed bin (35));
 47 dcl  ioa_ ext entry options (variable);
 48 dcl  com_err_ ext entry options (variable);
 49 
 50 /*        Error Table Entries           */
 51 
 52 dcl  error_table_$bad_string ext fixed bin (35);            /* bad search rule or dirname */
 53 dcl  error_table_$name_not_found ext fixed bin (35);        /* if seg not initiated */
 54 dcl  error_table_$no_s_permission ext fixed bin (35);
 55 dcl  error_table_$noentry ext fixed bin (35);               /* ename not in this directory */
 56 dcl  error_table_$not_a_branch ext fixed bin (35);          /* to tell caller that entry is a link */
 57 dcl  error_table_$segknown ext fixed bin (35);              /* to tell caller that segment was initiated */
 58 
 59 
 60 /*     Work Variables     */
 61 
 62 /*                                                          SWITCHES: if = "1"b then:               */
 63 dcl  chase_sw bit (1) aligned;                              /* return type and bitcount of target of link */
 64 dcl  target_sw bit (1) aligned;                             /* return pathname of target of link */
 65 dcl  priname_sw bit (1) aligned;                            /* return primary name on entry */
 66 dcl  known_sw bit (1) aligned;                              /* if init seg, return error_table_$segknown */
 67 dcl  link_sw bit (1) aligned;                               /* if a link, return error_table_$not_a_branch */
 68 dcl  error_sw bit (1) aligned;                              /* if error in using a rule, continue with others */
 69 dcl  show_sw bit (1) aligned;                               /* print rules, dirs, and error codes, while searching */
 70 dcl  noref_sw bit (1) aligned;                              /* don't use referencing dir rule */
 71 
 72 dcl  chase fixed bin (1);
 73 
 74 dcl  search_rules_ptr ptr;
 75 dcl 1 search_rules aligned based (search_rules_ptr),
 76     2 number fixed bin,
 77     2 names (21) char (168) aligned;
 78 
 79 dcl 1 stack_search_rules like search_rules automatic;
 80 
 81 dcl  names_needed bit (1) aligned;
 82 dcl  no_s_permission bit (1) aligned;                       /* to remember that status long returned this code */
 83 dcl  it_was_a_link bit (1) aligned;                         /* to remember a link, when chasing it */
 84 dcl (i, j) fixed bin;
 85 dcl  ldn fixed bin;                                         /* return from fs get path name */
 86 dcl  dummy_ename char (32);                                 /* return from fs get path name, to avoid clobbering
 87                                                                then original ename */
 88 dcl  dummy_dirname char (168);                              /* to avoid clobbering original dirname */
 89 dcl  dummy_segptr ptr;                                      /* return from hcs initiate, to avoid clobbering
 90                                                                original seg_ptr */
 91 
 92 dcl  me char (24) aligned int static init ("execute_search_rules_"); /* for com_err_ calls */
 93 
 94 dcl  stack_ptr ptr;
 95 
 96 dcl 1 stack_frame based (stack_ptr),
 97     2 pad (16) bit (36),
 98     2 back_ptr ptr,
 99     2 next_ptr ptr,
100     2 return_ptr ptr,
101     2 entry_ptr ptr;
102                                                             /* we don't care about rest of frame */
103 
104 dcl 1 long_branch aligned,                                  /* structure for status long call */
105     (2 long_type bit (2),
106     2 nnames bit (16),
107     2 nrp bit (18)) unaligned,
108     2 pad (6) fixed bin (35),
109     (2 curlen bit (12),
110     2 long_bitcount bit (24)) unaligned,
111     2 pad2 (2) fixed bin (35);
112 
113 dcl  lg_type fixed bin (2);                                 /* args for quick block: status_long_caller */
114 dcl  lg_bitcount fixed bin (24);
115 dcl  lg_name char (32);
116 dcl  lg_priname_sw bit (1) aligned;
117 dcl  lg_chase fixed bin (1);
118 
119 dcl  names (fnames) char (32) aligned based (ep);           /* names array for status long call */
120 
121 dcl  fnames fixed bin;
122 dcl  ep ptr;
123 dcl  system_free_ptr ptr int static init (null);
124 dcl  system_free_area area based (system_free_ptr);
125 
126 dcl  seg_ptr ptr;
127 
128 dcl  error_code fixed bin (35) init (0);                    /* to save error codes */
129 dcl  error_dir char (168) aligned;                          /* to save dir where error occurred */
130 dcl  unexpected_error bit (1) aligned;                      /* to distinguish between "not found"
131                                                                and other errors (like no access, or dir does not exist) */
132 
133 
134 dcl (addr, fixed, null, ptr, substr) builtin;
135 
136 dcl  cleanup condition;
137 
138 /*     P  R  O  C  E  D  U  R  E     */
139           search_rules_ptr  = addr (stack_search_rules);
140           call hcs_$get_search_rules (search_rules_ptr);
141 
142 start:    ;                                                 /* come here from ptr entry point */
143 
144 
145 /* copy switch values to bit(1) aligned for faster accessing */
146           chase_sw = substr (switches, 1, 1);
147           target_sw = substr (switches, 2, 1);
148           priname_sw = substr (switches, 3, 1);
149           known_sw = substr (switches, 4, 1);
150           link_sw = substr (switches, 5, 1);
151           error_sw = substr (switches, 6, 1);
152           show_sw = substr (switches, 7, 1);
153           noref_sw = substr (switches, 8, 1);
154 
155           if chase_sw & ^target_sw & ^link_sw then chase = 1; /* if we don't want to know about links,
156                                                                then set chase switch for status_minf call */
157 
158           ename = rname;                                    /* return the given rname as ename, unless we find, below, that:
159                                                                1) rname is not a name on the entry, or
160                                                                2) the primary name was requested, and is ^= rname */
161 
162           type, bit_count = -1;                             /* to distinguish from meaningful values, in case of error */
163 
164 search_loop: do i = 1 to search_rules.number;
165 
166                unexpected_error, it_was_a_link, no_s_permission, names_needed = "0"b;
167 
168                dirname = search_rules.names (i);
169 
170                if show_sw then
171                call show (-3);                              /* if show_sw then call ioa_ ("^/RULE: ^a",dirname) */
172 
173                if dirname = "" then goto end_search_loop;   /* as a convenience to callers of the s_r_ptr
174                                                                entry, who may want to call get_search_rules,
175                                                                and delete some rules from the structure. */
176 
177 
178                if dirname = "initiated_segments" then
179 check_init_segs: do;                                        /* see if it is initiated */
180 
181                     call hcs_$fs_get_seg_ptr (ename, seg_ptr, code);
182 
183                     if code ^= 0 then
184                     if show_sw then
185                     call show (1);                          /* if show_sw then call com_err_ (code,me,"from get seg ptr") */
186 
187                     if code ^= 0 then
188                     if code ^= error_table_$name_not_found then do;
189 
190                          if ^error_sw then return;
191                          error_dir = dirname;
192                          error_code = code;
193                          unexpected_error = "1"b;
194                     end;
195 
196                     if seg_ptr ^= null then
197 it_was_init:        do;
198 
199                          call hcs_$fs_get_path_name (seg_ptr, dirname, ldn, dummy_ename, code);
200 
201                          if code ^= 0 then do;
202 
203                               if show_sw then
204                               call show (2);                /* if show_sw then
205                                                                call com_err_ (code,me,"from get path name") */
206 
207                               if ^error_sw then return;
208                               error_dir = dirname;
209                               error_code = code;
210                               unexpected_error = "1"b;
211                          end;
212 
213                          else
214 got_pathname:            do;
215 
216                               call hcs_$status_minf (dirname, dummy_ename, chase, type, bit_count, code);
217 
218                               if code ^= 0 then
219                               if show_sw then
220                               call show (3);
221 
222 /* if code ^= 0, we are returning anyway, so just return it */
223 
224                               if code = 0 then
225 check_init_options:           do;
226 
227                                    if priname_sw then       /* if caller wants primary name */
228                                    ename = dummy_ename;     /* then give him what fs_get_pathname returned */
229                                    else                     /* if caller wants rname instead of primary name */
230                                    if ename ^= dummy_ename then /* and they are different */
231 check_refname:                     do;                      /* see if refname matches any name on segment */
232 
233                                         call hcs_$initiate (dirname, ename, "", 0, 0, dummy_segptr, code);
234                                                             /* try to initiate it using the reference name as the ename */
235                                         if seg_ptr ^= dummy_segptr /* if can't, or can but get different seg */
236                                         then ename = dummy_ename; /* then replace refname by a name on the seg */
237 
238                                         if dummy_segptr ^= null then /* if initiate worked */
239                                         call hcs_$terminate_noname (dummy_segptr, code); /* then terminate it */
240 
241                                         code = 0;           /* in case initiate or terminate set it nonzero */
242 
243                                    end check_refname;
244 
245                                    if known_sw then         /* if caller wants to know about initiated segs */
246                                    code = error_table_$segknown; /* then tell him, just as hcs_$initiate does */
247 
248                               end check_init_options;
249 
250 
251                               return;                       /* skip rest of program */
252 
253                          end got_pathname;
254 
255                     end it_was_init;
256 
257                end check_init_segs;
258 
259                else                                         /* this rule is not "initiated_segments" */
260 check_non_init: do;                                         /* process all the rest of the rules */
261 
262                     if substr (dirname, 1, 1) ^= ">" then   /* if not a directory path */
263 interpret_rule:     do;                                     /* then get one, from the given rule */
264 
265                          if dirname = "referencing_dir" then
266 get_refdir:              do;
267 
268                               if noref_sw then goto end_search_loop; /* skip this rule, if caller so requested */
269 
270                               call cu_$stack_frame_ptr (stack_ptr); /* get ptr to our stack frame */
271                               stack_ptr = stack_frame.back_ptr; /* get ptr to caller's frame */
272                               seg_ptr = stack_frame.entry_ptr; /* get ptr to caller */
273                                                             /* get pathname of caller */
274                               call hcs_$fs_get_path_name (seg_ptr, dirname, ldn, dummy_ename, code);
275                                                             /* we will use the directory portion of his pathname
276                                                                as the referencing_dir */
277 
278                               if code ^= 0 then do;
279                                    if show_sw then
280                                    call show (2);           /* if show_sw then
281                                                                call com_err_ (code,me,"from get path name") */
282 
283                                    if ^error_sw then return;
284                                    error_dir = dirname;
285                                    error_code = code;
286                                    unexpected_error = "1"b;
287                               end;
288 
289                          end get_refdir;
290 
291                          else if dirname = "working_dir" then
292                          dirname = get_wdir_ ();
293 
294                          else if dirname = "process_dir" then
295                          dirname = get_pdir_ ();
296 
297                          else if dirname = "home_dir" then
298                          dirname = get_default_wdir_ ();
299 
300                          else
301 bad_search_rule:         do;
302                               code = error_table_$bad_string;
303                               if show_sw then
304                               call show (0);                /* if show_sw then call com_err_ (code,me) */
305 
306                               if ^error_sw then return;
307                               error_code = code;
308                               error_dir = dirname;
309                               unexpected_error = "1"b;
310                          end bad_search_rule;
311 
312                     end interpret_rule;
313 
314                     if show_sw then
315                     if dirname ^= search_rules.names (i) then /* if directory different from rule */
316                     call show (-2);
317 
318                     if ^unexpected_error then
319 try_status:         do;
320 
321                          if priname_sw then do;             /* call status long, to be sure we get the primary name */
322                               lg_priname_sw = "1"b;
323                               lg_chase = chase;
324                               call status_long_caller;      /* internal procedure to set up for status long call */
325                               type = lg_type;
326                               bit_count = lg_bitcount;
327                               ename = lg_name;              /* this will be the primary name */
328                          end;
329 
330                          else do;                           /*  call status minf - we will return rname */
331                               call hcs_$status_minf (dirname, ename, chase, type, bit_count, code);
332 
333                               if code ^= 0 then
334                               if show_sw then
335                               call show (3);
336                          end;
337 
338                          if code = error_table_$no_s_permission then goto found_it;
339                          if code = 0 then
340 found_it:                do;
341 
342                               if type = 0 then              /* if this is a link */
343 examine_link:                 do;
344 
345                                    if link_sw then          /* if caller wants to know about links */
346                                    it_was_a_link = "1"b;    /* remember to tell him so */
347                                    if target_sw then        /* if caller wants name of target of links */
348 get_target:                        do;
349 
350                                         call hcs_$get_link_target (dirname, ename, dummy_dirname, dummy_ename, code);
351 
352                                         if code ^= 0 then do;
353 
354                                              if show_sw then
355                                              call show (4); /* if show_sw then
356                                                                call com_err_ (code,me,"from get link target") */
357                                              if ^error_sw then return;
358 
359                                              error_code = code;
360                                              error_dir = dirname;
361                                              unexpected_error = "1"b;
362                                         end;
363 
364                                    end get_target;
365 
366                                    if ^unexpected_error then
367 get_target_info:                   do;
368                                         if target_sw then   /* if we got the target pathname */
369                                         if dummy_ename ^= ename then /* and its ename ^= the one the caller sent */
370                                         if ^priname_sw then /* and the caller wants his, if it is on the entry */
371                                         names_needed = "1"b; /* then we must call status long, to get the names */
372 
373                                         if ^names_needed then if chase_sw then do; /* if just chase, get target status */
374                                              call hcs_$status_minf (dirname, ename, 1, type, bit_count, code);
375                                              if code ^= 0 then do;
376                                                   if show_sw then
377                                                   call show (3);
378                                                   if ^error_sw then return;
379                                                   error_dir = dirname;
380                                                   error_code = code;
381                                                   unexpected_error = "1"b;
382                                              end;
383                                         end;
384 
385                                         if names_needed then do; /* call status long? */
386                                              lg_priname_sw = "0"b;
387                                              lg_chase = 1;
388                                              call status_long_caller;
389                                              if code = 0 then /* if code ^= 0, lg_name = ename;
390                                                                we don't want that for the target */
391                                              dummy_ename = lg_name; /* rname, or primary name, if rname not on entry */
392                                              if chase_sw then do; /* copy target status */
393                                                   type = lg_type;
394                                                   bit_count = lg_bitcount;
395                                              end;           /* end copy target status */
396                                         end;                /* end wants target path */
397 
398                                         if target_sw then do; /* copy return args from get link target */
399                                              dirname = dummy_dirname;
400                                              ename = dummy_ename; /* may have been changed in get_target_info */
401                                         end;
402 
403                                    end get_target_info;
404 
405 
406                               end examine_link;
407 
408                               if ^unexpected_error then do;
409                                    if it_was_a_link         /* if first status call found a link,
410                                                                and user asked to be told */
411                                    then if code = 0         /* and there was no other error code */
412                                    then code = error_table_$not_a_branch; /* then return the "it was a link" code */
413                                    return;
414                               end;
415 
416                          end found_it;
417 
418                          if code ^= error_table_$noentry then do;
419 
420                               if ^error_sw then return;
421 
422                               error_code = code;
423                               error_dir = dirname;
424                          end;
425 
426                     end try_status;
427 
428                end check_non_init;
429 
430 end_search_loop:
431           end search_loop;
432 
433 /* fall thru when we run out of search rules */
434 
435           if error_code ^= 0 then do;                       /* if an unexpected error occurred */
436                code = error_code;                           /* that might be reason for not finding it */
437                dirname = error_dir;                         /* tell caller which rule had problem */
438           end;
439 
440           else                                              /* if nothing special, we just didn't find it */
441           code = error_table_$noentry;
442 
443           if show_sw then
444           call show (-1);                                   /* if show_sw then call com_err_ (code,me,ename) */
445           return;
446 
447 
448 /*   I  N  T  E  R  N  A  L     P  R  O  C  E  D  U  R  E  S       */
449 
450 
451 
452 
453 status_long_caller: proc;                                   /* procedure to call hcs_$status long, set up a
454                                                                cleanup handler to free the names array, examine the names,
455                                                                look for no_s_permission return code, and print
456                                                                error code if show switch is on */
457 
458                nnames = (16)"0"b;                           /* for benefit of cleanup handler */
459                on condition (cleanup) begin;
460 
461                     if nnames ^= (16)"0"b then do;          /* check this, instead of ep, since we build
462                                                                ep using ptr function, and might not have done so yet */
463                          ep = ptr (system_free_ptr, fixed (nrp)); /* build ptr to names array */
464                          free ep -> names in (system_free_area); /* free it */
465                     end;                                    /* end do group */
466                end;                                         /* end begin block */
467 
468                if system_free_ptr = null then               /* first time only */
469                system_free_ptr = get_system_free_area_ ();  /* get ptr to system free area */
470 
471                call hcs_$status_long (dirname, ename, lg_chase, addr (long_branch), system_free_ptr, code);
472 
473                if code ^= 0 then do;
474                     if show_sw then call show (5);
475                     lg_name = ename;                        /* always return a name */
476                     if code = error_table_$no_s_permission then no_s_permission = "1"b;
477                     else return;                            /* if not the above, we have no good info */
478                end;
479 
480                lg_type = fixed (long_type);
481                if lg_type = 0 then                          /* status long does not return a bitcount, for links */
482                lg_bitcount = 0;
483                else lg_bitcount = fixed (long_bitcount);
484 
485                if no_s_permission then return;              /* if we got status but no names */
486 
487                fnames = fixed (nnames);                     /* length of names array */
488                ep = ptr (system_free_ptr, fixed (nrp));     /* pointer to it */
489 
490                if lg_priname_sw then lg_name = names (1);
491 
492                else do;
493 
494                     do j = 1 to fnames                      /* look thru names on entry */
495                          while (names (j) ^= ename);        /* to see if ename is one of them */
496                     end;
497 
498                     if j > fnames then                      /* if it isn't */
499                     lg_name = names (1);                    /* return the primary name */
500                     else lg_name = ename;                   /* if it is, return it */
501                end;
502                revert cleanup;                              /* revert first; freeing non allocated variable usually
503                                                                clobbers the area badly enough to crash the process
504                                                                at the next attempted allocation */
505                free ep -> names in (system_free_area);      /* free the names array */
506 
507                return;
508 
509           end status_long_caller;
510 
511 
512 show:     proc (action_code);
513 
514 dcl  action_code fixed bin;
515 
516 dcl  message char (32) aligned;
517 
518 dcl  messages (5) char (32) int static aligned init (
519      "from hcs_$fs_get_seg_ptr",
520      "from hcs_$fs_get_path_name",
521      "from hcs_$status_minf",
522      "from hcs_$get_link_target",
523      "from hcs_$status_long");
524 
525                if action_code > 0 then
526 positive:      do;
527                     if action_code > 5 then return;         /* bad code - don't bother with error message */
528                     message = messages (action_code);
529                end positive;
530 
531                else
532 negative:      do;
533                     if action_code = -3 then do;
534                          call ioa_ ("^/RULE: ^a", dirname);
535                          return;
536                     end;
537 
538                     if action_code = -2 then do;
539                          call ioa_ (dirname);
540                          return;
541                     end;
542 
543                     else if action_code = -1 then
544                     message = ename;
545                     else if action_code = 0 then
546                     message = "";
547                     else return;                            /* bad code - don't bother with error message */
548 
549                end negative;
550 
551                call com_err_ (code, "execute_search_rules_", message);
552                return;
553           end show;
554 
555 
556 /*      E  N  T  R  Y      */
557 
558 
559 s_r_ptr:  entry (rname, switches, sptr, dirname, ename, type, bit_count, code);
560 
561 /* entry to use search rule structure supplied by caller, instead of the search rules currently in effect */
562 
563 
564 dcl  sptr ptr;
565 
566           search_rules_ptr = sptr;
567           goto start;
568 
569 
570 
571 
572      end execute_search_rules_;