/* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ execute_search_rules_: proc (rname, switches, dirname, ename, type, bit_count, code); /* Arguments */ dcl rname char (32); dcl switches bit (8) aligned; /* chase_sw,target_sw,priname_sw,known_sw, link_sw,error_sw,show_sw,noref_sw */ dcl dirname char (168); dcl ename char (32); dcl type fixed bin (2); dcl bit_count fixed bin (24); dcl code fixed bin (35); /* External Entries */ dcl get_default_wdir_ ext entry returns (char (168) aligned); dcl get_pdir_ ext entry returns (char (168) aligned); dcl get_wdir_ ext entry returns (char (168) aligned); dcl get_system_free_area_ ext entry returns (ptr); dcl cu_$stack_frame_ptr ext entry (ptr); dcl hcs_$fs_get_seg_ptr ext entry (char (*), ptr, fixed bin (35)); dcl hcs_$fs_get_path_name ext entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl hcs_$initiate ext entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$get_link_target ext entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$terminate_noname ext entry (ptr, fixed bin (35)); dcl hcs_$get_search_rules ext entry (ptr); dcl hcs_$status_long ext entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl hcs_$status_minf ext entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl ioa_ ext entry options (variable); dcl com_err_ ext entry options (variable); /* Error Table Entries */ dcl error_table_$bad_string ext fixed bin (35); /* bad search rule or dirname */ dcl error_table_$name_not_found ext fixed bin (35); /* if seg not initiated */ dcl error_table_$no_s_permission ext fixed bin (35); dcl error_table_$noentry ext fixed bin (35); /* ename not in this directory */ dcl error_table_$not_a_branch ext fixed bin (35); /* to tell caller that entry is a link */ dcl error_table_$segknown ext fixed bin (35); /* to tell caller that segment was initiated */ /* Work Variables */ /* SWITCHES: if = "1"b then: */ dcl chase_sw bit (1) aligned; /* return type and bitcount of target of link */ dcl target_sw bit (1) aligned; /* return pathname of target of link */ dcl priname_sw bit (1) aligned; /* return primary name on entry */ dcl known_sw bit (1) aligned; /* if init seg, return error_table_$segknown */ dcl link_sw bit (1) aligned; /* if a link, return error_table_$not_a_branch */ dcl error_sw bit (1) aligned; /* if error in using a rule, continue with others */ dcl show_sw bit (1) aligned; /* print rules, dirs, and error codes, while searching */ dcl noref_sw bit (1) aligned; /* don't use referencing dir rule */ dcl chase fixed bin (1); dcl search_rules_ptr ptr; dcl 1 search_rules aligned based (search_rules_ptr), 2 number fixed bin, 2 names (21) char (168) aligned; dcl 1 stack_search_rules like search_rules automatic; dcl names_needed bit (1) aligned; dcl no_s_permission bit (1) aligned; /* to remember that status long returned this code */ dcl it_was_a_link bit (1) aligned; /* to remember a link, when chasing it */ dcl (i, j) fixed bin; dcl ldn fixed bin; /* return from fs get path name */ dcl dummy_ename char (32); /* return from fs get path name, to avoid clobbering then original ename */ dcl dummy_dirname char (168); /* to avoid clobbering original dirname */ dcl dummy_segptr ptr; /* return from hcs initiate, to avoid clobbering original seg_ptr */ dcl me char (24) aligned int static init ("execute_search_rules_"); /* for com_err_ calls */ dcl stack_ptr ptr; dcl 1 stack_frame based (stack_ptr), 2 pad (16) bit (36), 2 back_ptr ptr, 2 next_ptr ptr, 2 return_ptr ptr, 2 entry_ptr ptr; /* we don't care about rest of frame */ dcl 1 long_branch aligned, /* structure for status long call */ (2 long_type bit (2), 2 nnames bit (16), 2 nrp bit (18)) unaligned, 2 pad (6) fixed bin (35), (2 curlen bit (12), 2 long_bitcount bit (24)) unaligned, 2 pad2 (2) fixed bin (35); dcl lg_type fixed bin (2); /* args for quick block: status_long_caller */ dcl lg_bitcount fixed bin (24); dcl lg_name char (32); dcl lg_priname_sw bit (1) aligned; dcl lg_chase fixed bin (1); dcl names (fnames) char (32) aligned based (ep); /* names array for status long call */ dcl fnames fixed bin; dcl ep ptr; dcl system_free_ptr ptr int static init (null); dcl system_free_area area based (system_free_ptr); dcl seg_ptr ptr; dcl error_code fixed bin (35) init (0); /* to save error codes */ dcl error_dir char (168) aligned; /* to save dir where error occurred */ dcl unexpected_error bit (1) aligned; /* to distinguish between "not found" and other errors (like no access, or dir does not exist) */ dcl (addr, fixed, null, ptr, substr) builtin; dcl cleanup condition; /* P R O C E D U R E */ search_rules_ptr = addr (stack_search_rules); call hcs_$get_search_rules (search_rules_ptr); start: ; /* come here from ptr entry point */ /* copy switch values to bit(1) aligned for faster accessing */ chase_sw = substr (switches, 1, 1); target_sw = substr (switches, 2, 1); priname_sw = substr (switches, 3, 1); known_sw = substr (switches, 4, 1); link_sw = substr (switches, 5, 1); error_sw = substr (switches, 6, 1); show_sw = substr (switches, 7, 1); noref_sw = substr (switches, 8, 1); if chase_sw & ^target_sw & ^link_sw then chase = 1; /* if we don't want to know about links, then set chase switch for status_minf call */ ename = rname; /* return the given rname as ename, unless we find, below, that: 1) rname is not a name on the entry, or 2) the primary name was requested, and is ^= rname */ type, bit_count = -1; /* to distinguish from meaningful values, in case of error */ search_loop: do i = 1 to search_rules.number; unexpected_error, it_was_a_link, no_s_permission, names_needed = "0"b; dirname = search_rules.names (i); if show_sw then call show (-3); /* if show_sw then call ioa_ ("^/RULE: ^a",dirname) */ if dirname = "" then goto end_search_loop; /* as a convenience to callers of the s_r_ptr entry, who may want to call get_search_rules, and delete some rules from the structure. */ if dirname = "initiated_segments" then check_init_segs: do; /* see if it is initiated */ call hcs_$fs_get_seg_ptr (ename, seg_ptr, code); if code ^= 0 then if show_sw then call show (1); /* if show_sw then call com_err_ (code,me,"from get seg ptr") */ if code ^= 0 then if code ^= error_table_$name_not_found then do; if ^error_sw then return; error_dir = dirname; error_code = code; unexpected_error = "1"b; end; if seg_ptr ^= null then it_was_init: do; call hcs_$fs_get_path_name (seg_ptr, dirname, ldn, dummy_ename, code); if code ^= 0 then do; if show_sw then call show (2); /* if show_sw then call com_err_ (code,me,"from get path name") */ if ^error_sw then return; error_dir = dirname; error_code = code; unexpected_error = "1"b; end; else got_pathname: do; call hcs_$status_minf (dirname, dummy_ename, chase, type, bit_count, code); if code ^= 0 then if show_sw then call show (3); /* if code ^= 0, we are returning anyway, so just return it */ if code = 0 then check_init_options: do; if priname_sw then /* if caller wants primary name */ ename = dummy_ename; /* then give him what fs_get_pathname returned */ else /* if caller wants rname instead of primary name */ if ename ^= dummy_ename then /* and they are different */ check_refname: do; /* see if refname matches any name on segment */ call hcs_$initiate (dirname, ename, "", 0, 0, dummy_segptr, code); /* try to initiate it using the reference name as the ename */ if seg_ptr ^= dummy_segptr /* if can't, or can but get different seg */ then ename = dummy_ename; /* then replace refname by a name on the seg */ if dummy_segptr ^= null then /* if initiate worked */ call hcs_$terminate_noname (dummy_segptr, code); /* then terminate it */ code = 0; /* in case initiate or terminate set it nonzero */ end check_refname; if known_sw then /* if caller wants to know about initiated segs */ code = error_table_$segknown; /* then tell him, just as hcs_$initiate does */ end check_init_options; return; /* skip rest of program */ end got_pathname; end it_was_init; end check_init_segs; else /* this rule is not "initiated_segments" */ check_non_init: do; /* process all the rest of the rules */ if substr (dirname, 1, 1) ^= ">" then /* if not a directory path */ interpret_rule: do; /* then get one, from the given rule */ if dirname = "referencing_dir" then get_refdir: do; if noref_sw then goto end_search_loop; /* skip this rule, if caller so requested */ call cu_$stack_frame_ptr (stack_ptr); /* get ptr to our stack frame */ stack_ptr = stack_frame.back_ptr; /* get ptr to caller's frame */ seg_ptr = stack_frame.entry_ptr; /* get ptr to caller */ /* get pathname of caller */ call hcs_$fs_get_path_name (seg_ptr, dirname, ldn, dummy_ename, code); /* we will use the directory portion of his pathname as the referencing_dir */ if code ^= 0 then do; if show_sw then call show (2); /* if show_sw then call com_err_ (code,me,"from get path name") */ if ^error_sw then return; error_dir = dirname; error_code = code; unexpected_error = "1"b; end; end get_refdir; else if dirname = "working_dir" then dirname = get_wdir_ (); else if dirname = "process_dir" then dirname = get_pdir_ (); else if dirname = "home_dir" then dirname = get_default_wdir_ (); else bad_search_rule: do; code = error_table_$bad_string; if show_sw then call show (0); /* if show_sw then call com_err_ (code,me) */ if ^error_sw then return; error_code = code; error_dir = dirname; unexpected_error = "1"b; end bad_search_rule; end interpret_rule; if show_sw then if dirname ^= search_rules.names (i) then /* if directory different from rule */ call show (-2); if ^unexpected_error then try_status: do; if priname_sw then do; /* call status long, to be sure we get the primary name */ lg_priname_sw = "1"b; lg_chase = chase; call status_long_caller; /* internal procedure to set up for status long call */ type = lg_type; bit_count = lg_bitcount; ename = lg_name; /* this will be the primary name */ end; else do; /* call status minf - we will return rname */ call hcs_$status_minf (dirname, ename, chase, type, bit_count, code); if code ^= 0 then if show_sw then call show (3); end; if code = error_table_$no_s_permission then goto found_it; if code = 0 then found_it: do; if type = 0 then /* if this is a link */ examine_link: do; if link_sw then /* if caller wants to know about links */ it_was_a_link = "1"b; /* remember to tell him so */ if target_sw then /* if caller wants name of target of links */ get_target: do; call hcs_$get_link_target (dirname, ename, dummy_dirname, dummy_ename, code); if code ^= 0 then do; if show_sw then call show (4); /* if show_sw then call com_err_ (code,me,"from get link target") */ if ^error_sw then return; error_code = code; error_dir = dirname; unexpected_error = "1"b; end; end get_target; if ^unexpected_error then get_target_info: do; if target_sw then /* if we got the target pathname */ if dummy_ename ^= ename then /* and its ename ^= the one the caller sent */ if ^priname_sw then /* and the caller wants his, if it is on the entry */ names_needed = "1"b; /* then we must call status long, to get the names */ if ^names_needed then if chase_sw then do; /* if just chase, get target status */ call hcs_$status_minf (dirname, ename, 1, type, bit_count, code); if code ^= 0 then do; if show_sw then call show (3); if ^error_sw then return; error_dir = dirname; error_code = code; unexpected_error = "1"b; end; end; if names_needed then do; /* call status long? */ lg_priname_sw = "0"b; lg_chase = 1; call status_long_caller; if code = 0 then /* if code ^= 0, lg_name = ename; we don't want that for the target */ dummy_ename = lg_name; /* rname, or primary name, if rname not on entry */ if chase_sw then do; /* copy target status */ type = lg_type; bit_count = lg_bitcount; end; /* end copy target status */ end; /* end wants target path */ if target_sw then do; /* copy return args from get link target */ dirname = dummy_dirname; ename = dummy_ename; /* may have been changed in get_target_info */ end; end get_target_info; end examine_link; if ^unexpected_error then do; if it_was_a_link /* if first status call found a link, and user asked to be told */ then if code = 0 /* and there was no other error code */ then code = error_table_$not_a_branch; /* then return the "it was a link" code */ return; end; end found_it; if code ^= error_table_$noentry then do; if ^error_sw then return; error_code = code; error_dir = dirname; end; end try_status; end check_non_init; end_search_loop: end search_loop; /* fall thru when we run out of search rules */ if error_code ^= 0 then do; /* if an unexpected error occurred */ code = error_code; /* that might be reason for not finding it */ dirname = error_dir; /* tell caller which rule had problem */ end; else /* if nothing special, we just didn't find it */ code = error_table_$noentry; if show_sw then call show (-1); /* if show_sw then call com_err_ (code,me,ename) */ return; /* I N T E R N A L P R O C E D U R E S */ status_long_caller: proc; /* procedure to call hcs_$status long, set up a cleanup handler to free the names array, examine the names, look for no_s_permission return code, and print error code if show switch is on */ nnames = (16)"0"b; /* for benefit of cleanup handler */ on condition (cleanup) begin; if nnames ^= (16)"0"b then do; /* check this, instead of ep, since we build ep using ptr function, and might not have done so yet */ ep = ptr (system_free_ptr, fixed (nrp)); /* build ptr to names array */ free ep -> names in (system_free_area); /* free it */ end; /* end do group */ end; /* end begin block */ if system_free_ptr = null then /* first time only */ system_free_ptr = get_system_free_area_ (); /* get ptr to system free area */ call hcs_$status_long (dirname, ename, lg_chase, addr (long_branch), system_free_ptr, code); if code ^= 0 then do; if show_sw then call show (5); lg_name = ename; /* always return a name */ if code = error_table_$no_s_permission then no_s_permission = "1"b; else return; /* if not the above, we have no good info */ end; lg_type = fixed (long_type); if lg_type = 0 then /* status long does not return a bitcount, for links */ lg_bitcount = 0; else lg_bitcount = fixed (long_bitcount); if no_s_permission then return; /* if we got status but no names */ fnames = fixed (nnames); /* length of names array */ ep = ptr (system_free_ptr, fixed (nrp)); /* pointer to it */ if lg_priname_sw then lg_name = names (1); else do; do j = 1 to fnames /* look thru names on entry */ while (names (j) ^= ename); /* to see if ename is one of them */ end; if j > fnames then /* if it isn't */ lg_name = names (1); /* return the primary name */ else lg_name = ename; /* if it is, return it */ end; revert cleanup; /* revert first; freeing non allocated variable usually clobbers the area badly enough to crash the process at the next attempted allocation */ free ep -> names in (system_free_area); /* free the names array */ return; end status_long_caller; show: proc (action_code); dcl action_code fixed bin; dcl message char (32) aligned; dcl messages (5) char (32) int static aligned init ( "from hcs_$fs_get_seg_ptr", "from hcs_$fs_get_path_name", "from hcs_$status_minf", "from hcs_$get_link_target", "from hcs_$status_long"); if action_code > 0 then positive: do; if action_code > 5 then return; /* bad code - don't bother with error message */ message = messages (action_code); end positive; else negative: do; if action_code = -3 then do; call ioa_ ("^/RULE: ^a", dirname); return; end; if action_code = -2 then do; call ioa_ (dirname); return; end; else if action_code = -1 then message = ename; else if action_code = 0 then message = ""; else return; /* bad code - don't bother with error message */ end negative; call com_err_ (code, "execute_search_rules_", message); return; end show; /* E N T R Y */ s_r_ptr: entry (rname, switches, sptr, dirname, ename, type, bit_count, code); /* entry to use search rule structure supplied by caller, instead of the search rules currently in effect */ dcl sptr ptr; search_rules_ptr = sptr; goto start; end execute_search_rules_; */ ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved */