access_class_check.pl1 11/11/89 1132.4r w 11/11/89 0800.4 95823 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-12-17,Lippard), approve(87-08-24,MCR7760), audit(88-02-03,Fawcett), install(88-02-16,MR12.2-1022): Make reset_soos work on segments. END HISTORY COMMENTS */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ /* Initial coding by Kobziar July 74 */ /* Modified 750523 by LJS to add protection auditing */ /* Modified 06/01/76 by R. Bratt to call find_$finished */ /* Modified 07/77 by THVV for bad_dir_ check */ /* Modified 06/84 by Keith Loepere to use the new dc_find. */ /* Modified 84-12-03 by EJ Sharpe for access_audit_ */ /* Modified 85-04-01 by Keith Loepere for access_audit_check_ep_. */ access_class_check: proc (a_dirname, a_ename, a_code); /* This procedure turns security_oosw off if dir consistent within AI rules */ dcl a_code fixed bin (35) parameter; dcl a_dirname char (*) parameter; dcl a_ename char (*) parameter; dcl access_class bit (72) aligned; dcl code fixed bin (35); dcl crunch_sw bit (1) init ("0"b); dcl d_access_class bit (72) aligned; dcl dep ptr; dcl dirname char (168); dcl dirlocked bit (1) aligned init ("0"b); dcl ename char (32); dcl entries_in_dir fixed bin; dcl 1 event_flags aligned like audit_event_flags; dcl got_branch bit (1) init ("0"b); dcl i fixed bin; dcl len fixed bin; dcl pathname char (168); dcl pdep ptr; dcl 1 qcell like quota_cell aligned auto; dcl relp bit (18); dcl segment bit (1) aligned; dcl unlock_parent_parent bit (1) init ("1"b); dcl access_audit_check_ep_$self entry (bit (36) aligned, bit (36) aligned, ptr) returns (bit (1)); dcl access_audit_$log_entry_ptr entry options (variable); dcl aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned) reducible; dcl aim_check_$greater entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned) reducible; dcl lock$dir_unlock entry (ptr); dcl level$get entry () returns (fixed bin); dcl status_$get_access_class entry (char (*), char (*), bit (72) aligned, fixed bin (35)); dcl sum$dirmod entry (ptr); dcl sum$getbranch entry (ptr, bit (36) aligned, ptr, fixed bin (35)); dcl sum$getbranch_root_my entry (ptr, bit (36) aligned, ptr, fixed bin (35)); dcl vtoc_attributes$get_quota entry (bit (36) aligned, bit (36) aligned, fixed bin (17), ptr, fixed bin, fixed bin (35)); dcl access_operations_$fs_obj_set_soos ext bit (36) aligned; dcl error_table_$ai_son_less ext fixed bin (35); dcl error_table_$argerr ext fixed bin (35); dcl error_table_$bad_dir ext fixed bin (35); dcl error_table_$notadir ext fixed bin (35); dcl error_table_$root ext fixed bin (35); dcl error_table_$rqover ext fixed bin (35); dcl pds$processid bit (36) aligned ext; dcl (addr, fixed, length, null, ptr, rtrim, string, substr) builtin; dcl bad_dir_ condition; dcl CHASE fixed bin (1) aligned internal static options (constant) init (1); %page; START: segment = "0"b; dirname = a_dirname; ename = a_ename; /* get full dirname into pathname */ len = length (rtrim (dirname)); /* Find length. Accept imbedded blanks. */ if ename ^= "" then do; if len + length (rtrim (ename)) + 1 > length (pathname) then do; /* path name too long */ bad_path: code = error_table_$argerr; goto early_fail; end; if len = 1 then pathname = substr (dirname, 1, 1) || ename; /* dir is root */ else pathname = substr (dirname, 1, len) || ">" || ename; end; else do; /* no ename */ if len >= length (pathname) then goto bad_path; /* enough checking */ pathname = dirname; /* only dirname valid */ end; /* get access class of dir */ call status_$get_access_class (pathname, "", access_class, code); if code ^= 0 then if code = error_table_$root then access_class = "0"b; else goto early_fail; /* map root's imaginary value */ call dc_find$dir_read (pathname, dp, code); if code = error_table_$notadir then do; call dc_find$obj_status_read (dirname, ename, CHASE, ep, code); segment = "1"b; end; if code ^= 0 then goto early_fail; dirlocked = "1"b; if ^segment then do; i = 0; entries_in_dir = dir.seg_count + dir.dir_count + dir.lcount; do relp = dir.entryfrp repeat entry.efrp while (relp); /* see if equal class */ ep = ptr (dp, relp); i = i + 1; if i > entries_in_dir then signal bad_dir_; if ^entry.bs then go to loop_cont; /* skip links */ if entry.owner ^= dir.uid | (entry.type ^= SEG_TYPE & entry.type ^= DIR_TYPE) then signal bad_dir_; if ^aim_check_$equal (access_class, entry.access_class) then do; if ^entry.multiple_class then goto err; /* if not equal then check for consistent upgrade */ if ^aim_check_$greater (entry.access_class, access_class) then goto err; if ^entry.dirsw then do; /* a segment can be upgraded only if in ring 1 */ if fixed (entry.ring_brackets (3)) > 1 then goto err; else goto loop_cont; end; /* a directory */ else do; call vtoc_attributes$get_quota (entry.uid, (entry.pvid), (entry.vtocx), addr (qcell), 0, code); if code ^= 0 then goto fail; if ^qcell.terminal_quota_sw then do; code = error_table_$rqover; goto fail; end; end; end; else if entry.multiple_class then goto err; /* can't be multiple class if equal */ loop_cont: end; end; /* directory */ if segment then dp = ptr (ep, 0); call sum$getbranch (dp, "1"b, dep, code); if code ^= 0 then goto fail1; got_branch = "1"b; if segment then do; if ^aim_check_$equal (entry.access_class, dep -> entry.access_class) then if ^entry.multiple_class | ^aim_check_$greater (entry.access_class, dep -> entry.access_class) then do; code = error_table_$ai_son_less; goto fail1; end; if entry.security_oosw then do; /* If it was out of service, we are making it in-service */ entry.security_oosw = "0"b; string (event_flags) = ""b; event_flags.special_op = "1"b; event_flags.grant = "1"b; event_flags.priv_op = "1"b; if access_audit_check_ep_$self (string (event_flags), access_operations_$fs_obj_set_soos, dep) then call access_audit_$log_entry_ptr ("access_class_check", level$get (), string (event_flags), access_operations_$fs_obj_set_soos, dep, code, null (), 0, "switch turned off"); ptr (dep, 0) -> dir.modify = "0"b; call sum$dirmod (dp); end; goto unlock3; end; call sum$getbranch_root_my (ptr (dep, 0), "0"b, pdep, code); /* get the parent's access_class */ if code ^= 0 then /* up to the root ? */ if code = error_table_$root then do; unlock_parent_parent = "0"b; d_access_class = "0"b; /* root at 0 */ code = 0; /* clear for return */ end; else goto unlock3; /* no other err acceptable */ /* successful */ else d_access_class = pdep -> entry.access_class; /* save this */ if unlock_parent_parent then call lock$dir_unlock (ptr (pdep, 0)); if aim_check_$greater (access_class, d_access_class) then do; /* this is an upgraded dir */ call vtoc_attributes$get_quota (dep -> entry.uid, (dep -> entry.pvid), (dep -> entry.vtocx), addr (qcell), 0, code); if code ^= 0 then goto fail; if ^qcell.terminal_quota_sw then do; code = error_table_$rqover; goto fail; end; end; else if ^aim_check_$equal (access_class, d_access_class) then do; code = error_table_$bad_dir; goto fail; end; /* success */ if dep -> entry.security_oosw then do; /* If it was out of service, we are making it in-service */ ptr (dep, 0) -> dir.modify = pds$processid; dep -> entry.security_oosw = "0"b; string (event_flags) = ""b; event_flags.special_op = "1"b; event_flags.grant = "1"b; event_flags.priv_op = "1"b; if access_audit_check_ep_$self (string (event_flags), access_operations_$fs_obj_set_soos, dep) then call access_audit_$log_entry_ptr ("access_class_check", level$get (), string (event_flags), access_operations_$fs_obj_set_soos, dep, code, null (), 0, "switch turned off"); end; ptr (dep, 0) -> dir.modify = "0"b; call sum$dirmod (ptr (dep, 0)); /* Must be done with dir locked */ unlock3: call lock$dir_unlock (ptr (dep, 0)); fail1: call dc_find$finished (dp, dirlocked); early_fail: a_code = code; return; err: code = error_table_$bad_dir; fail: if crunch_sw then do; /* FAILURE. If requested we will set out of service */ if ^got_branch then call sum$getbranch (dp, "1"b, dep, (0)); got_branch = "1"b; ptr (dep, 0) -> dir.modify = pds$processid; dep -> entry.security_oosw = "1"b; string (event_flags) = ""b; event_flags.special_op = "1"b; event_flags.grant = "1"b; event_flags.priv_op = "1"b; if access_audit_check_ep_$self (string (event_flags), access_operations_$fs_obj_set_soos, dep) then call access_audit_$log_entry_ptr ("access_class_check", level$get (), string (event_flags), access_operations_$fs_obj_set_soos, dep, code, null (), 0, "switch turned on"); ptr (dep, 0) -> dir.modify = "0"b; call sum$dirmod (ptr (dep, 0)); end; if got_branch then call lock$dir_unlock (ptr (dep, 0)); go to fail1; aim_check_soos: entry (a_dirname, a_ename, a_code); crunch_sw = "1"b; go to START; %page; %include access_audit_eventflags; %page; %include dc_find_dcls; %page; %include dir_header; %page; %include dir_entry; %page; %include fs_obj_access_codes; %page; %include fs_types; %page; %include quota_cell; %page; /* BEGIN MESSAGE DOCUMENTATION Message: AUDIT (access_class_check): GRANTED modification of security out_of_service ADDED_INFO S: $access_audit T: $run M: The soos switch for the specified path has been turned on or off by the security administrator as indicated. A: $ignore END MESSAGE DOCUMENTATION */ end access_class_check;  acl.pl1 11/11/89 1132.4r w 11/11/89 0800.0 244872 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ acl: proc; /* This is the acl write around for the directory change of 1972. */ /****^ HISTORY COMMENTS: 1) change(73-01-21,Kobziar), approve(), audit(), install(): Remove append from segments and obsolete CACLs. 2) change(73-02-01,EStone), approve(), audit(), install(): Rewritten in v2pl1 for performance improvements. 3) change(74-10-01,EStone), approve(), audit(), install(): Place uid and dtem in double word. 4) change(75-04-25,Greenberg), approve(), audit(), install(): Modified by BSG for NSS and no perm acls. 5) change(76-06-01,RBratt), approve(), audit(), install(): Modified to call find_$finished. 6) change(76-06-01,VanVleck), approve(), audit(), install(): Modified by THVV for no perm acls. 7) change(77-07-01,VanVleck), approve(), audit(), install(): Modified for bad_dir_ check. 8) change(83-08-01,Kittlitz), approve(), audit(), install(): Modified by E. N. Kittlitz for setfault$if_active pvid, vtocx args. 9) change(84-06-01,Loepere), approve(), audit(), install(): Modified by Keith Loepere for the new dc_find. 10) change(84-10-01,Loepere), approve(), audit(), install(): Modified for auditing operation as access change. 11) change(86-06-03,Lippard), approve(86-09-04,MCR7534), audit(86-09-11,Dickson), install(86-09-16,MR12.0-1159): Modified by Jim Lippard to make dir modes RW rather than null. END HISTORY COMMENTS */ /* Strategy used is to move input structure into an automatic structure acl(100) and call the new single acl primitives , thus avoiding seg faults while dir locked */ /* The entries to this routine are name entry switch $aadd 1 $a1add 1 $areplace 2 $adelete 3 $alist 4 Up to 100 entries are handeled and the arguments for all but alist and a1add are 1) a_dirname character(*) a directory path name. (Input) 2) a_ename character(*) an entry name for this acl; was null for now obselete cacl. (Input) 3) a_aclp pointer a pointer to an array of data to be entered or returned. (Input) 4) a_aclct fixed bin (17) a count of the number of entries in the array. (Output/alist Input/others) 5) a_code fixed bin (17) an error code. (Output) For $alist the argument a_uap is a pointer to a user area where the output will beallocated. For $a1add the first two arguments are as above and the rest are 1) a_name character(*) name to be added to the ACL. (Input) 2) a_mode fixed bin (5) the mode. (Input) 3) a_rb fixed bin (6) the ring brackets. (Input) This routine will do as much as it can, processing good entries in the data array and returning an error code in acla(i).reterr for the bad entries as well as an error code in a_code. If a_aclct = -1 for $adelete or if a_uap is non-null for $alist then the whole ACL list (up to 100 entries) will be listed or deleted as requested. The target ACL for replace is deleted before the new entries are made. */ %page; /* Parameters */ dcl a_aclct fixed bin parameter; dcl a_aclp ptr parameter; dcl a_code fixed bin (35) parameter; dcl a_dirname char (*) parameter; dcl a_ename char (*) parameter; dcl a_mode fixed bin (5) parameter; dcl a_name char (*) parameter; dcl a_rb (3) fixed bin (6) parameter; dcl a_uap ptr parameter; /* Constants */ dcl add fixed bin static options (constant) init (0); dcl add_one fixed bin static options (constant) init (1); dcl delete fixed bin static options (constant) init (3); dcl list fixed bin static options (constant) init (4); dcl replace fixed bin static options (constant) init (2); /* Variables */ dcl 1 acl (100) aligned like temp_acl; dcl access_id char (32) varying; dcl acl_start_ptr ptr; dcl aclp ptr; dcl add_sw bit (1); dcl all bit (1) aligned; dcl count fixed bin; dcl cnt fixed bin; dcl code fixed bin (35); dcl dirname char (168); dcl dirsw bit (1) aligned; dcl dummy char (32) aligned; dcl entryname char (32); dcl fail_sw bit (1) aligned; dcl function fixed bin; dcl gate bit (1) aligned; dcl i fixed bin; dcl in_aclp ptr; dcl j fixed bin; dcl name char (32) aligned; dcl offset fixed bin; dcl p ptr; dcl ring (3) bit (3) aligned; dcl ringno fixed bin; dcl uap ptr; /* External */ dcl error_table_$argerr fixed bin (35) ext; dcl error_table_$bad_ring_brackets fixed bin (35) ext; dcl error_table_$invalid_mode fixed bin (35) ext; dcl error_table_$invalid_project_for_gate fixed bin (35) ext; dcl error_table_$noalloc fixed bin (35) ext; dcl error_table_$obsolete_function fixed bin (35) ext; dcl 1 pds$access_name aligned ext, 2 person char (32), 2 project char (32), 2 tag (1); dcl pds$processid bit (36) aligned ext; /* Based */ dcl 1 acla (100) aligned based (aclp) like input_acl; dcl 1 input_acl aligned based, 2 userid char (32) aligned, 2 mode bit (5) unaligned, 2 reterr bit (13) unaligned, 2 (rb1, rb2, rb3) bit (6) unaligned; dcl 1 temp_acl aligned based, 2 person char (32) aligned, 2 project char (32) aligned, 2 tag char (1) aligned, 2 mode bit (36) aligned, 2 ex_mode bit (36) aligned, 2 status fixed bin (35), 2 (rb1, rb2, rb3) fixed bin; dcl 1 x aligned based, 2 person char (32) aligned, 2 project char (32) aligned, 2 tag char (1) aligned, 2 mode bit (36) aligned, 2 ex_mode bit (36) aligned, 2 status fixed bin (35), 2 rb (3) fixed bin; /* Entries */ dcl acc_list_$match entry (fixed bin, bit (36) aligned, ptr, ptr, ptr, fixed bin, fixed bin (35)); dcl acc_name_$elements entry (ptr, ptr, fixed bin (35)); dcl acl_$add_entry entry (fixed bin, bit (36) aligned, ptr, ptr, bit (1), fixed bin (35)); dcl acl_$del_acl entry (fixed bin, bit (36) aligned, ptr); dcl acl_$del_entry entry (fixed bin, bit (36) aligned, ptr, ptr, fixed bin (35)); dcl acl_$list_entry entry (fixed bin, bit (36) aligned, ptr, ptr, fixed bin, fixed bin (35)); dcl alloc_ entry (fixed bin, ptr, ptr); dcl change_dtem entry (ptr); dcl check_gate_acl_ entry (ptr, bit (1) aligned, fixed bin, char (32) aligned, fixed bin (35)); dcl freen_ entry (ptr); dcl level$get entry (fixed bin); dcl setfaults$if_active entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (1) aligned); dcl sum$dirmod entry (ptr); /* Misc */ dcl (area, bad_dir_) condition; dcl (addr, bin, bit, fixed, null, ptr, rtrim, size, substr) builtin; %page; aadd: entry (a_dirname, a_ename, a_aclp, a_aclct, a_code); function = add; /* indicate which type of acl manipulation */ call setup; /* copy input arguments and initialize flags */ if cnt = 0 then go to ret; /* if number of acl entries to be added is zero, return */ call check_count; /* validate count and aclp */ call clear_code; /* clear return 13 bit error code */ call fill_in_temp; /* convert input structure to intermediate structure */ add_common: call get_entry_ptr; /* get pointer to entry */ if dirsw then call check_modes; /* check validity of directory modes for dir acl */ else do; /* for segment acl */ call get_rb; /* get ring brackets of segment */ call check_rb; /* perform check on input ring bracket array */ if gate then do; /* if adding ACL to a gate, cannot add new project */ call check_gate_acl_ (acl_start_ptr, "1"b, (ep -> entry.acle_count), dummy, code); if code ^= 0 then go to unlock; /* cannot perform ACL addition */ end; end; call change_acl; /* set modify switch and update dtm */ call add_to_acl; /* add acl list */ /* indicate to segment control that dir modified */ call update_and_unlock; /* and unlock the directory */ go to finale; %page; a1add: entry (a_dirname, a_ename, a_name, a_mode, a_rb, a_code); /* add one only */ function = add_one; /* indicate which type of acl manipulation */ call setup; p = addr (acl (1)); /* convert input to intermediate strucutre */ cnt = 1; /* adding one acl */ name = a_name; /* copy userid */ if name = "" then do; /* set userid to current user with tag = "*" */ p -> temp_acl.person = pds$access_name.person; p -> temp_acl.project = pds$access_name.project; p -> temp_acl.tag = "*"; end; else do; /* break up userid into 3 part access name */ call acc_name_$elements (addr (name), p, p -> temp_acl.status); if p -> temp_acl.status ^= 0 then go to finale; /* if illegal name, stop right now */ end; p -> temp_acl.mode = bit (fixed (a_mode, 4), 4); /* copy mode, strip off trap bit */ p -> temp_acl.ex_mode = "0"b; /* clear extended mode */ p -> temp_acl.status = 0; /* clear error code */ p -> x.rb = a_rb; /* copy ring brackets */ go to add_common; /* transfer to acl adding code */ %page; areplace: entry (a_dirname, a_ename, a_aclp, a_aclct, a_code); function = replace; /* indicate what type of acl manipulation */ call setup; /* copy input arguments and initialize flags */ if cnt = 0 then go to remove_acl; /* if no ACLs to replace current ACL, delete present ACL */ call check_count; /* validate count and aclp */ call clear_code; /* clear return 13 bit error code */ call fill_in_temp; /* convert input structure to intermediate structure */ call get_entry_ptr; /* get pointer to entry and lock parent directory */ if dirsw then call check_modes; /* if replacing a dir acl check validity of dir modes */ else do; /* for segment acl */ p = addr (acl (cnt)); ring (1) = bit (fixed (p -> temp_acl.rb1, 3), 3); /* get ring brackets from intermediate structure */ ring (2) = bit (fixed (p -> temp_acl.rb2, 3), 3); ring (3) = bit (fixed (p -> temp_acl.rb3, 3), 3); call check_rb; /* perform check on input ring bracket array */ end; call change_acl; /* set modify switch and update dtm */ call delete_acl; /* delete entire acl */ call add_to_acl; /* add ACL list */ if ^dirsw then ep -> entry.ring_brackets = ring; /* change ring brackets of segment ACL */ /* indicate to segment control that dir modified */ call update_and_unlock; /* and unlock the directory */ go to finale; %page; adelete: entry (a_dirname, a_ename, a_aclp, a_aclct, a_code); function = delete; /* indicate what type of acl manipulation we are doing */ call setup; /* copy input arguments and initialize flags */ if cnt ^= -1 then do; /* given a list of acl entries to delete */ if cnt = 0 then go to ret; /* done if none to delete */ call check_count; /* validate count and aclp */ call clear_code; /* clear return 13 bit error code */ call get_names; /* parse input userids */ end; else do; /* delete entire acl */ remove_acl: all = "1"b; /* set flag */ aclp = null; end; call get_entry_ptr; /* get ptr to entry and lock directory */ call change_acl; /* set modify switch and update dtm */ if all then call delete_acl; /* delete whole acl */ else call delete_from_acl; /* or delete selected acl entries */ /* indicate to segment control that dir modified */ call update_and_unlock; /* and unlock the directory */ go to finale; %page; alist: entry (a_dirname, a_ename, a_aclp, a_aclct, a_uap, a_code); function = list; /* indicate what type of acl manipulation */ call setup; /* copy input arguments and initialize flags */ uap = a_uap; /* copy pointer to user's area */ if uap = null then do; /* if user provided no area, then list selected acl entries */ cnt = a_aclct; /* copy number of acl entries to be listed */ if cnt = 0 then go to ret; /* if number of acl entries is zero, return */ aclp = a_aclp; /* copy pointer to input structure */ call check_count; /* validate count and aclp */ call clear_code; /* clear return 13 bit error code */ call get_names; /* parse input userids */ end; else do; /* list entire acl */ all = "1"b; /* set flag */ aclp = null; cnt = -1; end; call get_entry_ptr; /* get entry ptr and lock directory */ if all then call list_acl; /* list entire acl */ else call list_acl_entries; /* list certain acl entries */ call get_rb; /* get ring brackets of segment */ call dc_find$finished (dp, "1"b); /* unlock and unuse */ if all then on area go to alloc_err; /* enable area condition outside internal procedure */ /* so that it will share external procedure's stack frame */ call copy_acl; /* copy from intermediate structure to user area */ go to finale; %page; /* error and other miscellanous returns */ alloc_err: /* user did not provide enough room when listing entire ACL */ if aclp ^= null then call freen_ (aclp); /* free what was allocated */ a_aclp = null; /* return null pointer to allocation, acl count = 0 and status code */ a_aclct = 0; code = error_table_$noalloc; go to ret; /* copy main status code - already unlocked directory */ arg_err: /* global problem with input arguments */ code = error_table_$argerr; go to ret; /* copy main status code - not yet locked directory */ bracket_error: /* rb of segment/directory not within write bracket */ code = error_table_$bad_ring_brackets; go to unlock; /* unlock directory - reflect individual errors */ unlock: /* unlock the directory on error */ dir.modify = "0"b; call dc_find$finished (dp, "1"b); /* unlock and unuse */ finale: if function = add_one then do; /* if entered via a1add, skip processing individual codes */ if code = 0 then code = p -> temp_acl.status; end; else if cnt > 0 then do i = 1 to cnt; /* reflect individual code to user's structure */ p = addr (acl (i)); if p -> temp_acl.status ^= 0 then do; aclp -> acla (i).reterr = bit (fixed (p -> temp_acl.status, 13), 13); /* if main status code is non-zero, reflect it up */ if code = 0 then code = p -> temp_acl.status; end; end; ret: a_code = code; return; %page; setup: /* copy arguments - set initial values for flags */ proc; code = 0; /* clear status code */ dirname = a_dirname; /* copy directory name */ entryname = a_ename; /* copy entry name */ /* perform requested function */ if function ^= list & function ^= add_one then do;/* if input args */ aclp = a_aclp; /* copy pointer to input structure */ cnt = a_aclct; /* copy count of entries in input structure */ end; all, /* clear various flags */ fail_sw, gate = "0"b; call level$get (ringno); /* get validation level */ end setup; %page; check_count: /* check input arguments - count of acl entries */ proc; /* and pointer to input structure */ if cnt < 0 then go to arg_err; /* count must be non-negative */ if cnt > 100 then go to arg_err; /* limit of 100 in this primitive */ if aclp = null then go to arg_err; /* trouble if pointer is null */ end check_count; %page; clear_code: /* clear error codes in user structure before doing anything */ proc; do i = 1 to cnt; in_aclp = addr (aclp -> acla (i)); in_aclp -> input_acl.reterr = "0"b; end; end clear_code; %page; get_entry_ptr: /* procedure called when manipulating acls - get pointer to entry */ proc; /* lock dir - copy items from entry - define items for lower level primitives */ if entryname = "" then do; /* trying to get obsolete cacl */ code = error_table_$obsolete_function; go to finale; end; /* get pointer to entry and lock parent */ if function = list then call dc_find$obj_status_read (dirname, entryname, 1, ep, code); else call dc_find$obj_access_write (dirname, entryname, 1, FS_OBJ_ACL_RING_MOD, ep, code); dp = ptr (ep, 0); /* get directory pointer before checking status code */ if code ^= 0 then go to ret; /* non-zero codes do not lock the directory */ dirsw = ep -> entry.dirsw; /* copy directory flag */ acl_start_ptr = addr (ep -> entry.acl_frp); /* lower level acl primitives want to know where acl starts */ /* check that validation level is <= write bracket of segment */ if function ^= list then if dirsw then do; /* if a directory look at extended ring brackets */ if ringno > bin (ep -> entry.ex_ring_brackets (1), 3) then go to bracket_error; end; else do; /* if a segment look at actual ring bracket */ if ringno > bin (ep -> entry.ring_brackets (1), 3) then go to bracket_error; end; end get_entry_ptr; %page; get_names: /* break input userids into 3 part access names */ proc; /* and store in intermediate storage */ do i = 1 to cnt; p = addr (acl (i)); in_aclp = addr (aclp -> acla (i)); call acc_name_$elements (in_aclp, p, p -> temp_acl.status); end; end get_names; %page; update_and_unlock: /* reflect change to ACL */ proc; call setfaults$if_active ((ep -> entry.uid), (ep -> entry.pvid), (ep -> entry.vtocx), "1"b); dir.modify = "0"b; call sum$dirmod (dp); /* turn on file modified switch of the directory */ call dc_find$finished (dp, "1"b); /* unlock and unuse */ end update_and_unlock; %page; change_acl: /* set dtem if user not transparent */ /* set dtbm in kste */ proc; /* turn on modify switch in directory */ dir.modify = pds$processid; call change_dtem (ep); end change_acl; %page; fill_in_temp: /* fill in intermediate structure before locking directory */ proc; /* essentially copying arguments */ do i = 1 to cnt; p = addr (acl (i)); in_aclp = addr (aclp -> acla (i)); /* store userid as 3 part access name */ call acc_name_$elements (in_aclp, p, p -> temp_acl.status); /* copy input mode as is + strip off old trap bit */ p -> temp_acl.mode = substr (in_aclp -> input_acl.mode, 2); p -> temp_acl.ex_mode = "0"b; /* clear extended mode */ /* copy input ring brackets */ p -> temp_acl.rb1 = fixed (in_aclp -> input_acl.rb1, 6); p -> temp_acl.rb2 = fixed (in_aclp -> input_acl.rb2, 6); p -> temp_acl.rb3 = fixed (in_aclp -> input_acl.rb3, 6); end; end fill_in_temp; %page; delete_acl: /* procedure to delete entire ACL */ proc; /* call lower level procedure to do work */ call acl_$del_acl ((entry.acle_count), entry.uid, acl_start_ptr); /* update counts */ dp -> dir.acle_total = dp -> dir.acle_total - ep -> entry.acle_count; ep -> entry.acle_count = 0; end delete_acl; %page; list_acl: proc; /* list entire ACL */ do i = 1 to 100; p = addr (acl (i)); /* get the i th ACL */ call acl_$list_entry ((entry.acle_count), entry.uid, acl_start_ptr, p, i, p -> temp_acl.status); if p -> temp_acl.status ^= 0 then if p -> temp_acl.status = error_table_$argerr then do; /* have reached the end of the ACL list */ cnt = i - 1; /* store the number of entries in the list */ count = ep -> entry.acle_count; /* check the validity of the entry ACL count count */ if count ^= cnt then signal bad_dir_; return; end; end; cnt = 100; /* there are more than 100 entries in list */ code = error_table_$argerr; /* return first 100 entries + status code */ end list_acl; %page; add_to_acl: /* add entries to ACL */ proc; count = 0; /* zero count of new ACL entries */ do i = 1 to cnt; p = addr (acl (i)); if p -> temp_acl.status = 0 then do; /* skip over items which previously produced errors */ /* add one entry to ACL */ call acl_$add_entry ((entry.acle_count), entry.uid, acl_start_ptr, p, add_sw, p -> temp_acl.status); if add_sw then do; /* if atually added, update counts */ ep -> entry.acle_count = ep -> entry.acle_count + 1; dp -> dir.acle_total = dp -> dir.acle_total + 1; end; end; end; end add_to_acl; %page; delete_from_acl: /* remove selected ACL entries */ proc; count = 0; /* zero count of entries deleted */ do i = 1 to cnt; p = addr (acl (i)); if p -> temp_acl.status = 0 then do; /* ignore requests with previous errors */ /* delete the ACL entry */ call acl_$del_entry ((entry.acle_count), entry.uid, acl_start_ptr, p, p -> temp_acl.status); if p -> temp_acl.status = 0 then count = count + 1; /* increment count of deletions if successful */ end; end; if count > 0 then do; /* if any deletions took place, update counts */ ep -> entry.acle_count = ep -> entry.acle_count - count; dp -> dir.acle_total = dp -> dir.acle_total - count; end; end delete_from_acl; %page; list_acl_entries: /* list selected ACL entries */ proc; do i = 1 to cnt; p = addr (acl (i)); if p -> temp_acl.status = 0 then do; /* if no previous error, */ /* find ACL entry in list */ call acc_list_$match ((entry.acle_count), entry.uid, acl_start_ptr, p, aclep, offset, p -> temp_acl.status); if p -> temp_acl.status = 0 then do; /* if input access name on list */ /* copy mode + extended mode into intermediate store */ p -> temp_acl.mode = aclep -> acl_entry.mode; p -> temp_acl.ex_mode = aclep -> acl_entry.mode; end; end; end; end list_acl_entries; %page; get_rb: proc; /* obtain ring brackets from branch */ if dirsw then do; /* directory ACL */ ring (1) = ep -> entry.ex_ring_brackets (1); ring (2), ring (3) = ep -> entry.ex_ring_brackets (2); end; else do; /* segment ACL */ ring (1) = ep -> entry.ring_brackets (1); ring (2) = ep -> entry.ring_brackets (2); ring (3) = ep -> entry.ring_brackets (3); end; end get_rb; %page; check_modes: /* perform check on input directory modes for ACLs */ proc; /* map old REWA modes to new SMA modes - setup intermediate structure modes */ do i = 1 to cnt; p = addr (acl (i)); /* convert REWA mode to new SMA directory modes */ p -> temp_acl.ex_mode = substr (p -> temp_acl.mode, 1, 1) || substr (p -> temp_acl.mode, 3, 2); p -> temp_acl.mode = RW_ACCESS; /* rw mode for directory ACLs */ /* do not allow specification of M without S */ if (p -> temp_acl.ex_mode & "11"b) = "01"b then do; p -> temp_acl.status = error_table_$invalid_mode; if function = add_one then go to unlock;/* stop for add1 entry */ end; end; end check_modes; %page; check_rb: /* check input ring brackets of segments for legality + consistency */ proc; /* check projects of gate segments */ if ringno > 1 then /* perform special checks if creating a gate segment by ACL replacement */ if ring (2) ^= ring (3) then /* or if adding ACL entries to a gate segment */ gate = "1"b; /* from rings greater than the administrative ring */ do i = 1 to cnt; p = addr (acl (i)); p -> temp_acl.mode = p -> temp_acl.mode & "1110"b; /* strip off old append bit for segment ACLs */ /* ring must be less than 8 and non-negative */ if p -> temp_acl.rb1 > 7 then go to input_rb_error; if p -> temp_acl.rb1 < 0 then go to input_rb_error; if p -> temp_acl.rb2 > 7 then go to input_rb_error; if p -> temp_acl.rb2 < 0 then go to input_rb_error; if p -> temp_acl.rb3 > 7 then go to input_rb_error; if p -> temp_acl.rb3 < 0 then go to input_rb_error; /* ring brackets must be internally consistent */ if ringno > p -> temp_acl.rb1 then go to input_rb_error; if p -> temp_acl.rb1 > p -> temp_acl.rb2 then go to input_rb_error; if p -> temp_acl.rb2 > p -> temp_acl.rb3 then do; input_rb_error: p -> temp_acl.status = error_table_$bad_ring_brackets; fail_sw = "1"b; /* abort after checking remainder of input ACLs */ go to skip_rb_check; /* and skip remainder of checking */ end; if gate then /* if manipulating a gate segment */ /* check that user is adding/replacing his project or service project */ if p -> temp_acl.project ^= pds$access_name.project then if p -> temp_acl.project ^= "SysDaemon" then do; p -> temp_acl.status = error_table_$invalid_project_for_gate; fail_sw = "1"b; /* stop after checking rest of input */ go to skip_rb_check; end; do j = 1 to 3; /* if no errors thus far */ /* check input rb against rb of existing segment (adding) */ /* or check all input rb against rb of last input rb (replacing) */ if p -> x.rb (j) ^= fixed (ring (j), 3) then go to input_rb_error; end; skip_rb_check: end; if fail_sw then go to unlock; /* if serious error, abort */ end check_rb; %page; copy_acl: /* format ACL for entry points which list */ proc; /* and copy from temporary storage into user's area */ if all then do; /* if listing entire ACL */ /* allocate in area provided by user */ call alloc_ (size (input_acl) * cnt, uap, aclp); if aclp = null then go to alloc_err; a_aclp = aclp; a_aclct = cnt; end; do i = 1 to cnt; p = addr (acl (i)); /* get ptr to intermediate entry */ /* omit requests which generated errors */ if p -> temp_acl.status = 0 then do; in_aclp = addr (aclp -> acla (i)); /* get ptr to output entry */ /* construct userid - use varying character string for efficiency */ access_id = rtrim (p -> temp_acl.person); access_id = access_id || "."; access_id = access_id || rtrim (p -> temp_acl.project); access_id = access_id || "."; access_id = access_id || p -> temp_acl.tag; in_aclp -> input_acl.userid = access_id; /* format directory mode - convert from SMA to REWA */ if dirsw then in_aclp -> input_acl.mode = "0"b || substr (p -> temp_acl.ex_mode, 1, 1) || "1"b || substr (p -> temp_acl.ex_mode, 2, 2); /* return segment ACL modes - add old trap and append bits */ else in_aclp -> input_acl.mode = "0"b || substr (p -> temp_acl.mode, 1, 4); /* return ring brackets */ in_aclp -> input_acl.rb1 = (3)"0"b || ring (1); in_aclp -> input_acl.rb2 = (3)"0"b || ring (2); in_aclp -> input_acl.rb3 = (3)"0"b || ring (3); in_aclp -> input_acl.reterr = "0"b; /* clear code */ end; end; end copy_acl; /* format: off */ %page; %include access_mode_values; %page; %include dc_find_dcls; %page; %include dir_acl; %page; %include dir_entry; %page; %include dir_header; %page; %include fs_obj_access_codes; end acl;  append.pl1 11/11/89 1132.4rew 11/11/89 0800.0 349740 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-02-27,TLNguyen), approve(89-02-27,MCR8049), audit(89-02-28,Parisek), install(89-03-15,MR12.3-1025): a. removed create_branch_version_1. b. fixed size error. c. fixed stringsize error. 2) change(89-03-31,TLNguyen), approve(89-03-31,PBF8049), audit(89-03-31,Farley), install(89-04-24,MR12.3-1031): Reinstated the check for create_branch_version_1 in order to retain binary compatibility. END HISTORY COMMENTS */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ append: procedure; /* Modified 85-04-01 by Keith Loepere for new access_audit_check_ep_. */ /* Modified 85-01-30 by Keith Loepere to get dtem right. */ /* Modified 84-02-11 by Greg Texada to reference the arguments correctly in retv entry */ /* Modified 84-12-14 by Keith Loepere to allow setting dir quota for dirs */ /* Modified 84-11-27 by EJ Sharpe to change access_audit_ arg list */ /* Modified 10/15/84 by Keith Loepere to explicitly activate dir being created. Also to prevent creation of upgraded MSFs. Also for audit info. Also for admin_gate_$create_branch_ */ /* Modified 1984-10-01 BIM to fix retv max_auth for ^ac_sw case. */ /* Modified 07/10/84 by Keith Loepere to use the new dc_find. */ /* Modified 04/02/84 by K. Loepere to restrict link pathnames to valid 7-bit ASCII characters. */ /* Modified 84-03-16 BIM to make retv work with AIM. this includes TEMPORARY change to set soos on multi-class objects retrieved. */ /* Modified 05/07/82 by J. Bongiovanni to fix bug in cross-retrieval */ /* Modified 02/15/82 by J. Bongiovanni to fix bug in duplicate uid check */ /* Modified 11/01/79 by Mike Grady to set sons lvid for retv case (used by adopt seg) */ /* Modified 02/19/79 by C. D. Tavares to set dir ex ring brackets and to correct several bad_ring_brackets err codes */ /* modified 6/77 by D. Vinograd to check for duplicate uids in volume retriever case */ /* modified 4/77 by M. Weaver to replace makeknown with makeknown_ */ /* modified by D. Vinograd 9/76 to add entry retv. This entry used by the volume retriever to append an entry structure passed in by the caller. */ /* modified by S.E. Barr 8/76 to use variable sized hash tables */ /* modified by R. Bratt May 31, 1976 to call find_$finished */ /* modified by L. Scheffler March 1976 to use info-only entry in dir_control_error */ /* modified by Larry Johnson March 1976 for appending master dirs */ /* modified by Bernard S. Greenberg, 4-24-75 for NSS */ /* modified by Kobziar 4-11-75 to filter unused bits from access class */ /* modified by Kobziar 10-20-74 to add new entry: create_branch */ /* modified by Kobziar on 6-20-74 to copy access_class from parent to branch */ /* modified by Kobziar on 11-15-73 to take out "a" mode on segs */ /* append$branch: Creates a non directory branch in the hierarchy and places the current user on the acl with the specified mode. USAGE: call append$branch(directory_name, entry_name, access_mode, error_code) 1. directory_name char(*) - - - directory path name of new branch 2. entry_name char(*) - - - created branch's name 3. access_mode fixed bin(5) - - - mode desired on the created branch 4. error_code fixed bin(35) - - - file system error code (Output) Default values are: 1. Ringbrackets set from users validation level. 2. User id set to creator User id with tag = "*". 3. Copy switch set to off. 4. Bit count set to 0. append$link: Creates a link in a specified directory with a given name to an other specified segment. USAGE: call append$link(directory_name, entry_name, link_to_name, error_code) 1. directory_name char(*) - - - directory path name of new link 2. entry_name char(*) - - - created link name 3. link_to_name char(*) - - - path name of segment to be linked to 4. error_code fixed bin(17) - - - file system error code (Output) append$branchx: Creates either a directory or non directory entry as specified with all the attributes described below as specified. USAGE: call append$branhcx(directory_name, entry_name, access_mode, ringbrackets, user_id, directory_switch, copy_switch, bit_count, error_code) 1. directory_name char(*) - - - directory path name of new branch 2. entry_name char(*) - - - created branch's entry name 3. acces_mode fixed bin(5) - - - mode desired on the created branch 4. ringbrackets arry(3) - - - fixed bin(6) - - - ring brackets desired on the created branch 5. user_id char(*) - - - user_id desired on the acl 6. directory_switch fixed bin(1) - - - directory branch switch 7. copy_switch fixed bin(1) - - - segment copy switch 8. bit_count fixed bin(24) - - - segment length in bits 9. error_code fixed bin(17) - - - file system error code (Output) append$master_dir: create a master directory for a logical volume. Called from ring 1 after setting things up with the vol registration stuff. USAGE: call append$master_dir(directory_name, entry_name, access_mode, ringbrackets, user_id, sons_lvid, error_code); 1-5. Same as branchx 6. sons_lvid bit (36) - - - logical vol ID for sons 7. error_code fixed bin - - - error code (output) append$create_branch_: Allows the setting of the access class field in a branch and and the setting of quota in new directories. admin_create_branch_ is the same but allows creation in lower class dirs. USAGE: call append$create_branch_(directory_name, entry_name, arg_ptr, code) 1. - 2. as in branchx 3. arg_ptr ptr - - - pointer to a create_branch_info as given in create_branch_info.incl.pl1 4. error_code as above. */ %page; /* Parameters */ dcl a_arg_ptr ptr parameter; dcl a_bitcnt fixed bin (24) parameter; dcl a_code fixed bin (35) parameter; dcl a_copysw fixed bin (2) parameter; dcl a_dirname char (*) parameter; dcl a_dirsw fixed bin (1) parameter; dcl a_ename char (*) parameter; dcl a_linkname char (*) parameter; dcl a_mode fixed bin (5) parameter; dcl a_retv_append_argp ptr parameter; dcl a_ringbrack (3) fixed bin (6) parameter; dcl a_sons bit (36) parameter; dcl a_uid_path (0:15) bit (36) aligned parameter; dcl a_userid char (*) parameter; /* static variable */ dcl create_branch_version_1 fixed bin int static options (constant) init (1); /* Variables */ dcl ac_sw bit (1) aligned; dcl acbr_version fixed bin; dcl access_class bit (72) aligned; dcl acl_count fixed bin; dcl acl_start_ptr ptr; dcl add_sw bit (1); dcl admin_append bit (1) aligned; dcl areap ptr; dcl arg_ptr ptr; dcl asize fixed bin; dcl audit_eventflags bit (36) aligned; dcl authp ptr; dcl bcount fixed bin; dcl bitcnt fixed bin (24); dcl bmode bit (3) aligned; dcl branch_sw bit (1); dcl chase_sw bit (1) aligned; dcl code fixed bin (35); dcl copysw fixed bin (1); dcl default_sw bit (1); dcl dep ptr; dcl dir_quota fixed bin (18); dcl dirl bit (1) aligned; dcl dirname char (168); dcl dirp ptr; dcl dirsw fixed bin (1); dcl dtem bit (36) aligned; dcl dumcode fixed bin (35); dcl dummy char (32) aligned; dcl ename char (32); dcl ename_aligned char (32) aligned; dcl i fixed bin; dcl iacl_start_ptr ptr; dcl iaclp ptr; dcl 1 initial_acl aligned like input_acl; dcl level fixed bin; dcl linkname char (168) aligned; dcl llngth fixed bin (18); dcl 1 local_entry like entry aligned; dcl max_access_authorization bit (72) aligned; dcl 1 mk_info aligned like makeknown_info; dcl 1 my_audit_user_info aligned like audit_user_info; dcl n_iacls fixed bin; dcl newuid bit (36) aligned; dcl nwords fixed bin; dcl parent_access_class bit (72) aligned; dcl prevep ptr; dcl prior_dir_acl_count fixed bin; dcl priv_mqsw bit (1) aligned; dcl project char (32) aligned; dcl quota fixed bin (18); dcl read_lock bit (36) aligned; dcl retv bit (1) aligned; dcl retv_cross_segment bit (1) aligned; dcl ringbrack (3) fixed bin (6); dcl segno fixed bin; dcl 1 service_acl aligned, 2 person char (32) init ("*"), 2 project char (32) init ("SysDaemon"), 2 tag char (1) init ("*"), 2 mode bit (36) init ("101"b), 2 exmode bit (36) init ("0"b); dcl sons bit (36) aligned; dcl sonsw bit (1) aligned; dcl sp_sw bit (1) aligned; dcl sysl bit (1) aligned; dcl temp_b4 bit (4) aligned; dcl uid_path (0:15) bit (36) aligned; dcl 1 user_acl aligned, 2 person char (32), 2 project char (32), 2 tag char (1), 2 mode bit (36) init ("111"b), 2 exmode bit (36) init ("0"b); dcl userid char (32) aligned; dcl vtocx_temp fixed bin; dcl xsize fixed bin; /* Based */ dcl 1 acbr like create_branch_info based (arg_ptr) aligned; dcl 1 input_acl based aligned, 2 person char (32), 2 project char (32), 2 tag char (1), 2 mode bit (36), 2 exmode bit (36); /* External */ dcl active_all_rings_data$max_tree_depth external fixed bin; dcl active_hardcore_data$alloc_sizes (6) external fixed bin; dcl active_hardcore_data$dir_arearp ext fixed bin (35); dcl active_hardcore_data$dir_hdrsize external fixed bin; dcl active_hardcore_data$elcsize external fixed bin; dcl active_hardcore_data$ensize external fixed bin; dcl active_hardcore_data$esize external fixed bin; dcl active_hardcore_data$nalloc_sizes external fixed bin; dcl error_table_$ai_restricted external fixed bin (35); dcl error_table_$argerr external fixed bin (35); dcl error_table_$invalid_mode external fixed bin (35); dcl error_table_$invalid_project_for_gate external fixed bin (35); dcl error_table_$invalid_ring_brackets external fixed bin (35); dcl error_table_$lower_ring external fixed bin (35); dcl error_table_$max_depth_exceeded external fixed bin (35); dcl error_table_$namedup external fixed bin (35); dcl error_table_$noalloc external fixed bin (35); dcl error_table_$noentry external fixed bin (35); dcl error_table_$unimplemented_version external fixed bin (35); dcl 1 pds$access_authorization aligned like aim_template external; dcl 1 pds$access_name aligned external, 2 person char (32), 2 project char (32), 2 tag char (1); dcl pds$max_access_authorization bit (72) aligned external; dcl pds$processid bit (36) aligned external; dcl sys_info$access_class_ceiling external bit (72) aligned; dcl sys_info$default_dir_max_length fixed bin (19) external; /* Entries */ dcl acc_name_$elements entry (ptr, ptr, fixed bin (35)); dcl acc_name_$encode entry (ptr, ptr, fixed bin (35)); dcl access_audit_check_ep_$self entry (bit (36) aligned, bit (36) aligned, ptr) returns (bit (1)); dcl access_audit_check_ep_$user entry (bit (36) aligned, bit (36) aligned, ptr, bit (72) aligned, bit (36) aligned) returns (bit (1)); dcl access_audit_$log_entry_ptr entry (char (*), fixed bin, bit (36) aligned, bit (36) aligned, ptr, fixed bin (35), ptr, fixed bin (18), char (*)); dcl access_audit_$log_entry_ptr_user entry (char (*), fixed bin, bit (36) aligned, bit (36) aligned, ptr, fixed bin (35), ptr, fixed bin (18), ptr, char (*)); dcl acl_$add_entry entry (fixed bin, bit (36) aligned, ptr, ptr, bit (1), fixed bin (35)); dcl acl_$del_acl entry (fixed bin, bit (36) aligned, ptr); dcl acl_$list_entry entry (fixed bin, bit (36) aligned, ptr, ptr, fixed bin, fixed bin (35)); dcl aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl aim_check_$greater entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl allocate_dir_ht_ entry (ptr, fixed bin, fixed bin (35)); dcl check_gate_acl_ entry (ptr, bit (1) aligned, fixed bin, char (32) aligned, fixed bin (35)); dcl create_vtoce entry (ptr, bit (36), fixed bin (17), fixed bin (35)); dcl delete_vtoce entry (ptr, fixed bin (35)); dcl fs_alloc$alloc entry (ptr, fixed bin, ptr); dcl fs_alloc$free entry (ptr, fixed bin, ptr); dcl fs_alloc$init entry (ptr, fixed bin, ptr, fixed bin); dcl getuid entry () returns (bit (36) aligned); dcl hash$in entry (ptr, ptr, fixed bin (35)); dcl hash$out entry (ptr, ptr, ptr, fixed bin (35)); dcl hash$search entry (ptr, ptr, ptr, fixed bin (35)); dcl level$get entry returns (fixed bin); dcl lock$dir_unlock entry (ptr); dcl makeknown_ entry (ptr, fixed bin, fixed bin, fixed bin (35)); dcl makeunknown_ entry (fixed bin, bit (36) aligned, bit (1) aligned, fixed bin (35)); dcl mountedp entry (bit (36) aligned) returns (fixed bin (35)); dcl quota$append_mdir_set entry (ptr, fixed bin (18), fixed bin (35)); dcl quota$check entry (ptr, fixed bin (18), fixed bin (35)); dcl quota$qmove_mylock entry (ptr, ptr, fixed bin (18), bit (1) aligned, fixed bin (35)); dcl sum$dirmod entry (ptr); dcl syserr$error_code entry options (variable); dcl truncate$trentry entry (ptr); dcl uid_path_util$get entry (ptr, dim (0:15) bit (36) aligned, fixed bin (35)); /* Misc */ dcl (addr, baseptr, bin, bit, clock, collate, divide, fixed, length, null, ptr, rel, rtrim, substr, unspec, verify) builtin; dcl bad_dir_ condition; %page; master_dir: entry (a_dirname, a_ename, a_arg_ptr, a_sons, a_uid_path, a_code); call setup; sons = a_sons; sonsw = "1"b; max_access_authorization = pds$max_access_authorization; go to cbcomm; retv: entry (a_dirname, a_ename, a_arg_ptr, a_retv_append_argp, a_code); call setup; retv = "1"b; retv_append_argp = a_retv_append_argp; if retv_append_args.version ^= RETV_APPEND_ARGS_VERSION_1 then do; a_code = error_table_$unimplemented_version; return; end; level = retv_append_args.level; max_access_authorization = retv_append_args.max_access_authorization; arg_ptr = addr (a_arg_ptr -> acbr); /* prevent indirections and tallys */ acbr_version = acbr.version; if acbr_version < create_branch_version_1 | acbr_version > create_branch_version_2 then go to arg_err; audit_user_info_ptr = addr (my_audit_user_info); unspec (audit_user_info) = "0"b; audit_user_info.version = audit_user_info_version_1; audit_user_info.user_id = acbr.userid; /* we'll have to trust our caller for this, the retriever is good about this */ audit_user_info.process_id = "0"b; /* unknown whether logged in */ audit_user_info.authorization = retv_append_args.access_authorization; /* in non-retv case, access_mode gets from the pds */ audit_user_info.authorization_range(2) = retv_append_args.max_access_authorization; audit_user_info.audit_flags = (36)"1"b; /* audit anything until we get real audit_flags */ audit_user_info.ring = retv_append_args.level; if retv_append_args.link then linkname = retv_append_args.ep -> link.pathname; else local_entry = retv_append_args.ep -> entry; if retv_append_args.link then goto join_link; retv_cross_segment = retv_append_args.cross_segment; goto cbcomm2; admin_create_branch_: entry (a_dirname, a_ename, a_arg_ptr, a_code); call setup; admin_append = "1"b; max_access_authorization = sys_info$access_class_ceiling; go to cbcomm; create_branch_: entry (a_dirname, a_ename, a_arg_ptr, a_code); call setup; max_access_authorization = pds$max_access_authorization; cbcomm: arg_ptr = addr (a_arg_ptr -> acbr); /* prevent indirections and tallys */ acbr_version = acbr.version; if acbr_version < create_branch_version_1 | acbr_version > create_branch_version_2 then go to arg_err; cbcomm2: ac_sw = ^acbr.parent_ac_sw; /* if no ac specified, have to get parent's entry point */ if ac_sw then do; access_class = acbr.access_class; /* If ac was specified, copy it */ if ^aim_check_$greater_or_equal (max_access_authorization, access_class) then do; code = error_table_$ai_restricted; go to fin; end; end; copysw = fixed (acbr.switches.copy_sw, 1); bmode = acbr.mode; dirsw = fixed (acbr.switches.dir_sw, 1); ringbrack (1) = acbr.rings (1); ringbrack (2) = acbr.rings (2); if dirsw = 1 then ringbrack (3) = ringbrack (2); /* ignore third bracket */ else ringbrack (3) = acbr.rings (3); userid = acbr.userid; bitcnt = acbr.bitcnt; chase_sw = acbr.switches.chase_sw; priv_mqsw = acbr.switches.priv_upgrade_sw; quota = acbr.quota; if acbr_version > create_branch_version_1 then dir_quota = acbr.dir_quota; go to comm2; branchx: entry (a_dirname, a_ename, a_mode, a_ringbrack, a_userid, a_dirsw, a_copysw, a_bitcnt, a_code); call setup; if a_copysw = 0 then copysw = 0; else copysw = 1; if a_dirsw = 0 then dirsw = 0; else dirsw = 1; if dirsw = 0 then bmode = substr (bit (fixed (a_mode, 4), 4), 1, 3); else do; /* map rewa to sma */ temp_b4 = bit (fixed (a_mode, 4), 4); bmode = substr (temp_b4, 1, 1) || substr (temp_b4, 3, 2); end; userid = a_userid; /* copy process group id */ ringbrack = a_ringbrack; /* pick up all three */ if dirsw = 1 then ringbrack (3) = ringbrack (2); /* except for dirs */ bitcnt = a_bitcnt; /* and bitcount */ comm2: branch_sw = "1"b; /* indicate that we are appending a branch */ default_sw = "0"b; /* turn off default attribute switch */ do i = 1 to 3; /* check input brackets */ if ringbrack (i) >= 8 then go to inv_rb_err; if ringbrack (i) < 0 then go to inv_rb_err; end; if ^retv then level = level$get (); /* Get current validation level */ if ^retv | (retv & ^local_entry.dirsw) then if ringbrack (1) < level then goto lower_ring_err; else if ringbrack (1) > ringbrack (2) | ringbrack (2) > ringbrack (3) then go to inv_rb_err; call acc_name_$elements (addr (userid), addr (user_acl), code); /* convert userid to 3 part access name */ if code ^= 0 then go to arg_err; go to join; branch: entry (a_dirname, a_ename, a_mode, a_code); call setup; branch_sw, /* indicate that we are appending a branch */ default_sw = "1"b; /* indicate that we will select the default attributes */ dirsw, /* Set dirsw off -- can't be a directory */ copysw, /* And no copying */ bitcnt = 0; /* Bit count starts at zero */ user_acl.person = pds$access_name.person; /* set up final acl to be caller with a tag of "*" */ user_acl.project = pds$access_name.project; user_acl.tag = "*"; level, /* save validation level */ ringbrack (*) = level$get (); /* set brackets to V, V, V */ bmode = substr (bit (fixed (a_mode, 4), 4), 1, 3);/* strip off trap bit */ go to join; link: entry (a_dirname, a_ename, a_linkname, a_code); call setup; linkname = a_linkname; /* copy and check linkname */ join_link: branch_sw = "0"b; /* indicate that we are appending a link */ if substr (linkname, 1, 1) ^= ">" then go to arg_err; /* find length of linkname - allow embedded blanks */ llngth = length (rtrim (linkname)); if verify (substr (linkname, 1, llngth), collate ()) > 0 then go to arg_err; /* link must be all ascii */ join: dirl = "0"b; code = 0; /* clear error code */ if retv then authp = addr (user_acl); else authp = addr (pds$access_name); /* get pointer to 3 part access name */ dirname = a_dirname; /* copy directory and entry name arguments */ ename = a_ename; if branch_sw then do; /* if appending a branch */ /* set up ACLS with proper mode */ /* convert fixed bin(5) mode into new modes */ if dirsw = 0 then user_acl.mode = bmode; else do; user_acl.exmode = bmode; if (user_acl.exmode & "11"b) = "01"b then /* don't allow M without S access */ go to invalid_mode; service_acl.mode = "111"b; /* set access field for directories */ service_acl.exmode = "111"b; /* set extended mode for .SysDaemon access */ end; end; if ^branch_sw then chase_sw = "0"b; /* don't chase when adding links */ if retv then do; call dc_find$dir_for_retrieve_append (dirname, ename, bin (chase_sw, 1), audit_user_info_ptr, dep, dp, code); if code ^= 0 then go to fin; dirl = "1"b; end; else do; if admin_append then call dc_find$dir_for_append_raw (dirname, ename, bin (chase_sw, 1), dep, dp, code); else call dc_find$dir_for_append (dirname, ename, bin (chase_sw, 1), dep, dp, code); if code ^= 0 then go to fin; dirl = "1"b; end; if dep = null then parent_access_class = "0"b; /* assume root at 0 access class */ else do; if branch_sw then parent_access_class = dep -> entry.access_class; call lock$dir_unlock (ptr (dep, 0)); dep = null; end; code = 0; ename_aligned = ename; if branch_sw then do; /* make sure not lower than parent */ if ac_sw then call check_aim_access; else access_class = parent_access_class; /* make it same as parent */ end; if retv then do; /* check for duplicate uids */ if ^retv_append_args.link then do; i = 0; bcount = dir.dir_count + dir.seg_count + dir.lcount; do ep = ptr (dp, dir.entryfrp) repeat (ptr (dp, entry.efrp)) while (rel (ep) ^= "0"b); i = i + 1; if i > bcount then signal bad_dir_; if entry.uid = local_entry.uid then goto name_dup; end; end; end; if dirsw = 1 & dir.tree_depth >= active_all_rings_data$max_tree_depth then do; code = error_table_$max_depth_exceeded; go to unlock; end; call hash$search (dp, addr (ename_aligned), ep, code); /* See if the entry is already there */ if code = 0 then go to name_dup; /* indicates that name already on another entry */ if code ^= error_table_$noentry then signal bad_dir_; /* another code says that hash table is messed up */ if ^branch_sw | (dirsw = 1) then code = 0; /* Always ok to create links or dirs */ else code = mountedp (dir.sons_lvid); /* Can we create a VTOCE? */ if code ^= 0 then go to unlock; areap = ptr (dp, dir.arearp); /* start to allocate */ dir.modify = pds$processid; if retv then newuid = local_entry.uid; else newuid = getuid (); /* Get the unique ID */ if branch_sw then do; /* if appending a branch */ if dirsw = 1 then do; iacl_start_ptr = addr (dir.iacl (level).dir_frp); /* get ptr to dir Initial ACL for V */ n_iacls = dir.iacl_count (level).dir; end; else do; iacl_start_ptr = addr (dir.iacl (level).seg_frp); /* get ptr to seg IACl at validation level */ n_iacls = dir.iacl_count (level).seg; if ringbrack (2) ^= ringbrack (3) then /* check for valid project if creating gate seg */ if level > 1 then do; /* in rings greater than administrative ring */ if retv then project = user_acl.project; else project = pds$access_name.project; if user_acl.project ^= project then if user_acl.project ^= "SysDaemon" then do; code = error_table_$invalid_project_for_gate; go to unlock; end; call check_gate_acl_ (iacl_start_ptr, "1"b, 0, dummy, code); /* check Initial ACL for project */ if code ^= 0 then go to unlock; end; end; xsize = active_hardcore_data$esize; /* store size of an entry */ call fs_alloc$alloc (areap, xsize, ep); /* allocate the entry */ if ep = null then go to alloc_err; if retv then do; entry = local_entry; entry.acl_frp, entry.acl_brp = "0"b; entry.acle_count = 0; dtem = entry.dtem; /* save for later */ end; if dirsw = 1 then entry.type = DIR_TYPE; else entry.type = SEG_TYPE; entry.size = xsize; entry.owner = dir.uid; acl_count = 0; acl_start_ptr = addr (entry.acl_frp); /* fill in items before call to acl_ */ prior_dir_acl_count = dir.acle_total; /* save total number of acl entries in directory */ /* put SysDaemon on ACL */ if ^retv | retv_cross_segment then do; call acl_$add_entry (0, newuid, acl_start_ptr, addr (service_acl), add_sw, code); if code ^= 0 then go to cleanup_acl; /* This loop adds acls to the branch. (code = error_table_$argerr is set when the end of the acl thread is passed) */ acl_count = 1; /* add on Initial ACL */ dir.acle_total = dir.acle_total + 1; iaclp = addr (initial_acl); do i = 1 by 1 while (code = 0); call acl_$list_entry (n_iacls, dir.uid, iacl_start_ptr, iaclp, i, code); if code = 0 then do; call acl_$add_entry (acl_count, newuid, acl_start_ptr, iaclp, add_sw, code); if code ^= 0 then goto cleanup_acl; if add_sw then do; /* If actually added */ acl_count = acl_count + 1; dir.acle_total = dir.acle_total + 1; end; end; else if code ^= error_table_$argerr then go to cleanup_acl; end; /* now put on ACL for user */ if ^retv_cross_segment then do; call acl_$add_entry (acl_count, newuid, acl_start_ptr, addr (user_acl), add_sw, code); if code ^= 0 then goto cleanup_acl; end; if add_sw then do; acl_count = acl_count + 1; dir.acle_total = dir.acle_total + 1; end; entry.acle_count = acl_count; /* set acl count for entry */ end; end; else do; /* if appending a link, allocate the link */ nwords = active_hardcore_data$elcsize + 3 + divide (llngth + 3, 4, 17, 0); /* first get number of words for link */ /* find appropriate allocation size */ do i = active_hardcore_data$nalloc_sizes - 1 to 1 by -1 while (nwords <= active_hardcore_data$alloc_sizes (i)); end; xsize = active_hardcore_data$alloc_sizes (i + 1); call fs_alloc$alloc (areap, xsize, ep); if ep = null then go to alloc_err; link.type = LINK_TYPE; link.size = xsize; link.pathname_size = llngth; link.pathname = linkname; link.owner = dir.uid; /* Pathname size MUST be set for 'refer' to be correct */ end; call acc_name_$encode (addr (entry.author), authp, code); /* set author */ if code ^= 0 then go to cleanup_acl; np = addr (entry.primary_name); /* first name is in the branch */ entry.name_frp, /* fill in name info before hashing */ entry.name_brp = rel (np); entry.nnames = 1; np -> names.entry_rp = rel (ep); np -> names.name = ename; np -> names.type = NAME_TYPE; np -> names.size = active_hardcore_data$ensize; np -> names.owner = newuid; call hash$in (dp, np, code); /* have already checked for name dup */ if code ^= 0 then goto cleanup_acl; /* Fill in general entry info */ entry.uid = newuid; /* Fill in the unique ID */ entry.dtem = substr (bit (fixed (clock, 52), 52), 1, 36); if ^branch_sw then dir.lcount = dir.lcount + 1; /* link */ else do; entry.bs = "1"b; /* Entry is a branch */ entry.per_process_sw = dir.per_process_sw; entry.bc = bitcnt; /* set bit count */ entry.dirsw = bit (dirsw, 1); /* Can't append segs to segs, you know! */ entry.access_class = access_class & sys_info$access_class_ceiling; entry.multiple_class = sp_sw; /* indicates class higher than parent */ /**** Set the security oos for backup-retrieved multi-class segments. This is a temporary fix to circumvent the lack of information on authorization/max authorization in the volume dumper. */ if retv then if entry.multiple_class then do; if ^pds$access_authorization.soos then entry.security_oosw = "1"b; end; entry.master_dir = sonsw; call acc_name_$encode (addr (entry.bc_author), authp, code); /* set bc author */ if code ^= 0 then go to make_err; call uid_path_util$get (dp, uid_path, code); /* get uid pathname of parent */ if code ^= 0 then go to make_err; uid_path (dir.tree_depth + 1) = entry.uid; /* last component */ if ^retv then do; call create_vtoce (ep, entry.pvid, vtocx_temp, code); if code ^= 0 then go to make_err; /* problems. */ entry.vtocx = vtocx_temp; /* Store in unal fld in branch */ if dirsw = 1 then call setup_directory; else do; /* link */ entry.ring_brackets (1) = bit (fixed (ringbrack (1), 3), 3); entry.ring_brackets (2) = bit (fixed (ringbrack (2), 3), 3); entry.ring_brackets (3) = bit (fixed (ringbrack (3), 3), 3); entry.copysw = bit (copysw, 1); /* copy sw */ dir.seg_count = dir.seg_count + 1; /* and update segment count in directory */ end; end; else do; /* retv case. */ if retv_cross_segment then do; call create_vtoce (ep, entry.pvid, vtocx_temp, code); if code ^= 0 then goto make_err; entry.vtocx = vtocx_temp; end; if dirsw = 1 then do; dir.dir_count = dir.dir_count + 1; if ^entry.master_dir then entry.sons_lvid = dir.sons_lvid; /* propagate the correct sons lvid */ end; else dir.seg_count = dir.seg_count + 1; end; end; if dir.entryfrp = ""b then do; /* first entry in directory */ dir.entryfrp, dir.entrybrp = rel (ep); entry.efrp, entry.ebrp = ""b; end; else do; prevep = ptr (ep, dir.entrybrp); /* get pointer to previous entry */ entry.ebrp = rel (prevep); /* set back pointer of entry */ prevep -> entry.efrp = rel (ep); /* set forward pointer of prev. entry */ entry.efrp = ""b; /* set forward pointer of entry */ dir.entrybrp = rel (ep); /* reset dir rel back pointer */ end; if retv then entry.dtem = dtem; dir.modify = "0"b; call sum$dirmod (dp); /* We've modified this directory */ audit_eventflags = "0"b; addr (audit_eventflags) -> audit_event_flags.grant = "1"b; if retv then /* audit the new object */ if access_audit_check_ep_$user (audit_eventflags, access_operations_$fs_obj_create, ep, audit_user_info.authorization, audit_user_info.audit_flags) then call access_audit_$log_entry_ptr_user ("append", level, audit_eventflags, access_operations_$fs_obj_create, ep, 0, null, 0, audit_user_info_ptr, ""); else ; else if access_audit_check_ep_$self (audit_eventflags, access_operations_$fs_obj_create, ep) then call access_audit_$log_entry_ptr ("append", level, audit_eventflags, access_operations_$fs_obj_create, ep, 0, null, 0, ""); call dc_find$finished (dp, dirl); fin: a_code = code; return; arg_err: code = error_table_$argerr; go to fin; lower_ring_err: code = error_table_$lower_ring; goto fin; inv_rb_err: code = error_table_$invalid_ring_brackets; go to fin; invalid_mode: code = error_table_$invalid_mode; go to fin; name_dup: code = error_table_$namedup; go to unlock; alloc_err: code = error_table_$noalloc; go to unlock; free_vtoce: call delete_vtoce (ep, dumcode); if dumcode ^= 0 then call syserr$error_code (4, dumcode, "append: err from delete_vtoce for ^a>^a:", dirname, ename); make_err: call hash$out (dp, addr (ename_aligned), np, dumcode); if dumcode ^= 0 then call syserr$error_code (4, dumcode, "append: error from hash$out for ^a>^a:", dirname, ename); cleanup_acl: if branch_sw then do; call acl_$del_acl (acl_count, newuid, acl_start_ptr); dir.acle_total = prior_dir_acl_count; /* restore the acl count in the directory */ end; call fs_alloc$free (areap, xsize, ep); unlock: if dep ^= null then call lock$dir_unlock (ptr (dep, 0)); dir.modify = "0"b; call dc_find$finished (dp, dirl); go to fin; %page; check_aim_access: proc; if aim_check_$greater (access_class, parent_access_class) then do; if dirsw = 1 then do; /* see if privileged oos creation */ if quota <= 0 then if level > 1 then goto ai_err; else if ^priv_mqsw then goto ai_err; if bitcnt ^= 0 then if level > 1 then goto ai_err; /* no upgraded non-multiclass MSFs */ sp_sw = "1"b; /* this sets entry.multiple_class */ end; else do; /* will be a multiclass segment */ if ringbrack (3) > 1 then go to ai_err; /* can only create multi class seg from ring 1 */ if priv_mqsw then sp_sw = "1"b; else go to ai_err; /* wasn't reall wanted, wrong access class passed */ end; end; else if ^aim_check_$equal (access_class, parent_access_class) then do; ai_err: code = error_table_$ai_restricted; /* ok to return as have at least append mode */ goto unlock; end; end check_aim_access; setup: proc; ac_sw = "0"b; admin_append = "0"b; chase_sw = "1"b; dir_quota = 0; priv_mqsw = "0"b; quota = 0; read_lock = "0"b; retv = "0"b; retv_cross_segment = "0"b; sonsw = "0"b; sp_sw = "0"b; sysl = "0"b; return; end setup; %page; /* This procedure fills in the directory header and moves quota down. */ setup_directory: proc; if sonsw then entry.sons_lvid = sons; /* Master dir? */ else entry.sons_lvid = dir.sons_lvid; /* if not, inherit */ /* set extended rb, normal rb are 0,0,0 */ entry.ex_ring_brackets (1) = bit (bin (ringbrack (1), 3), 3); entry.ex_ring_brackets (2) = bit (bin (ringbrack (2), 3), 3); if ^sonsw then do; call quota$check (ep, quota, code); /* check if quota can take quota more pages */ if code ^= 0 then go to free_vtoce; end; /* make the new directory segment known */ /* Turn the modify switch OFF in the parent while initializing the inferior directory. Note that there is a window until it is turned on again during which the modify switch is OFF although the operation is not finished */ dir.modify = "0"b; unspec (mk_info) = "0"b; mk_info.uid = entry.uid; mk_info.entryp = ep; mk_info.dirsw = "1"b; mk_info.allow_write = "1"b; mk_info.activate = "1"b; dirp = null; call makeknown_ (addr (mk_info), segno, (0), code); if code ^= 0 then go to free_vtoce; dirp = baseptr (segno); unspec (dirp -> dir) = "0"b; /* Zero the header */ dirp -> dir.type = DIR_HEADER_TYPE; /* Fill in constants */ dirp -> dir.size = active_hardcore_data$dir_hdrsize; dirp -> dir.version_number = version_number_2; dirp -> dir.owner = dir.uid; dirp -> dir.uid = entry.uid; /* Fill in the unique id */ dirp -> dir.arearp = bit (fixed (active_hardcore_data$dir_arearp, 18), 18); dirp -> dir.pvid = entry.pvid; dirp -> dir.per_process_sw = entry.per_process_sw; dirp -> dir.sons_lvid = entry.sons_lvid; dirp -> dir.master_dir = entry.master_dir; if entry.master_dir then dirp -> dir.master_dir_uid = entry.uid; else dirp -> dir.master_dir_uid = dir.master_dir_uid; /* Inherit */ dirp -> dir.access_class = entry.access_class; dirp -> dir.vtocx = entry.vtocx; asize = sys_info$default_dir_max_length - fixed (dirp -> dir.arearp, 18); call fs_alloc$init (ptr (dirp, dirp -> dir.arearp), asize, addr (active_hardcore_data$alloc_sizes), active_hardcore_data$nalloc_sizes); call allocate_dir_ht_ (dirp, 0, (0)); dirp -> dir.tree_depth = dir.tree_depth + 1; /* set tree depth */ if quota > 0 then /* Set quota */ if ^sonsw then do; /* non-master dir, move */ call quota$qmove_mylock (ep, dirp, quota, "0"b, code); if code ^= 0 then do; /* drop this hot potato */ /* used to unlock new dir here */ qerr: call truncate$trentry (ep); /* and header page */ call makeunknown_ (segno, "0"b, ("0"b), dumcode); if dumcode ^= 0 then call syserr$error_code (4, dumcode, "append: makeunknown_ err after quota err for ^a>^a:", dirname, ename); go to free_vtoce; /* leave in kst if makeunknown_ fails */ end; end; else do; /* master dir. */ call quota$append_mdir_set (ep, quota, code); /* set the quuota */ if code ^= 0 then go to qerr; end; else if priv_mqsw & ac_sw then do; /* path for reloader to create upgraded dirs with no quota */ if aim_check_$greater (access_class, parent_access_class) then ep -> entry.security_oosw = "1"b; /* by leaving entry oosw */ end; if dir_quota > 0 then do; /* Set quota */ call quota$qmove_mylock (ep, dirp, dir_quota, "1"b, code); if code ^= 0 then go to qerr; /* drop this hot potato */ end; call sum$dirmod (dirp); /* indicate that it has been modified */ call makeunknown_ (segno, "0"b, ("0"b), code); if code ^= 0 then call syserr$error_code (4, code, "append: error from makeunknown_ for ^a>^a:", dirname, ename); dir.modify = pds$processid; /* Turn modify sw back on again to complete the creation of the branch. This call will terminate the window referred to above and created at the beginning of the initialization of the inferior directory. */ dir.dir_count = dir.dir_count + 1; /* up directory count in parent */ if sonsw then a_uid_path = uid_path; /* return uid pathname to ring 1 */ return; end setup_directory; %page; %include access_audit_eventflags; %page; %include access_audit_user_info; %page; %include aim_template; %page; %include create_branch_info; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include dir_header; %page; %include dir_ht; %page; %include dir_link; %page; %include dir_name; %page; %include fs_obj_access_codes; %page; %include fs_types; %page; %include makeknown_info; %page; %include null_addresses; %page; %include retv_append_args; %page; /* BEGIN MESSAGE DOCUMENTATION Message: append: error from delete_vtoce for PATH: ERROR_MESSAGE S: $log T: $run M: While deleting a VTOC entry to clean up an unsuccessful attempt to create an branch, append got an error. $err A: $note Message: append: error from hash$out for PATH: ERROR_CODE S: $log T: $run M: While removing a name to clean up an unsuccessful attempt to create a branch, append got an error. $err A: $note Message: append: makeunknown_ err after quota err for PATH: ERROR_CODE S: $log T: $run M: During the creation of a new directory, append encountered an error moving quota. While cleaning up from this error a further error was encountered. The system continues to operate. $err A: $note Message: append: error from makeunknown_ for PATH: ERROR_CODE S: $log T: $run M: Append made the new directory PATH unknown after initializing its header. While doing so it encountered an error. $err A: $note END MESSAGE DOCUMENTATION */ end append;  asd_.pl1 11/11/89 1132.4r w 11/11/89 0800.0 334539 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(88-06-10,Lippard), approve(88-07-04,MCR7929), audit(88-07-08,Parisek), install(88-07-15,MR12.2-1057): Modified to return error code of 0 and status_code of error_table_$user_not_found in case where specific ACLs are requested to be listed and entry has an empty ACL. END HISTORY COMMENTS */ /* format: style2 */ asd_: procedure; /* Modified 10/84 Keith Loepere to audit operation as an access change. */ /* Modified 84-07-03 BIM for ring number range checks. */ /* Modified 6/84 Keith Loepere to use the new dc_find. */ /* Modified 8/83 E. N. Kittlitz. setfaults$if_active pvid, vtocx args */ /* Modified 3/83 E. N. Kittlitz. setfaults on fatal_error if acl modified */ /* Modified 5/82 BIM to use Legal PL/I in the case where list_* is called */ /* on a null acl with a area pointer. */ /* a one-dim array is allocated, but a count of 0 is */ /* returned, for compatability. (instead of returning */ /* an error code) */ /* Modified 3/82 BIM for no system free seg, refer extent entrypoints */ /* Modified by B. Margulies 05/10/79 to remove pds$xmode level restriction and allow setting exacls within validation level */ /* Modified 07/77 by THVV for bad_dir_ check */ /* Modified by R. Bratt 06/01/76 to call find_$finished */ /* Modified by Kobziar 10/15/75 to copy et$user_not_found errors in delete structure */ /* NSS, 4/25/75, by Greenberg */ /* Modified by E. Stone Oct 1974 to place uid and dtem in double word */ /* Modified to copy arguments before using - 9/74 by A. Mason */ /* Modified by Kobziar on 11-12-73 to return dirseg and nondirseg error codes */ /* This is the gate level acl proc and contains 18 entries for listing, deleting, replacing, and * adding acl entries to segments, directories, and initial acls. * Entrypoints whose names begin with r_ are identical in function, but take * refer extend structures. * * There are r_ entrypoints for acl listing, since for allocation of storage * refer extents are cleaner. The other entrypoints stay as they are, * because arrays are easier to declare in automatic structures. * * It is always possible to pass addr (XXX_acl.entries), XXX_acl.count * into the other entrypoint. * * _e_n_t_r_y _a_r_g_u_m_e_n_t_s * * list_dall (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_acl_ptr, a_acl_count, a_code) * r_list_dall (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_code); * r_list_sall (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_code); * list_sall as above. Dall lists all of a directory acl and used the dir_acl structure(below) * . while sall lists all of a segment's acl and uses the acl structure. * * list_idall (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_acl_ptr, a_acl_count, a_ring, a_code) * list_isall List of initial acls for segments and directories, for the specified ring. * r_list_idall (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_ring, a_code) * r_list_isall (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_ring, a_code); * * del_dentries (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_code) * del_sentries as above. Dentries and sentries use the del_acl structure and delete the specified acl entries. * del_identries (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_ring, a_code) * del_isentries Delete initial acls for segments and directories for the specified ring. * replace_dall (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_daemon_sw, a_code) * replace_sall as above. Dall replaces a dir acl with the one given and uses the dir_acl structure * . while sall replaces a segment's acl and uses the acl structure. * replace_idall (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_daemon_sw, a_ring, a_code) * replace_isall Replace initial acl for segments and directories fir the specified ring. * add_dentries (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_code) * add_sentries as above. Dentries adds (or changes the mode if the acl entry already exists) the * . given entries to a directory acl and uses the dir_acl structure, while sentries * . adds or changes the mode and uses the acl structure. * add_identries (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_ring, a_code) * add_isentries Add to initial acls of segments or directories for the specified ring. * * * * _a_r_g_u_m_e_n_t _v_a_l_u_e * * a_dir_name char(*), the name of the directory (Input). * a_entryname char(*), the name of the brnach in the above directory whoes acl is to be read or * . written (Input). * a_area_ptr ptr, used only in listing acls and pts to an area wher the entire acl should be * . listed, otherwize it is null and only the modes in the given acl list will be listed. * . (Input). * a_return_struc_ptr ptr, is set to point to allocation in area (if a_area_ptr given) of the * . acl list. (Output) * a_acl_ptr ptr, points to an acl, dir_acl, or del_acl structure. (Input for all except * . when listing whole acl rather than specified acl's modes, when it must be null). * a_acl_count fixed bin(17), then number of acl entries in the given structure, (Input except * . for list when listing whole acl, then output). * a_daemon_sw bit(1) aligned, used to specify if want a *.SysDaemon.* rw or sma acl entry appended * . to the acl replacement list. "0"b = yes, "1"b = no, (Input). * a_ring fixed bin(3), the initial acl's ring number.(Must be >= validation level). * a_code fixed bin(35), is a standard file system error code. If non zero then no * . processing has been performed except in the case of deleting, where a user_not_found * . code in the del_acl structure indicates that this entry wasn't found. * **/ dcl a_acl_count fixed bin (17) parameter; dcl a_acl_ptr ptr parameter; dcl a_area_ptr ptr parameter; dcl a_code fixed bin (35) parameter; dcl a_daemon_sw bit (1) parameter; /* indicates whether to remove a *.SysDaemon.* acl */ dcl a_dir_name char (*) parameter; dcl a_entryname char (*) parameter; dcl a_return_struc_ptr ptr parameter; dcl a_ring fixed bin (3) parameter; dcl 1 acl1 based (acl_entry_ptr) aligned, /* one entry of an input acl list */ 2 ac_name, 3 person char (32), 3 project char (32), 3 tag char (1), 2 mode bit (36), 2 ex_mode bit (36); dcl arg_area area based (area_ptr); dcl 1 a_n aligned like acl1; dcl acl_entry_ptr ptr; dcl acl_start_ptr ptr; dcl add_sw bit (1); dcl ael fixed bin; dcl area_ptr ptr; dcl called_find bit (1) aligned; dcl caller_level fixed bin (3) unsigned; dcl code fixed bin (35); dcl d_s bit (1) aligned; dcl daemon_sw bit (1) aligned; dcl dirname char (168); dcl entryname char (32); dcl esw fixed bin (17); /* indicates which entry point called */ dcl fail_sw bit (1) aligned; dcl fatal_error_sets_faults bit (1) aligned; dcl i fixed bin; dcl initial_acl bit (1) aligned; dcl locked bit (1) aligned; dcl locked_for_write bit (1) aligned; dcl n_acls fixed bin; dcl offset fixed bin; dcl owning_structure bit (36) aligned; dcl refer_allocation bit (1) aligned; /* new style listing */ dcl return_acl_ptr pointer; dcl ring fixed bin (17); dcl structure_supplied bit (1) aligned; /* no allocation needed */ dcl t_char1 char (32) aligned; dcl t_char2 char (32) aligned; dcl tag char (1) aligned; dcl temp_access_name char (32) aligned; dcl temp_extended_mode bit (36) aligned; dcl temp_mode bit (36); dcl work_p ptr; dcl acc_name_$elements ext entry (ptr, ptr, fixed bin (35)); dcl acl_$add_entry entry (fixed bin, bit (36) aligned, ptr, ptr, bit (1), fixed bin (35)); dcl acl_$del_acl entry (fixed bin, bit (36) aligned, ptr); dcl acl_$del_entry entry (fixed bin, bit (36) aligned, ptr, ptr, fixed bin (35)); dcl acl_$list_entry entry (fixed bin, bit (36) aligned, ptr, ptr, fixed bin, fixed bin (35)); dcl change_dtem entry (ptr); dcl check_gate_acl_ entry (ptr, bit (1) aligned, fixed bin (17), char (32) aligned, fixed bin (35)); dcl level$get entry returns (fixed bin (3)); dcl lock$dir_lock_read entry (ptr, fixed bin (35)); dcl lock$dir_unlock entry (ptr); dcl setfaults$if_active entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (1) aligned); dcl sum$dirmod entry (ptr); dcl error_table_$argerr ext fixed bin (35); dcl error_table_$bad_acl_mode ext fixed bin (35); dcl error_table_$bad_ring_brackets ext fixed bin (35); dcl error_table_$dirseg ext fixed bin (35); dcl error_table_$empty_acl ext fixed bin (35); dcl error_table_$invalid_ascii ext fixed bin (35); dcl error_table_$invalid_mode ext fixed bin (35); dcl error_table_$noalloc ext fixed bin (35); dcl error_table_$nondirseg ext fixed bin (35); dcl error_table_$null_info_ptr ext fixed bin (35); dcl error_table_$user_not_found ext fixed bin (35); dcl pds$processid bit (36) aligned ext; dcl ADD_DIR fixed bin static options (constant) init (4); dcl ADD_SEG fixed bin static options (constant) init (8); dcl DEL_DIR fixed bin static options (constant) init (2); dcl DEL_SEG fixed bin static options (constant) init (6); dcl LIST_DIR fixed bin static options (constant) init (1); dcl LIST_SEG fixed bin static options (constant) init (5); dcl REP_SEG fixed bin static options (constant) init (7); dcl REP_DIR fixed bin static options (constant) init (3); dcl (addr, bin, fixed, null, ptr, rtrim, substr) builtin; dcl (area, any_other, bad_dir_, cleanup, seg_fault_error) condition; %page; /* * * * * * * * * * * * * * * * * */ list_idall: entry (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_acl_ptr, a_acl_count, a_ring, a_code); initial_acl = "1"b; go to LIST_DALL_COMMON; list_dall: entry (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_acl_ptr, a_acl_count, a_code); initial_acl = "0"b; LIST_DALL_COMMON: refer_allocation = "0"b; go to R_LIST_DALL_COMMON; r_list_idall: entry (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_ring, a_code); initial_acl = "1"b; go to R_LIST_DALL_COMMON_0; r_list_dall: entry (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_code); initial_acl = "0"b; R_LIST_DALL_COMMON_0: refer_allocation = "1"b; R_LIST_DALL_COMMON: if initial_acl then ring = a_ring; /* list the alc of a directory */ esw = LIST_DIR; go to LIST_COMMON; list_isall: entry (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_acl_ptr, a_acl_count, a_ring, a_code); initial_acl = "1"b; go to LIST_SALL_COMMON; list_sall: entry (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_acl_ptr, a_acl_count, a_code); initial_acl = "0"b; LIST_SALL_COMMON: refer_allocation = "0"b; go to R_LIST_SALL_COMMON; r_list_isall: entry (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_ring, a_code); initial_acl = "1"b; go to R_LIST_DALL_COMMON_0; r_list_sall: entry (a_dir_name, a_entryname, a_area_ptr, a_return_struc_ptr, a_code); initial_acl = "0"b; R_LIST_SALL_COMMON_0: refer_allocation = "1"b; R_LIST_SALL_COMMON: if initial_acl then ring = a_ring; esw = LIST_SEG; /* The listing entrypoints happen here, via two internal procedures */ /* One is used when the structure is supplied, and selection is to take */ /* place. That is process_specific_list. The other is for allocation */ /* and return. That is process_list_all. */ LIST_COMMON: caller_level = level$get (); locked, locked_for_write, called_find, fatal_error_sets_faults = "0"b; area_ptr = a_area_ptr; if initial_acl then if ring < 0 | ring > 7 then call fatal_error (error_table_$argerr); d_s = esw < LIST_SEG; structure_supplied = (area_ptr = null); if structure_supplied then do; if refer_allocation then acl_ptr = a_return_struc_ptr; else acl_ptr = a_acl_ptr; if acl_ptr = null then call fatal_error (error_table_$null_info_ptr); if /* tree */ refer_allocation then if d_s then do; acl_count = directory_acl.count; acl_ptr = addr (directory_acl.entries); end; else do; acl_count = segment_acl.count; acl_ptr = addr (segment_acl.entries); end; else acl_count = a_acl_count; end; else do; return_acl_ptr = null; acl_ptr = null; acl_count = 0; end; on cleanup call cleanup_; %page; Retry_process_list_all: /** Come here is the dir changed asychronously */ call check_pathname_find_read_lock_and_check_access; acl_entry_ptr = addr (a_n); /* used as a temp for constructing input acl ent */ if initial_acl then do; if d_s then acl_start_ptr = addr (dir.iacl (ring).dir_frp); else acl_start_ptr = addr (dir.iacl (ring).seg_frp); if d_s then n_acls = dir.iacl_count (ring).dir; else n_acls = dir.iacl_count (ring).seg; owning_structure = dir.uid; /* dir is owner of iacl entries */ end; else do; acl_start_ptr = addr (entry.acl_frp); n_acls = entry.acle_count; owning_structure = entry.uid; /* When checking and making acles, entry owns em */ end; /***** If the acl is null, the only work to do (allocating a null structure) */ /***** is done after the dir is unlocked. */ if structure_supplied then call process_specific_list; else if n_acls > 0 then call process_list_all; /* Both of these return with the dir locked, and acl_ptr and acl_count */ /* ready to return */ call dc_find$finished (dp, "1"b); if refer_allocation /* new style */ then if structure_supplied then ; else do; if acl_count = 0 then do; /* allocate 1-dim (legal pl1) */ acl_count = 1; if d_s then do; allocate directory_acl in (arg_area); directory_acl.count = 0; /* but report the fact that it is null */ end; else do; allocate segment_acl in (arg_area); segment_acl.count = 0; end; return_acl_ptr = acl_ptr;/* share code with case just below */ end; a_return_struc_ptr = return_acl_ptr; end; else /* old style */ if structure_supplied then ; else do; if acl_count = 0 /* null acl */ then do; acl_count = 1; /* allocate 1-dim (legal pl1) */ if d_s then allocate directory_acl_array in (arg_area); else allocate segment_acl_array in (arg_area); acl_count = 0; /* but report 0 count */ end; a_return_struc_ptr = acl_ptr; a_acl_count = acl_count; end; a_code = code; /* reflect code from some bad entry */ return; /* So much for listing */ %page; del_identries: entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_ring, a_code); initial_acl = "1"b; /* delete initial acl entries for dir at ring */ go to DEL_DENTRIES_COMMON; del_dentries: entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_code); /* del part of dir acl */ initial_acl = "0"b; DEL_DENTRIES_COMMON: esw = DEL_DIR; goto start_proc; del_isentries: entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_ring, a_code); initial_acl = "1"b; /* delete for segments */ go to DEL_SENTRIES_COMMON; del_sentries: entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_code); /* del part of seg acl */ initial_acl = "0"b; DEL_SENTRIES_COMMON: esw = DEL_SEG; goto start_proc; replace_idall: entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_daemon_sw, a_ring, a_code); initial_acl = "1"b; /* replace inatial acl for dirs at ring */ go to REPLACE_DALL_COMMON; replace_dall: entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_daemon_sw, a_code); /* replace a dir acl with one provided */ initial_acl = "0"b; REPLACE_DALL_COMMON: esw = REP_DIR; daemon_sw = a_daemon_sw; goto start_proc; replace_isall: entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_daemon_sw, a_ring, a_code); initial_acl = "1"b; /* replace for segments */ go to REPLACE_SALL_COMMON; replace_sall: entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_daemon_sw, a_code); /* replace s seg acl with one given */ initial_acl = "0"b; REPLACE_SALL_COMMON: esw = REP_SEG; daemon_sw = a_daemon_sw; goto start_proc; add_identries: entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_ring, a_code); initial_acl = "1"b; /* add initial acls for dir at ring */ go to ADD_DENTRIES_COMMON; add_dentries: entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_code); /* add or replace toa dir acl */ initial_acl = "0"b; ADD_DENTRIES_COMMON: esw = ADD_DIR; goto start_proc; add_isentries: entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_ring, a_code); initial_acl = "1"b; /* add for segmemts */ go to ADD_SENTRIES_COMMON; add_sentries: entry (a_dir_name, a_entryname, a_acl_ptr, a_acl_count, a_code); /* add or relpace entries to seg acl */ initial_acl = "0"b; ADD_SENTRIES_COMMON: esw = ADD_SEG; %page; start_proc: caller_level = level$get (); locked, locked_for_write, called_find, fatal_error_sets_faults = "0"b; acl_ptr = a_acl_ptr; acl_count = a_acl_count; if initial_acl then do; ring = a_ring; if ring < 0 | ring > 7 then call fatal_error (error_table_$argerr); end; d_s = esw < LIST_SEG; if esw ^= REP_SEG & esw ^= REP_DIR then do; /* if replacing, can replace with empty */ if acl_ptr = null then call fatal_error (error_table_$null_info_ptr); if acl_count = 0 then call fatal_error (error_table_$argerr); end; if acl_ptr = null then acl_count = 0; else do; on any_other call fatal_error (error_table_$argerr); call check_in_structure; revert any_other; end; call check_pathname_find_read_lock_and_check_access; %page; acl_entry_ptr = addr (a_n); /* used as a temp for constructing input acl ent */ if initial_acl then do; if d_s then acl_start_ptr = addr (dir.iacl (ring).dir_frp); else acl_start_ptr = addr (dir.iacl (ring).seg_frp); if d_s then n_acls = dir.iacl_count (ring).dir; else n_acls = dir.iacl_count (ring).seg; owning_structure = dir.uid; /* dir is owner of iacl entries */ end; else do; acl_start_ptr = addr (entry.acl_frp); n_acls = entry.acle_count; owning_structure = entry.uid; /* When checking and making acles, entry owns em */ end; %page; dir.modify = pds$processid; if ^initial_acl then do; call change_dtem (ep); fatal_error_sets_faults = "1"b; end; /* * * * delete * * * */ if (esw = DEL_DIR) | (esw = DEL_SEG) then do; on any_other call fatal_error (error_table_$argerr); delete_acl_array (*).status_code = 0; revert any_other; do i = 1 to acl_count; on any_other call fatal_error (error_table_$argerr); temp_access_name = delete_acl_array (i).access_name; revert any_other; call acc_name_$elements (addr (temp_access_name), acl_entry_ptr, code); if code ^= 0 then do; on any_other call fatal_error (error_table_$argerr); delete_acl_array (i).status_code = code; revert any_other; call fatal_error (error_table_$argerr); end; call acl_$del_entry (n_acls, owning_structure, acl_start_ptr, acl_entry_ptr, code); if code ^= 0 then do; if code = error_table_$user_not_found then do; on any_other call fatal_error (error_table_$argerr); delete_acl_array (i).status_code = code; revert any_other; code = 0; goto del_loop; end; else call fatal_error (code); end; if ^initial_acl then entry.acle_count = entry.acle_count - 1; else if d_s then dir.iacl_count.dir (ring) = dir.iacl_count.dir (ring) - 1; else dir.iacl_count.seg (ring) = dir.iacl_count.seg (ring) - 1; dir.acle_total = dir.acle_total - 1; del_loop: end; go to CLEAN_RETURN; end; /* esw = DEL_DIR, DEL_SEG */ %page; /* * * * replacement and addition * * * */ /* esw = REP_DIR, REP_SEG, ADD_DIR, ADD_SEG */ /* see if have to check gate */ if ^initial_acl /* ep is invalid if initial_acl = "1"b */ then if ((esw = REP_SEG) | (esw = ADD_SEG)) & caller_level > 1 & fixed (entry.ring_brackets (2), 3) < fixed (entry.ring_brackets (3), 3) then do; call check_gate_acl_ (acl_ptr, "0"b, acl_count, (""), code); if code ^= 0 then call fatal_error (code); if esw = ADD_SEG then if entry.acl_frp ^= ""b then do; /* trying to sneek own project in? */ call check_gate_acl_ (acl_start_ptr, "1"b, (entry.acle_count), (""), code); if code ^= 0 then call fatal_error (code); end; end; if (esw = REP_DIR) | (esw = REP_SEG) then do; if initial_acl then if d_s then ael = dir.iacl_count.dir (ring); else ael = dir.iacl_count.seg (ring); else ael = entry.acle_count; /* start by deleting everything */ call acl_$del_acl (n_acls, owning_structure, acl_start_ptr); n_acls = 0; if initial_acl then if d_s then dir.iacl_count.dir (ring) = 0; else dir.iacl_count.seg (ring) = 0; else entry.acle_count = 0; dir.acle_total = dir.acle_total - ael; /* should *.SysDaemon be put back ? */ if ^daemon_sw then do; t_char1 = "*.SysDaemon.* "; call acc_name_$elements (addr (t_char1), acl_entry_ptr, (0)); acl_entry_ptr -> acl1.mode = RW_ACCESS; if d_s then acl_entry_ptr -> acl1.ex_mode = SMA_ACCESS; else acl_entry_ptr -> acl1.ex_mode = ""b; call acl_$add_entry (n_acls, owning_structure, acl_start_ptr, acl_entry_ptr, add_sw, code); if code ^= 0 /* should never happen */ then call fatal_error (code); n_acls = 1; if ^initial_acl then entry.acle_count = entry.acle_count + 1; else if d_s then dir.iacl_count.dir (ring) = dir.iacl_count.dir (ring) + 1; else dir.iacl_count.seg (ring) = dir.iacl_count.seg (ring) + 1; dir.acle_total = dir.acle_total + 1; end; end; do i = 1 to acl_count; on any_other call fatal_error (error_table_$argerr); if d_s then do; temp_access_name = directory_acl_array (i).access_name; temp_mode = directory_acl_array (i).mode; if substr (temp_mode, 4) ^= ""b then do; directory_acl_array (i).status_code = error_table_$bad_acl_mode; call fatal_error (error_table_$argerr); end; end; else do; temp_access_name = segment_acl_array (i).access_name; temp_mode = segment_acl_array (i).mode; if substr (temp_mode, 5) ^= ""b /* let a through */ then do; segment_acl_array (i).status_code = error_table_$bad_acl_mode; call fatal_error (error_table_$argerr); end; temp_mode = temp_mode & REW_ACCESS;/* but not far */ temp_extended_mode = segment_acl_array (i).extended_mode; end; revert any_other; call acc_name_$elements (addr (temp_access_name), acl_entry_ptr, code); if code ^= 0 then do; on any_other call fatal_error (error_table_$argerr); if d_s then do; directory_acl_array (i).status_code = code; go to BAD_ACLE; end; else do; segment_acl_array (i).status_code = code; BAD_ACLE: revert any_other; call fatal_error (error_table_$argerr); end; end; if d_s then do; acl_entry_ptr -> acl1.mode = RW_ACCESS; acl_entry_ptr -> acl1.ex_mode = temp_mode; end; else do; acl_entry_ptr -> acl1.mode = temp_mode; acl_entry_ptr -> acl1.ex_mode = temp_extended_mode; end; call acl_$add_entry (n_acls, owning_structure, acl_start_ptr, acl_entry_ptr, add_sw, code); if code ^= 0 then call fatal_error (code); /* hate to give up here, but no choice */ n_acls = n_acls + 1; if add_sw then do; /* acl added, up count */ if ^initial_acl then entry.acle_count = entry.acle_count + 1; else if d_s then dir.iacl_count.dir (ring) = dir.iacl_count.dir (ring) + 1; else dir.iacl_count.seg (ring) = dir.iacl_count.seg (ring) + 1; dir.acle_total = dir.acle_total + 1; end; end; /* i do loop */ CLEAN_RETURN: if ^initial_acl then call setfaults$if_active ((entry.uid), (entry.pvid), (entry.vtocx), "1"b); call unlock_dir; a_code = 0; return; %page; check_pathname_find_read_lock_and_check_access: procedure; if initial_acl then do; /* need ptr to locked dir */ dirname = a_dir_name; entryname = a_entryname; if dirname = ">" then dirname = ">" || entryname; else if entryname ^= "" /* compatable with old idiot programs */ then dirname = rtrim (dirname) || ">" || entryname; if dirname = "" /* this is always invalid */ then call fatal_error (error_table_$argerr); if esw = LIST_DIR | esw = LIST_SEG then do; call dc_find$dir_read (dirname, dp, code); if code ^= 0 then go to find_error; called_find, locked = "1"b; end; else do; call dc_find$dir_write (dirname, FS_OBJ_IACL_MOD, dp, code); if code ^= 0 then go to find_error; called_find, locked = "1"b; locked_for_write = "1"b; /* fine, ready to go for iacls */ if ring < caller_level | ring > 7 /* only 8 rings, folks */ then call fatal_error (error_table_$bad_ring_brackets); end; end; else do; /* ordinary acl */ dirname = a_dir_name; entryname = a_entryname; if dirname = "" /* this is always invalid */ then call fatal_error (error_table_$argerr); if esw = LIST_DIR | esw = LIST_SEG then do; call dc_find$obj_status_read (dirname, entryname, 1, ep, code); if code ^= 0 then go to find_error; locked, called_find = "1"b; dp = ptr (ep, 0); end; else do; call dc_find$obj_access_write (dirname, entryname, 1, FS_OBJ_ACL_MOD, ep, code); if code ^= 0 then find_error: call fatal_error (code); locked, called_find = "1"b; dp = ptr (ep, 0); locked_for_write = "1"b; if entry.dirsw then if caller_level > bin (entry.ex_ring_brackets (1), 3) /* modify bracket */ then call fatal_error (error_table_$bad_ring_brackets); else ; else if caller_level > bin (entry.ring_brackets (1)) then call fatal_error (error_table_$bad_ring_brackets); end; if entry.dirsw then do; if esw > ADD_DIR then call fatal_error (error_table_$dirseg); /* have already checked mode, safe to return */ end; else do; if esw <= ADD_DIR then call fatal_error (error_table_$nondirseg); end; end; /* dp is set, ep is set for non-inacl case, access is okay */ end check_pathname_find_read_lock_and_check_access; %page; check_in_structure: procedure; /* Precheck structure to return errors without doing anything. */ /* check is repeated at actual run through acl to catch modifications */ /* from other processes */ declare fail_sw bit (1) aligned; if esw = DEL_DIR | esw = DEL_SEG then delete_acl_array (*).status_code = 0; else if d_s then directory_acl_array (*).status_code = 0; else segment_acl_array (*).status_code = 0; fail_sw = "0"b; work_p = addr (a_n.ac_name); /* a_n is a temp hold structure */ do i = 1 to acl_count; /* used for argument checking */ if (esw = DEL_DIR) | (esw = DEL_SEG) then do; /* when deleting acl entries, just perform name check */ call acc_name_$elements (addr (delete_acl_array (i).access_name), work_p, code); if code ^= 0 then do; delete_acl_array (i).status_code = code; if code ^= error_table_$invalid_ascii then fail_sw = "1"b; end; end; else if d_s then do; /* look at directory acl modes and do name check */ if substr (directory_acl_array (i).mode, 4) ^= ""b then do; bad_mode: directory_acl_array (i).status_code = error_table_$bad_acl_mode; fail_sw = "1"b; end; else if substr (directory_acl_array (i).mode, 1, 2) = "01"b then do; /* do not allow m without s permission */ directory_acl_array (i).status_code = error_table_$invalid_mode; fail_sw = "1"b; end; call acc_name_$elements (addr (directory_acl_array (i).access_name), work_p, code); if code ^= 0 then do; fail_sw = "1"b; directory_acl_array (i).status_code = code; end; end; else do; /* look at segment acl modes and do name check */ if substr (segment_acl_array (i).mode, 5) ^= ""b then do; /* permit a mode for compatability */ segment_acl_array (i).status_code = error_table_$bad_acl_mode; fail_sw = "1"b; end; call acc_name_$elements (addr (segment_acl_array (i).access_name), work_p, code); if code ^= 0 then do; fail_sw = "1"b; segment_acl_array (i).status_code = code; end; end; end; /* do i = 1 to acl_count */ if fail_sw then do; a_code = error_table_$argerr; go to ERROR_RETURN; end; end check_in_structure; %page; process_specific_list: procedure; ael = acl_count; /* zero out all status codes for unambiguous errors */ on any_other call fatal_error (error_table_$argerr); if d_s then directory_acl_array (*).status_code = 0; else segment_acl_array (*).status_code = 0; revert any_other; fail_sw = "0"b; do i = 1 to ael; offset = 0; on any_other call fatal_error (error_table_$argerr); if d_s then temp_access_name = directory_acl_array (i).access_name; else temp_access_name = segment_acl_array (i).access_name; revert any_other; call acc_name_$elements (addr (temp_access_name), acl_entry_ptr, code); if code ^= 0 then do; on any_other call fatal_error (error_table_$argerr); if d_s then directory_acl_array (i).status_code = code; else segment_acl_array (i).status_code = code; revert any_other; fail_sw = "1"b; go to list_loop; end; call acl_$list_entry (n_acls, owning_structure, acl_start_ptr, acl_entry_ptr, offset, code); if code ^= 0 then if code = error_table_$empty_acl then do; on any_other call fatal_error (error_table_$argerr); if d_s then do; directory_acl_array (*).status_code = error_table_$user_not_found; directory_acl_array (*).mode = ""b; end; else do; segment_acl_array (*).status_code = error_table_$user_not_found; segment_acl_array (*).mode = ""b; segment_acl_array (*).extended_mode = ""b; end; revert any_other; code = 0; return; end; else if code = error_table_$user_not_found then do; on any_other call fatal_error (error_table_$argerr); if d_s then do; directory_acl_array (i).status_code = code; directory_acl_array (i).mode = ""b; end; else do; segment_acl_array (i).status_code = code; segment_acl_array (i).mode = ""b; segment_acl_array (i).extended_mode = ""b; end; revert any_other; code = 0; goto list_loop; /* no such user is okay, continue */ end; else call fatal_error (code); on any_other call fatal_error (error_table_$argerr); if d_s then directory_acl_array (i).mode = acl_entry_ptr -> acl1.ex_mode; else do; /* check if can return ex mode */ segment_acl_array (i).mode = acl_entry_ptr -> acl1.mode; segment_acl_array (i).extended_mode = acl_entry_ptr -> acl1.ex_mode; end; revert any_other; list_loop: end; if fail_sw then call fatal_error (error_table_$argerr); end process_specific_list; %page; process_list_all: procedure; declare saved_dir_change_pclock fixed bin (35); acl_count = n_acls; /* Unlock, allocate, relock */ saved_dir_change_pclock = dir.change_pclock; call lock$dir_unlock (dp); locked = "0"b; on any_other call fatal_error (error_table_$argerr); on area call fatal_error (error_table_$noalloc); /* specific takes precedence */ if refer_allocation then do; if d_s then do; allocate directory_acl in (arg_area); directory_acl.count = acl_count; directory_acl.version = ACL_VERSION_1; return_acl_ptr = acl_ptr; acl_ptr = addr (directory_acl.entries); end; else do; allocate segment_acl in (arg_area); segment_acl.count = acl_count; segment_acl.version = ACL_VERSION_1; return_acl_ptr = acl_ptr; acl_ptr = addr (segment_acl.entries); end; end; else do; if d_s then allocate directory_acl_array in (arg_area); else allocate segment_acl_array in (arg_area); return_acl_ptr = acl_ptr; end; revert any_other, area; /* Relock */ /* hmmm, perhaps we should censor seg_deleted ... ? */ on seg_fault_error signal bad_dir_; call lock$dir_lock_read (dp, code); if code ^= 0 then call fatal_error (code); locked = "1"b; revert seg_fault_error; if dir.change_pclock ^= saved_dir_change_pclock then do; call unlock_dir; /* Locked_for_write guaranteed "0"b */ go to Retry_process_list_all; end; acl_entry_ptr = addr (a_n); do i = 1 to acl_count; offset = i; /* offset ^= 0, so list_entry will not match */ call acl_$list_entry (acl_count, owning_structure, acl_start_ptr, acl_entry_ptr, offset, code); if code = error_table_$argerr then /* see if listing all and count wrong */ signal bad_dir_; else if code ^= 0 then call fatal_error (code); t_char1 = acl_entry_ptr -> acl1.ac_name.person; t_char2 = acl_entry_ptr -> acl1.ac_name.project; tag = acl_entry_ptr -> acl1.ac_name.tag; on any_other call fatal_error (error_table_$argerr); (nostringsize): begin; if d_s then do; directory_acl_array (i).status_code = 0; directory_acl_array (i).access_name = rtrim (t_char1) || "." || rtrim (t_char2) || "." || tag; directory_acl_array (i).mode = acl_entry_ptr -> acl1.ex_mode; directory_acl_array (i).status_code = 0; end; else do; segment_acl_array (i).status_code = 0; segment_acl_array (i).access_name = rtrim (t_char1) || "." || rtrim (t_char2) || "." || tag; segment_acl_array (i).mode = acl_entry_ptr -> acl1.mode; segment_acl_array (i).extended_mode = acl_entry_ptr -> acl1.ex_mode; end; end /* the begin block */; revert any_other; end; end process_list_all; %page; cleanup_: procedure; /** ASSUME that if a cleanup is in progress that verify_lock will be */ /** called, so leave the dir locked for verify_lock to find and */ /** salvage. */ if /* case */ esw = LIST_DIR | esw = LIST_SEG then do; if /* case */ ^structure_supplied & acl_ptr ^= null then if /* tree */ refer_allocation then if d_s then free directory_acl; else free segment_acl; else if d_s then free directory_acl_array; else free segment_acl_array; end; if called_find then call dc_find$finished (dp, "0"b); /* leave locked for verify_lock */ end cleanup_; unlock_dir: procedure; if locked_for_write then do; call sum$dirmod (dp); dir.modify = ""b; end; if called_find then call dc_find$finished (dp, locked); else if locked then call lock$dir_unlock (dp); locked, called_find = "0"b; end unlock_dir; fatal_error: procedure (cc); declare cc fixed bin (35); a_code = cc; if fatal_error_sets_faults /* only true if we have ep, etc. */ then do; call setfaults$if_active ((entry.uid), (entry.pvid), (entry.vtocx), "1"b); fatal_error_sets_faults = ""b; end; call unlock_dir; call cleanup_; /* Free space, locking left untouched */ go to ERROR_RETURN; end fatal_error; ERROR_RETURN: return; %page; %include access_mode_values; %page; %include acl_structures; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include dir_header; %page; %include fs_obj_access_codes; end asd_;  chname.pl1 11/11/89 1132.4r w 11/11/89 0800.4 102006 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ chname: proc; /* Last modified (Date and reasons): by Keith Loepere to provide audit info and to change PAM to use uid's, November 1984. by Keith Loepere to use the new dc_find, August 1984. by BIM 1984 for sst reformat. by E. N. Kittlitz, May 1983, search_ast$check. by E. N. Kittlitz, March 1983, to not backup entry.dtem. by Keith Loepere January 1983 so bad ring bracket error makes it to user. by J. Bongiovanni to always flush pam on directory rename by THVV for bad_dir_ check, 7/77 by D. Vinograd to add new entry retv for use by the volume retriever, 9/76 by S. Barr to use new hash table format, 9/76 by R. Bratt to call find_$finished, 06/01/76 by R. Bratt for pam flush, 2/3/76. by BSG for NSS, 4/25/75. by Bernard S. Greenberg for SST name table, Feb. 18, 1975. by Richard H. Gumpertz 9 July 71 to interpret user not on acl as "null 7,7,7" when checking validation level by Richard H Gumpertz on 8 July 71 to check brackets for >= validation level */ cfile: entry (a_parent, a_ename, a_oldname, a_newname, a_code); /* This proceedure to used to add, delete, and rename segments. It has two entry points. The entry point cfile" takes a directory path name and entry name to determine the segment affected while the entry point "cseg" uses a pointer. USAGE: call chname$cfile(directory_name, entry_name, old_name, new_name, error_code); 1. directory_name char(*) path name of directory in which entry_name is an entry. 2. entry_name char(*) entry name of segment to be changed. 3. old_name char(*) name to be deleted from name list of entry_name. 4. new_name char(*) name to be added to name list of entry_name. 5. error_code fixed bin(35) file system error code (Output). USAGE: call chname$cseg(segment_pointer, old_name, new_name, error_code); 1. segment_pointer pointer pointer to segment to be changed. 2. - 4. Same as above. NOTE: 1. Caller must have write access with respect to the directory. */ dcl a_code fixed bin (35); dcl a_ename char (*); dcl a_ep ptr; dcl a_newname char (*); dcl a_oldname char (*); dcl a_parent char (*); dcl a_sp ptr; dcl ep_known fixed bin static init (2) options (constant); ; dcl file fixed bin static init (0) options (constant); dcl seg fixed bin static init (1) options (constant); ; dcl areap ptr; dcl code fixed bin (35); dcl ename char (32); dcl entry_point fixed bin; dcl just_delete_name bit (1) aligned; dcl last_namep ptr; dcl namecnt fixed bin (18); dcl nep ptr; dcl new_np ptr; dcl newname char (32) aligned; dcl newname_p ptr; dcl next_np ptr; /* ptr to next primary name before it is moved in */ dcl old_np ptr; dcl oldname char (32) aligned; dcl oldname_p ptr; dcl parent char (168); dcl pvid bit (36) aligned; dcl save_fp bit (18); /* save of old primary name forward thread */ dcl sp ptr; dcl uid bit (36) aligned; dcl vtocx fixed bin; dcl active_hardcore_data$ensize fixed bin external; dcl error_table_$bad_ring_brackets fixed bin (35) external; dcl error_table_$namedup fixed bin (35) external; dcl error_table_$noalloc fixed bin (35) external; dcl error_table_$noentry fixed bin (35) external; dcl error_table_$nonamerr fixed bin (35) external; dcl error_table_$oldnamerr fixed bin (35) external; dcl error_table_$segnamedup fixed bin (35) external; dcl pds$processid bit (36) aligned ext; dcl 1 pds$transparent aligned ext, 2 m bit (1) unaligned, 2 u bit (1) unaligned; dcl sst$ast_track bit (1) aligned external; dcl change_dtem entry (ptr); dcl fs_alloc$alloc entry (ptr, fixed bin, ptr); dcl fs_alloc$free entry (ptr, fixed bin, ptr); dcl hash$in entry (ptr, ptr, fixed bin (35)); dcl hash$out entry (ptr, ptr, ptr, fixed bin (35)); dcl hash$search entry (ptr, ptr, ptr, fixed bin (35)); dcl level$get entry returns (fixed bin); dcl lock$dir_unlock entry (ptr); dcl lock$lock_ast entry; dcl lock$unlock_ast entry; dcl pathname_am$flush entry (bit (36) aligned); dcl search_ast$check entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin (35)) returns (ptr); dcl sum$dirmod entry (ptr); dcl (addr, bin, bit, clock, divide, fixed, null, ptr, rel, rtrim) builtin; %page; entry_point = file; /* entered via chname entry point */ parent = a_parent; ename = a_ename; go to common; cseg: entry (a_sp, a_oldname, a_newname, a_code); entry_point = seg; /* entered via chname$cseg entry point */ sp = a_sp; goto common; retv: entry (a_ep, a_oldname, a_newname, a_code); ep = a_ep; dp = ptr (ep, 0); entry_point = ep_known; common: code = 0; oldname = a_oldname; newname = a_newname; if newname = "" then just_delete_name = "1"b; /* if no name is to be added, then just remove a name */ else just_delete_name = "0"b; /* otherwise adding or replacing a name */ if entry_point ^= ep_known then do; if entry_point = file then call dc_find$obj_status_write (parent, ename, 0, FS_OBJ_RENAME, ep, code); else call dc_find$obj_status_write_ptr (sp, FS_OBJ_RENAME, ep, code); dp = ptr (ep, 0); if code ^= 0 then go to finale; if entry.bs then if ^(entry.dirsw) then if fixed (entry.ring_brackets (1), 3) < (level$get ()) then do; code = error_table_$bad_ring_brackets; go to unlock; end; else ; else if fixed (entry.ex_ring_brackets (1), 3) < (level$get ()) then do; code = error_table_$bad_ring_brackets; go to unlock; end; else ; end; namecnt = fixed (entry.nnames, 18); if namecnt = 1 then if just_delete_name /* Will there be any names left after oldname is deleted */ then do; /* and no name is added */ code = error_table_$nonamerr; go to unlock; end; areap = ptr (dp, dir.arearp); dir.modify = pds$processid; if just_delete_name then go to delete_name; newname_p = addr (newname); call hash$search (dp, newname_p, nep, code); if code = 0 then do; if ep = nep then code = error_table_$segnamedup; else code = error_table_$namedup; go to unlock; end; if code ^= error_table_$noentry then go to unlock; call fs_alloc$alloc (areap, active_hardcore_data$ensize, new_np); /* allocate storage for newname */ if new_np = null then go to noalloc_err; new_np -> names.name = newname; new_np -> names.entry_rp = rel (ep); new_np -> names.type = NAME_TYPE; new_np -> names.size = active_hardcore_data$ensize; new_np -> names.owner = entry.uid; call hash$in (dp, new_np, code); if code ^= 0 then go to hash_error; last_namep = ptr (ep, entry.name_brp); new_np -> names.bp = rel (last_namep); last_namep -> names.fp = rel (new_np); entry.name_brp = rel (new_np); namecnt = namecnt + 1; /* increase count of number of names for "entry" */ delete_name: if oldname = "" then go to finish; oldname_p = addr (oldname); call hash$search (dp, oldname_p, nep, code); if code ^= 0 then go to finish; /* if name not in hash table (most probably) */ if ep ^= nep then go to name_err; /* if name associated with another entry */ call hash$out (dp, oldname_p, old_np, code); /* Hash "oldname" to find its place in the */ if code ^= 0 then do; /* hash table and vacate this place. */ name_err: code = error_table_$oldnamerr; go to finish; end; if old_np -> names.bp then do; /* not primary name */ ptr (old_np, old_np -> names.bp) -> names.fp = old_np -> names.fp; if old_np -> names.fp then ptr (old_np, old_np -> names.fp) -> names.bp = old_np -> names.bp; else entry.name_brp = old_np -> names.bp; end; else do; /* * The name entry for the primary name is stored in the entry structure. If the name being deleted or changed * was the primary name, then the new primary name must be moved into this area. The steps are: * 1. The new primary name is hashed out. * 2. The new primary name is threaded out. * 3. The contents of the new primary name are copied into the slot in the entry. * 4. The new primary name in its new location is hashed in. */ if just_delete_name then next_np = ptr (dp, old_np -> names.fp); else next_np = new_np; call hash$out (dp, addr (next_np -> names.name), next_np, code); if code ^= 0 then goto finish; /* Unthread new primary name. */ if next_np -> names.fp = "0"b then entry.name_brp = next_np -> names.bp; /* end of chain */ else ptr (dp, next_np -> names.fp) -> names.bp = next_np -> names.bp; ptr (dp, next_np -> names.bp) -> names.fp = next_np -> names.fp; /* Copy new primary name into entry slot, but save old primary threads. */ save_fp = old_np -> names.fp; old_np -> names = next_np -> names; old_np -> names.fp = save_fp; old_np -> names.bp = "0"b; call hash$in (dp, old_np, code); if code ^= 0 then goto finish; old_np = next_np; /* set so space will be freed later */ if entry.bs & sst$ast_track then do; /* AST names */ uid = entry.uid; /* Must extract info before locking AST */ pvid = entry.pvid; vtocx = entry.vtocx; temp_entry_name = newname; /* This is the new name */ call lock$lock_ast; nm_astep = search_ast$check (uid, pvid, vtocx, (0)); /* ignore code since it's just for name table */ if nm_astep ^= null then %include make_sstnt_entry; call lock$unlock_ast; end; end; namecnt = namecnt - 1; /* decrease count of number of names for "entry" */ call fs_alloc$free (areap, active_hardcore_data$ensize, old_np); /* free storage for "oldname" */ if entry.dirsw then call pathname_am$flush (entry.uid); finish: entry.nnames = namecnt; if ^pds$transparent.m then /* is it ok to change date */ if entry.dtem ^= bit (fixed (clock (), 52), 36) then /* if 'now', don't bother. we're not setfaulting */ call change_dtem (ep); /* if old, brighten it up */ dir.modify = "0"b; call sum$dirmod (dp); /* Notify control that "parent" has been modified */ go to unlock1; /* Error handlers. */ unlock: dir.modify = "0"b; unlock1: if entry_point ^= ep_known then do; if entry_point = file then call dc_find$finished (dp, "1"b); else call lock$dir_unlock (dp); end; finale: a_code = code; return; hash_error: call fs_alloc$free (areap, active_hardcore_data$ensize, new_np); go to unlock; noalloc_err: code = error_table_$noalloc; go to unlock; /* format: off */ %page; %include aste; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include dir_header; %page; %include dir_ht; %page; %include dir_name; %page; %include fs_obj_access_codes; %page; %include fs_types; %page; %include sstnt; end chname;  copy_fdump.pl1 11/11/89 1132.4rew 11/11/89 0800.0 159507 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* COPY_FDUMP - Make Copy of Information in Dump Partition: This program creates a toe-hold into the dump partition. This partition may contain dump information left by the bce dump program. This information is copied into multiple segments in the directory >dumps. These segments are force-deactivated as a hedge against crashes. 4/7/71 - N. I. Morris & S. H. Webber 9/28/71 - modified to allow setting erf no and to add error codes - D. M. Jordan 3/2/73 - modified for 6180 and v2pl1 - RE Mullen 7/11/73 - modified to copy dn355 core image out of part dump and added get_erf_no entry - RE Mullen 10/08/75 - modified for multiple 355s - Robert Coren 02/01/79 - modified to allow more than 10 segnos - F. W. Martinson 08/25/80 - Modified to announce copy in syserr log -- W. Olin Sibert 11/11/80 - modified for the DPS8/70M CPU -- J. A. Bush 03/21/81, W. Olin Sibert, for ADP PTWs and ptw_util_. 02/26/82 - J. Bongiovanni, to eliminate use of FSDCT, force deactivate dump segments. 11/05/84, Keith Loepere to change terminate to terminate_. 01/22/85, Keith Loepere for new find_partition. */ /****^ HISTORY COMMENTS: 1) change(86-10-23,Fawcett), approve(86-10-23,MCR7517), audit(86-10-30,Beattie), install(86-11-03,MR12.0-1206): Changed to remove the word BOS from message. END HISTORY COMMENTS */ copy_fdump: proc (a_code); dcl i fixed bin, /* page table index */ p ptr, /* handy pointer */ ptp ptr, /* Pointer to page table of abs-seg */ (dt, dt_dn355) char (24), /* date and time strings */ (ename, a_ename, xname, ename_dn355, a_ename_dn355) char (32), /* dump segment entry names */ erf char (12), /* converted ERF number */ (erf_no, a_erf_no) fixed bin, /* number to set next dump to */ ptsi fixed bin, /* page table size index */ code fixed bin (35), /* error code */ a_code fixed bin (35), /* error code to return to caller */ rb (3) fixed bin (6) init (7, 7, 7), /* ring brackets for call to append */ seqno fixed bin, /* dump sequence number */ esw fixed bin, /* entry switch */ dumpadd fixed bin (18), /* address within dump partition */ nrecs fixed bin (18), /* number of records in PART DUMP */ next_part_add fixed bin, /* dumpadd of rec following PART DUMP */ first fixed bin (20), /* first address within dump partition */ (length, a_length) fixed bin (35), /* length dump info */ (a_valid, a_valid_dn355) bit (1), /* = 1 if dumps are valid */ word_count fixed bin (18), /* number of words to copy from dump partition at one time */ copy (word_count) fixed bin (35) based, /* structure to allow copying of dump data */ dump_pvtx fixed bin, dump_pvid bit (36) aligned, tsdwp ptr, /* pointer to SDW */ tsdw bit (72); /* temporary for SDW */ dcl (max_size, max_pages, dn355_size) fixed bin; /* max for output segs */ dcl single_dn355_size fixed bin (35); /* number of bits in 355 core image */ dcl words_per_image fixed bin; dcl pg_size fixed bin; dcl (dumping_Multics, dumping_dn355) bit (1); /* to keep track of what we want to dump */ dcl (hdr_size, rest_size) fixed bin; /* sizes in words */ dcl dn355_copy bit (single_dn355_size) aligned based; /* for copying 355 dump */ dcl 1 din based aligned, /* structure of first 64K of PART DUMP */ 2 header (hdr_size) fixed bin (35), /* registers, rel locs of segs, etc */ 2 dn355_images (4), 3 dn355_core bit (single_dn355_size) aligned, /* dn355 core image put here by FD355 */ 2 rest (rest_size) fixed bin (35); /* start of segments dumped by FDUMP */ dcl (error_table_$noaccess fixed bin (35), error_table_$dmpinvld fixed bin (35), error_table_$noprtdmp fixed bin (35), error_table_$bdprtdmp fixed bin (35), error_table_$dmpvalid fixed bin (35), error_table_$nopart fixed bin (35), sys_info$default_max_length fixed bin (35), sys_info$page_size fixed bin (35), pds$process_group_id char (32) aligned, abs_seg$) ext; dcl sst$astsize fixed bin external static; dcl 1 sst$level (0:3) aligned external static, 2 ausedp bit (18) unaligned, 2 no_aste bit (18) unaligned; dcl privileged_mode_ut$swap_sdw ext entry (ptr, ptr), thread$out entry (ptr, bit (18) unal), lock$lock_ast entry, lock$unlock_ast entry, get_ptrs_$given_astep ext entry (ptr) returns (bit (72) aligned), syserr ext entry options (variable), condition_ ext entry (char (*), entry), reversion_ ext entry (char (*)), date_time_ ext entry (fixed bin (71), char (*)), append$branchx ext entry (char (*), char (*), fixed bin (5), (3) fixed bin (6), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35)), initiate ext entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)), pc$cleanup entry (ptr), get_aste ext entry (fixed bin) returns (ptr), put_aste ext entry (ptr), cv_bin_$dec ext entry (fixed bin (17)) returns (char (12) aligned), demand_deactivate$force_given_segno entry (ptr, fixed bin (35)), terminate_$noname entry (ptr, fixed bin (35)), find_partition entry (char (*), fixed bin, bit (36) aligned, fixed bin (18), fixed bin (18), fixed bin (35)), ptw_util_$make_disk entry (pointer, fixed bin (20)); dcl (addr, addrel, bit, char, divide, fixed, ltrim, min, null, size, substr) builtin; /* */ esw = 0; go to setup; set_erf_no: entry (a_erf_no, a_code); erf_no = a_erf_no; esw = 1; go to setup; get_erf_no: entry (a_length, a_valid, a_ename, a_valid_dn355, a_ename_dn355, a_code); esw = 2; a_length = 0; a_valid, a_valid_dn355 = "0"b; a_ename, a_ename_dn355 = " "; setup: a_code = 0; p = null (); /* So any_other handler wins */ pg_size = sys_info$page_size; /* number of words per page */ max_size = sys_info$default_max_length; /* max number of words in segs copy_fdump creates */ max_pages = divide (max_size + pg_size - 1, pg_size, 17, 0); dn355_size = 16384 * 4; /* words equaling 32K of 18bit words for up to 4 355s */ single_dn355_size = 16384 * 36; /* bits for one 355 core image */ words_per_image = 16384; /* same in words */ hdr_size = size (dump); /* number of words in dump header */ /* Determine location and size of the dump partition. */ call find_partition ("dump", dump_pvtx, dump_pvid, dumpadd, nrecs, code); if code ^= 0 then do; if code = error_table_$nopart then a_code = error_table_$noprtdmp; else a_code = code; return; end; first = dumpadd; if nrecs = 0 then do; a_code = error_table_$bdprtdmp; return; end; next_part_add = first + nrecs; /* Stop before here */ /* Now create an abs_seg through which to look at the dump */ dumpptr = addr (abs_seg$); /* get pointer to abs_seg */ tsdwp = addr (tsdw); /* get a pointer to the SDW to be used */ call lock$lock_ast; astep = get_aste (max_pages); /* get a large page table / ASTE */ ptsi = fixed (aste.ptsi, 2); call thread$out (astep, sst$level.ausedp (ptsi)); call lock$unlock_ast; ptp = addrel (astep, sst$astsize); /* get a pointer to the page table */ tsdw = get_ptrs_$given_astep (astep); /* get the actual SDW to use */ call privileged_mode_ut$swap_sdw (dumpptr, tsdwp);/* make abs_seg point to the dump seg */ aste.pvtx = dump_pvtx; aste.csl = bit (fixed (max_pages,9), 9); /* Set correct current length in AST entry. */ aste.nqsw = "1"b; /* indicate no quota for this segment */ /* */ /* Set up a condition in case we bomb out. */ call condition_ ("any_other", handler); if esw = 1 then go to set_num; /* just set the erf number in the dump partition */ if esw = 2 then go to get_num; /* just return info in dump header */ /* Attempt to copy the dump information into the hierarchy. */ do seqno = 0 by 1; /* Keep going until we run out of information. */ do i = 0 to (max_pages - 1) while (i < next_part_add - dumpadd); call ptw_util_$make_disk (addrel (ptp, i), (dumpadd + i)); /* The disk record */ end; if seqno = 0 then do; /* were making our first seg in >dumps */ call check_dump_header; /* Initialize some variables and see whats in PART DUMP */ length = min (length, nrecs * pg_size - dn355_size - hdr_size); if dumping_dn355 then do; /* we want to make a special seg in >dumps for 355core image */ xname = ename_dn355; /* will have ".355" suffix */ word_count = dn355_size; /* clearly */ call get_branch; /* get and initiate a branch */ do i = 1 to 4; /* copy up to four 355 core images */ if substr (dumpptr -> dump.dumped_355s, i, 1) /* there is an image for this one */ then p -> dn355_copy = dumpptr -> din.dn355_images (i).dn355_core; /* copy it */ else p -> dn355_copy = "0"b; p = addrel (p, words_per_image); /* bump to next core image */ end; dumpptr -> dump.valid_355 = "0"b; /* turn off the valid bit */ end; if dumping_Multics then do; /* need to skip over the dn355 stuff */ call pc$cleanup (astep); /* Force all pages from core. */ aste.npfs = "0"b; /* turn off no page fault switch */ do i = 0 to 1; /* fill in first 2 ptws */ call ptw_util_$make_disk (addrel (ptp, i), (dumpadd + i)); /* The disk record */ end; dumpadd = dumpadd + divide (dn355_size, pg_size, 18, 0); /* skip over dn355 data */ do i = 2 to (max_pages - 1) while (i < next_part_add - dumpadd); call ptw_util_$make_disk (addrel (ptp, i), (dumpadd + i)); /* The disk record */ end; rest_size = min (max_size - hdr_size, length); /* does not include header */ word_count = hdr_size + rest_size; /* the number of words to this branch */ xname = ename; /* the name of the branch we will create */ call get_branch; /* get and initiate the branch */ p -> copy = dumpptr -> copy; /* copy the header and some Multics segs */ length = length - rest_size; /* remaining length is less now */ end; end; else do; /* no need to worry about dn355 stuff */ substr (ename, 13) = ltrim (char (seqno)) || "." || ltrim (erf); word_count = min (length, max_size); /* take what we can */ xname = ename; /* a standard name */ call get_branch; p -> copy = dumpptr -> copy; /* copy the data */ length = length - word_count; /* shorten remaining length */ end; call pc$cleanup (astep); /* Force all pages from core. */ aste.npfs = "0"b; /* Turn off the no page fault switch. */ dumpadd = dumpadd + max_pages; /* Step partition address to next max_pagesK. */ if ^dumping_Multics then go to endup; /* dn355 core is copied already */ if length <= 0 then go to cleanup; /* Check for completion of Multics dump copying */ end; /* Continue loop until dump info exhausted. */ /* */ cleanup: call ptw_util_$make_disk (ptp, first); /* Insert toe-hold to first record */ dumpptr -> dump.valid = "0"b; /* Turn off valid bit. */ call syserr (LOG, "copy_fdump: Copied fdump image of erf ^d (^a) for ^a", /* let anyone who cares know about this */ dumpptr -> dump.erfno, dt, pds$process_group_id); endup: call pc$cleanup (astep); /* Force all pages from core. */ exit: call reversion_ ("any_other"); if p ^= null () then do; /* terminate and force-deactivate */ call demand_deactivate$force_given_segno (p, code); call terminate_$noname (p, code); end; call lock$lock_ast; call put_aste (astep); /* return the AST entry */ call lock$unlock_ast; tsdw = ""b; call privileged_mode_ut$swap_sdw (dumpptr, tsdwp); return; set_num: /* CODE to reset the erf number in PART DUMP */ call ptw_util_$make_disk (ptp, first); /* Establish address for first page */ if (dumpptr -> dump.valid | dumpptr -> dump.valid_355) then do; /* Previous dump hasn't been picked up */ a_code = error_table_$dmpvalid; go to endup; end; dumpptr -> dump.erfno = erf_no - 1; /* set the dump number */ go to endup; get_num: /* CODE to get the erf number in PART DUMP */ call ptw_util_$make_disk (ptp, first); /* get address of first page */ call check_dump_header; /* internal proc to decode header info */ if dumping_Multics then do; a_length = length; a_valid = dumping_Multics; a_ename = ename; end; if dumping_dn355 then do; a_valid_dn355 = dumping_dn355; a_ename_dn355 = ename_dn355; end; go to endup; /* */ /* INTERNAL PROC to examine the dump header */ check_dump_header: proc; if esw ^= 1 then /* previously checked that it's invalid for set_erf_no entry */ if dumpptr -> dump.valid = "0"b then if dumpptr -> dump.valid_355 = "0"b then do; a_code = error_table_$dmpinvld; /* No valid dumps so scram */ go to endup; end; dumping_Multics = dumpptr -> dump.valid; /* want to copy valid Multics dump */ dumping_dn355 = dumpptr -> dump.valid_355; /* want to copy valid 355 dump */ length = dumpptr -> dump.words_dumped; /* keep this number handy */ /* Now fabricate a name for the dump. The names look like ... MMDDYY.TTTT.N.EEE MMDDYY = month, day, year TTTT = time of day N = sequence number of dump segment EEE = ERF number */ erf = cv_bin_$dec ((dumpptr -> dump.erfno)); /* Convert the ERF number. */ if dumping_Multics then do; call date_time_ (dumpptr -> dump.time, dt); /* Convert the date and time of dump. */ ename = substr (dt, 1, 2) || substr (dt, 4, 2) || substr (dt, 7, 2) || "." || substr (dt, 11, 5) || "0." || ltrim (erf); end; if dumping_dn355 then do; call date_time_ (dumpptr -> dump.time_355, dt_dn355); /* setup name for 355 segs in >dumps similarly */ ename_dn355 = substr (dt_dn355, 1, 2) || substr (dt_dn355, 4, 2) || substr (dt_dn355, 7, 2) || "." || substr (dt_dn355, 11, 5) || "0." || ltrim (erf) || ".355"; end; end check_dump_header; /* INTERNAL PROC to create a seg in >dumps, and initiate it */ get_branch: proc; /* share stack frame */ append: if p ^= null () then do; /* terminate and force-deactivate */ call demand_deactivate$force_given_segno (p, code); call terminate_$noname (p, code); end; call append$branchx (">dumps", xname, RW_ACCESS_BIN, rb, (pds$process_group_id), 0, 0, 36 * word_count, code); if code ^= 0 then do; if code = error_table_$noaccess then do;/* >dumps is not there */ call append$branchx (">", "dumps", A_ACCESS_BIN, rb, "*.*.*", 1, 0, 0, code); /* create it */ if code ^= 0 then do; a_code = code; go to endup; end; go to append; /* loop back to try again */ end; else do; /* Branch cannot be created. */ a_code = code; go to endup; end; end; call initiate (">dumps", xname, "", 0, 0, p, code); /* get a pointer to the new seg */ if p = null then do; /* If initiation failed ... */ a_code = code; go to endup; end; end get_branch; /* */ /* INTERNAL PROC to handle unclaimed signals */ handler: proc (mc_ptr, name); dcl mc_ptr ptr, /* pointer to machine conditions (not used) */ name char (*); /* name of the condition */ call syserr (ANNOUNCE, "copy_fdump: unexpected ^a signal.", name); go to exit; /* Print comment, and then clean up and exit. */ end handler; %page; %include access_mode_values; %page; %include aste; %page; %include bos_dump; %page; %include syserr_constants; /* */ /* BEGIN MESSAGE DOCUMENTATION Message: copy_fdump: unexpected NAME signal. S: $info T: $run M: An attempt to copy the dump from the DUMP partition with copy_fdump resulted in an unclaimed signal. This may be due to damage to the DUMP partition contents, a malfunction of the BCE dump command, a supervisor error, or a simple difficulty like running out of space in >dumps. The system continues operation. The copied dump may be only partly valid. A: $notify Message: copy_fdump: Copied fdump image of erf NNN (MM/DD/YY HHMM.M) for USERNAME S: $info T: $run M: The user identified by USERNAME has successfully copied the FDUMP image for the specified ERF out of the DUMP partition. The time the FDUMP was taken is also included in the message. This message is informational only, and is intended only as an aid in tracking system progress by perusing the syserr log. A: $ignore END MESSAGE DOCUMENTATION */ end copy_fdump;  correct_qused.pl1 11/11/89 1132.4r w 11/11/89 0800.4 99540 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ correct_qused: proc (a_dir, a_osu, a_odu, a_nsu, a_ndu, a_did_anything, a_code); /* Quota used reconstructor. An original algorithm by Bernard Greenberg Feb. 1977 Modified 1/82 BIM for write lock on dir to get exclusive lock. Modified 8/83 E. N. Kittltiz for search_ast$check. Modified 7/84 Keith Loepere to use the new dc_find. Modified 10/84 Keith Loepere to provide audit info. Modified 12/84 Keith Loepere for new dir quota definition. */ /* Parameters */ dcl a_code fixed bin (35) parameter; dcl a_did_anything bit (1) aligned parameter; dcl a_dir char (*) parameter; dcl a_ndu fixed bin (34) parameter; dcl a_nsu fixed bin (34) parameter; dcl a_odu fixed bin (34) parameter; dcl a_osu fixed bin (34) parameter; /* Variables */ dcl branches_passed fixed bin; dcl code fixed bin (35); dcl correct_dir bit (1) aligned; dcl correct_seg bit (1) aligned; dcl did_anything bit (1) aligned; dcl dname char (168); dcl dpvid bit (36) aligned; dcl dudelta fixed bin (34); dcl duid bit (36) aligned; dcl dvtocx fixed bin; dcl htblsize fixed bin; dcl 1 local_vtoce aligned like vtoce; dcl ndu fixed bin (34); /* old-new X seg-dir used */ dcl nentries fixed bin; dcl nsu fixed bin (34); dcl odu fixed bin (34); dcl osu fixed bin (34); dcl scode fixed bin (35); dcl scode1 fixed bin (35); dcl sudelta fixed bin (34); /* External */ dcl error_table_$rqover fixed bin (35) ext; dcl error_table_$vtoce_connection_fail fixed bin (35) ext; /* Misc */ dcl (addr, fixed, mod, null, ptr, rel, unspec) builtin; dcl bad_dir_ condition; /* Entries */ dcl get_pvtx entry (bit (36) aligned, fixed bin (35)) returns (fixed bin); dcl lock$lock_ast entry; dcl lock$unlock_ast entry; dcl logical_volume_manager$lvtep entry (bit (36) aligned, ptr, fixed bin (35)); dcl quotaw$rvq entry (ptr, fixed bin (34), fixed bin (34), fixed bin (34), fixed bin (34)); dcl search_ast$check entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin (35)) returns (ptr); dcl syserr entry options (variable); dcl vtoc_attributes$correct_qused entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin (34), fixed bin (34), fixed bin (35)); dcl vtoc_man$get_vtoce entry (bit (36) aligned, fixed bin, fixed bin, bit (3), ptr, fixed bin (35)); %page; /* The basic operational theorem of this program is that the quota used total for any directory quota cell is either right or wrong by a finite and constant amount. If that amount of error can be computed at any given time (T0) by figuring out what it should be, it can be corrected at any time later by adding this fixed correction, regardless of how many pages were created or destroyed in the interim. */ correct_dir, correct_seg = "1"b; go to join; correct_seg_qused: entry (a_dir, a_osu, a_nsu, a_did_anything, a_code); correct_dir = "0"b; correct_seg = "1"b; go to join; correct_dir_qused: entry (a_dir, a_odu, a_ndu, a_did_anything, a_code); correct_dir = "1"b; correct_seg = "0"b; join: dname = a_dir; did_anything = "0"b; scode, code = 0; vtocep = addr (local_vtoce); call dc_find$dir_write_priv (dname, FS_OBJ_CORRECT_QUSED, dp, code); if code ^= 0 then go to err; if correct_seg then do; call logical_volume_manager$lvtep (dir.sons_lvid, (null ()), code); /* We check before and after cycle, the first time to rule out problem. We check at the end if demount occured during run. Still small window. */ if code ^= 0 then go to unlock_err; end; /* Directory is locked at this point (actually back at dc_find). Until we unlock it, nobody can truncate VTOCEs or create or delete segments or dirs in it. Finite and constant set of inferior UID's from here to the end. Furthermore, all "used" change can only be on active segments, all of which must be active now, and no new ones can become active because we have the directory locked. */ nentries = dir.seg_count + dir.dir_count; htblsize = (nentries * 7) / 5; duid = dir.uid; /* Get uid into automatic */ dpvid = dir.pvid; /* pvid of directory, copied from branch */ dvtocx = dir.vtocx; /* vtocx of directory, copied from branch */ call lock$lock_ast; /* Lock the AST. If this dir is not active, none of its sons can become active until we unlock this dir. If it is, we must call quotaw to get info. */ astep = search_ast$check (duid, dpvid, dvtocx, code); /* is it there? */ if code ^= 0 then do; /* double-uid */ call lock$unlock_ast; go to unlock_err; end; if astep = null then do; nsu = 0; /* At time T0, which never existed, no active inferior quota was found */ call lock$unlock_ast; /* And will remain so. */ call internal_vtoc_man (dir.uid, dir.pvid, dir.vtocx); /* Get current quota numbers for this dir */ if code ^= 0 then go to unlock_err; ndu = fixed (vtoce.records, 9); /* Count dirs pages toward itself */ osu = vtoce.used (0); odu = vtoce.used (1); /* Read old totals at time T0 */ end; else /* There is active inferior quota */ call quotaw$rvq (astep, osu, odu, nsu, ndu); /* Get false (o) numbers and active inferior totals (n) */ /* The time that quotaw$rvq reads these numbers is called "T0". The "false" numbers read out of the ASTE for this dir at T0 is (was) wrong by a finite number, "d(0:1)". The difference between the active inferior totals and the "right" number at time T0 is the sum of the non-active used for all VTOCEs not active at time T0. As long as the AST remains locked, the membership of this set cannot change. We have not unlocked it since T0. From this number, we can find "d". */ begin; /* * * * * START OF BEGIN BLOCK * * * * * * */ dcl hshx fixed bin; dcl htbl (0:htblsize - 1) bit (36) aligned; /* Enter begin block to make hashtable */ unspec (htbl) = "0"b; /* No stuff in table */ if astep ^= null then do; /* AST still locked here */ do astep = ptr (astep, aste.infp) repeat ptr (astep, aste.infl) while (rel (astep)); /* Loop the AST to record activity at T0 */ if hash_search ((aste.uid)) then call syserr (1, "correct_qused: hash error"); else htbl (hshx) = aste.uid; end; call lock$unlock_ast; /* I don't care what gets deactivated now */ end; branches_passed = 0; /* Don't loop */ nentries = nentries + dir.lcount; /* Gotta count them too */ do ep = ptr (dp, dir.entryfrp) repeat ptr (dp, entry.efrp) while (rel (ep)); branches_passed = branches_passed + 1; if branches_passed > nentries then signal bad_dir_; if entry.bs then do; /* Skip them links */ if entry.owner ^= dir.uid | (entry.type ^= SEG_TYPE & entry.type ^= DIR_TYPE) then signal bad_dir_; if ^hash_search (entry.uid) then do; /* If not active at T0, get VTOC stuff */ if ^correct_seg then if ^entry.dirsw then go to next_entry; /* avoid asking for non-mounted vtoce */ call internal_vtoc_man (entry.uid, (entry.pvid), entry.vtocx); if code ^= 0 then scode = code; else do; if vtoce.dirsw then do; if vtoce.received (0) = 0 & ^vtoce.master_dir then nsu = nsu + vtoce.used (0); if vtoce.received (1) = 0 then ndu = ndu + vtoce.used (1); /* dirs pages already counted in used */ end; else nsu = nsu + fixed (vtoce.records, 9); end; end; end; next_entry: end; if branches_passed < nentries then signal bad_dir_; hash_search: proc (c_uid) returns (bit (1) aligned); /* Internal to begin block */ dcl c_uid bit (36) aligned parameter; dcl cuid bit (36) aligned; dcl hshi fixed bin; cuid = c_uid; if cuid = "0"b then signal bad_dir_; hshi = mod (fixed (cuid, 36), htblsize); do hshx = hshi to htblsize - 1, 0 to hshi - 1; if htbl (hshx) = cuid then return ("1"b); else if htbl (hshx) = "0"b then return ("0"b); end; signal bad_dir_; /* dir header must have lied */ end hash_search; end; /* * * * * END OF BEGIN BLOCK * * * * * * * */ %page; /* Now nsu and ndu are the correct used totals at time T0, while osu and odu are the erroneous totals at time T0. Thus, we can find d(0:1), the difference. This difference will not change, it is the fixed error. */ sudelta = nsu - osu; dudelta = ndu - odu; /* We are now free to change whatever we have at any time by these differences. */ if scode ^= 0 then do; /* if was problem check for lv demount window */ if correct_seg then do; call logical_volume_manager$lvtep (dir.sons_lvid, (null ()), scode1); if scode1 ^= 0 then do; code = scode1; sudelta, dudelta = 0; end; end; end; if ^correct_seg then sudelta = 0; if ^correct_dir then dudelta = 0; if sudelta ^= 0 | dudelta ^= 0 then call vtoc_attributes$correct_qused (duid, dir.pvid, (dir.vtocx), sudelta, dudelta, code); else code = 0; if code = 0 then did_anything = "1"b; else if code = error_table_$rqover then did_anything = "1"b; /* Avoid page fault */ unlock_err: call dc_find$finished (dp, "1"b); err: if code = 0 then code = scode; a_did_anything = did_anything; a_code = code; if correct_seg then do; a_nsu = nsu; a_osu = osu; end; if correct_dir then do; a_ndu = ndu; a_odu = odu; end; return; %page; internal_vtoc_man: proc (b_uid, b_pvid, b_vtocx); /* Internal proc to get a whole bunch of vtoc info for a segment guaranteed not to be active */ dcl b_pvid bit (36) aligned parameter; dcl b_uid bit (36) aligned parameter; dcl b_vtocx fixed bin (17) unal parameter; dcl pvtx fixed bin; pvtx = get_pvtx (b_pvid, code); if code ^= 0 then return; call vtoc_man$get_vtoce (b_pvid, pvtx, (b_vtocx), "100"b, vtocep, code); if code = 0 then if vtoce.uid ^= b_uid then code = error_table_$vtoce_connection_fail; end; /* format: off */ %page; %include aste; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include dir_header; %page; %include fs_obj_access_codes; %page; %include fs_types; %page; %include vtoce; %page; /* BEGIN MESSAGE DOCUMENTATION Message: correct_qused: hash error S: $crash T: $run M: Multiple entries within a directory undergoing quota correction have the same UID. END MESSAGE DOCUMENTATION */ end;  del_dir_tree.pl1 11/11/89 1132.4r w 11/11/89 0800.4 78552 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ del_dir_tree: proc (a_dirname, a_ename, a_code); /* Del_dir_tree is used to delete all branches, whether directory or not with respect to some node. If the sub tree with respect to that node has directories in it then the branches they contain must be deleted befor the directory can be. Care is taken to protect against another user appending a new branch while deletion is being done by always recycling over the whole directory when we return from a lower node. The basic operation of the program is to perform its own star_ list as it goes, calling delentry to delete each object. It keeps rescanning the dir (actually just looking at the first object which it then deletes) until the dir is empty. USAGE: call del_dir_tree(parent_path_name, entry_dir_name, error_code); 1. parent_path_name char(*) path name of the directory whose sub tree structure is to be deleted. 2. entry_dir_name char(*) entry name of the directory whose sub tree structure is to be deleted. 3. error_code fixed bin(35) file system error code (Output). NOTES: 1. User must have status (to perform the star_ list we simulate here) and modify (for later deltion) modes on directory structure. 2. The directory entry_dir_name is not deleted. */ /* Modified 2/85 by Keith Loepere to look for new error codes. */ /* Modified 12/84 by Keith Loepere for relocking strategy. */ /* Modified 6/84 by Keith Loepere to use the new dc_find. */ /* Modified 1/80 by Mike Grady to fix bad error handling code in main loop */ /* Modified 4/77 by M. Weaver to call makeknown_ instead of makeknown */ /* Modified 11/76 by D.Vinograd to add entry retv for use by volume reloader */ /* Modified June 1, 1976 by R. Bratt to call find_$finished when done with ep */ /* Modified 760309 by L. Scheffler to use info-only entries in dire_control_error */ /* Modified July 74 by Kobziar to call new entry in access_mode */ /* Modified by E Stone to delete directories in the subtree without SM access 5/74 */ /* Parameters */ dcl a_code fixed bin (35) parameter; dcl a_dirname char (*) parameter; dcl a_ename char (*) parameter; dcl a_retv bit (1) parameter; /* External */ dcl error_table_$argerr fixed bin (35) ext; dcl error_table_$copy_sw_on fixed bin (35) ext; dcl error_table_$fulldir fixed bin (35) ext; dcl error_table_$incorrect_access fixed bin (35) ext; dcl error_table_$moderr fixed bin (35) ext; dcl error_table_$mylock fixed bin (35) ext; dcl error_table_$root fixed bin (35) ext; dcl error_table_$safety_sw_on fixed bin (35) ext; dcl error_table_$vtoce_connection_fail ext fixed bin (35); dcl pds$process_group_id char (32) aligned ext; /* Entries */ dcl asd_$add_dentries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl delentry$dfile entry (char (*), char (*), fixed bin (35)); dcl delentry$retv entry (char (*), char (*), fixed bin (35)); dcl lock$dir_unlock external entry (pointer); dcl set$copysw entry (char (*), char (*), fixed bin (1), fixed bin (35)); dcl set$safety_sw_path entry (char (*), char (*), bit (1) aligned, fixed bin (35)); dcl sum$getbranch_root_my entry (ptr, bit (36) aligned, ptr, fixed bin (35)); /* Misc */ dcl (addr, length, ptr, rel, rtrim) builtin; dcl bad_dir_ condition; dcl seg_fault_error condition; /* Variables */ dcl code fixed bin (35); dcl 1 dir_acl aligned, 2 access_name char (32), 2 mode bit (36), 2 status_code fixed bin (35); dcl dirl bit (1) aligned; dcl dirname char (168); dcl ename char (32); dcl entries_in_dir fixed bin; dcl entries_seen fixed bin; dcl name char (32); dcl nnp ptr; dcl pname char (168); dcl rep bit (18) aligned; dcl retv bit (1) init ("0"b); %page; goto join; retv: entry (a_dirname, a_ename, a_code); retv = "1"b; goto join; recurse: entry (a_dirname, a_ename, a_retv, a_code); retv = a_retv; join: dirl = "0"b; code = 0; /* clear status code */ dirname = a_dirname; /* copy arguments */ ename = a_ename; if dirname = ">" then pname = ">" || ename; else if ename = "" then pname = dirname; else if length (rtrim (dirname)) + 1 + length (rtrim (ename)) > length (pname) then do; code = error_table_$argerr; go to finale; end; else pname = rtrim (dirname) || ">" || ename; if retv then call dc_find$dir_read_priv (pname, dp, code); else call dc_find$dir_read (pname, dp, code); /* get a pointer to dir, check for s (those requiring m check it itself) */ if code ^= 0 then go to finale; dirl = "1"b; if ^retv then do; /* safety switch of directory must be off */ call sum$getbranch_root_my (dp, "0"b, ep, code); if code = 0 then do; if entry.safety_sw then code = error_table_$safety_sw_on; call lock$dir_unlock (ptr (ep, 0)); end; else if code = error_table_$mylock then if entry.safety_sw then code = error_table_$safety_sw_on; else code = 0; else if code = error_table_$root then code = 0; if code ^= 0 then go to finale; end; on seg_fault_error begin; code = error_table_$vtoce_connection_fail; goto finale; end; rescan_dir: entries_in_dir = dp -> dir.seg_count + dp -> dir.dir_count + dp -> dir.lcount; entries_seen = 0; do rep = dp -> dir.entryfrp repeat entry.efrp while (rep); ep = ptr (dp, rep); /* pick up pointer to entry */ entries_seen = entries_seen + 1; if entries_seen > entries_in_dir then signal bad_dir_; if entry.uid = ""b then go to end_loop; if entry.bs then if (entry.owner ^= dp -> dir.uid) | (entry.type ^= SEG_TYPE & entry.type ^= DIR_TYPE) then signal bad_dir_; else ; else if (link.owner ^= dp -> dir.uid) | (link.type ^= LINK_TYPE) then signal bad_dir_; nnp = ptr (ep, entry.name_frp); if nnp -> names.type ^= NAME_TYPE | nnp -> names.owner ^= entry.uid | nnp -> names.entry_rp ^= rel (ep) then signal bad_dir_; name = nnp -> names.name; /* get primary name of entry */ if name = "" then signal bad_dir_; call dc_find$finished (dp, dirl); /* unlock directory (delentry requires it) */ dirl = "0"b; delent: if retv then call delentry$retv (pname, name, code); else call delentry$dfile (pname, name, code);/* try to delete this entry */ if code = 0 then do; if retv then call dc_find$dir_read_priv (pname, dp, code); else call dc_find$dir_read (pname, dp, code); /* get a pointer to dir, check for s (those requiring m check it itself) */ if code ^= 0 then go to finale; dirl = "1"b; go to rescan_dir; end; if code = error_table_$safety_sw_on & ^retv then do; /* turn safety switch off */ call set$safety_sw_path (pname, name, "0"b, code); if code = 0 then go to delent; else go to finale; /* we can't continue */ end; else if code = error_table_$copy_sw_on & ^retv then do; /* turn copy switch off */ call set$copysw (pname, name, 0, code); if code = 0 then go to delent; else go to finale; end; else if code = error_table_$fulldir then do; /* directory has entries */ again: call recurse (pname, name, retv, code); /* delete all entries in this dir */ if code = 0 then goto delent; else if code = error_table_$incorrect_access | code = error_table_$moderr then do; /* try to give user proper access to delete sub-tree */ dir_acl.access_name = pds$process_group_id; dir_acl.mode = "111"b; call asd_$add_dentries (pname, name, addr (dir_acl), 1, code); if code = 0 then goto again; else goto finale; end; else go to finale; end; else go to finale; end_loop: end; finale: if dirl then call dc_find$finished (dp, DC_FIND_UNLOCK_DIR); a_code = code; return; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include dir_header; %page; %include dir_link; %page; %include dir_name; %page; %include fs_types; end del_dir_tree;  delentry.pl1 11/11/89 1132.4r w 11/11/89 0800.0 188163 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ delentry: proc; /* modified by Kobziar on 11-15-73 not to require "w" on seg in order to delete */ /* last modified April 1975 by R. Bratt for new RNT/KST system */ /* last modified Feb. 1976 by R. Bratt for pam flush */ /* last modified April 20, 1976 by R. Bratt to check mountedness of volume */ /* modified 760324 by L. Scheffler to fix call to dir_control_error to call with dp, not ep */ /* last modified April 24, 1976 by R. Bratt to swallow known_in_other_rings code from makeunknown */ /* last modified June 1, 1976 by R. Bratt to call find_$finished when done */ /* Modified by D.Vinograd 6/76 to add entry retv, used by volume retriever, which deletes without access checking */ /* Modified 4/77 by M. Weaver to replace makeknown by makeknown_ */ /* Modified April 1979 by D. Spector to remove logging of privileged deletions */ /* Modified June 1981 by J. Bongiovanni to call pathname_am$clear when deleting per-process directory */ /* Modified June 30 1981 by M. Pierret to remove access checking for priviledged entry.*/ /* Modified 2/82 BIM for new name of side-door dir unlocker. */ /* Modified 9/83 E. N. Kittlitz to handle makeknown_ returning connection_fail */ /* Modified 6/84 Keith Loepere to use the new dc_find. */ /* Modified 10/84 Keith Loepere for auditing of deletions. */ /* Modified 84-11-27 to change access_audit_ arg lists */ /* Modified 85-04-01 Keith Loepere for new access_audit_check_ep_. */ /* Modified 85-05-08 EJ Sharpe: renamed priv_duid to duid_mdir_priv, added duid_mdir entry */ /* Modified 85-05-15 EJ Sharpe: fix so hpdl can delete master dirs */ /* The delentry routine implements the user callable primitives for deleting an entry in a directory. Entry: delentry$dfile This entry deletes the entry designamed by the directory pathname, dirname, and the entry name, ename. Usage: call delentry$dfile (dirname, ename, code); 1) dirname (character (168)) parent directory pathname (Input) 2) ename (character(32) entryname to be deleted (Input) 3) code (fixed bin) return error code (Output) Entry: delentry$dseg This entry deletes the entry designated by the pointer sp. Usage: call delentry$dseg (sp, code); 1) sp (pointer) pointer to segment to be deleted (Input) 2) code (fixed bin) error code (Output) Note: If the entry is a segment, then the contents of the segment are deleted before the entry is deleted. If it is a directory entry then an error code is returned and del_dir_tree must be called. */ /* Parameters */ dcl a_code fixed bin (35) parameter; dcl a_dirname char (*) parameter; dcl a_ename char (*) parameter; dcl a_ep ptr parameter; dcl a_sp ptr parameter; dcl a_trp fixed bin (71) parameter; /* to return time-record product */ dcl a_uidpath (0:15) bit (36) aligned parameter; /* Variables */ dcl acl_count fixed bin; dcl aclep ptr; dcl areap ptr; dcl asize fixed bin; dcl audit_eventflags bit (36) aligned; dcl code fixed bin (35); dcl damaged bit (1) init ("0"b);/* TRUE if dir uid is 0 */ dcl dirl bit (1) init ("0"b); dcl dirname char (168); dcl e_sw fixed bin; dcl ename char (32); dcl ignore fixed bin (35); dcl 1 mk_info aligned like makeknown_info; dcl mkunk_uid bit (36) aligned init ("0"b); dcl ncnt fixed bin; dcl nnames fixed bin (18); dcl nrp bit (18) aligned; dcl onp ptr; dcl priv_entry bit (1) init ("0"b); dcl pvid bit (36) aligned; dcl 1 qcell like quota_cell aligned automatic; dcl ring fixed bin; dcl seg_uid bit (36) aligned; dcl segl bit (1) init ("0"b); dcl segno fixed bin; dcl segptr ptr init (null); dcl sp ptr; dcl trp fixed bin (71); dcl type fixed bin; dcl uidpath (0:15) bit (36) aligned; dcl vtocx fixed bin; /* Constants */ dcl directory init (2) fixed bin static; dcl link_br init (0) fixed bin static; dcl file init (0) fixed bin static; dcl read_lock bit (36) aligned init ("0"b); dcl retv init (3) fixed bin static; dcl seg init (1) fixed bin static; dcl segment init (1) fixed bin static; dcl uid_mdir init (2) fixed bin static; /* External */ dcl active_hardcore_data$ensize fixed bin external; dcl active_hardcore_data$esize fixed bin external; dcl error_table_$copy_sw_on fixed bin (35) external; dcl error_table_$dirseg fixed bin (35) external; dcl error_table_$fulldir fixed bin (35) external; dcl error_table_$infcnt_non_zero fixed bin (35) external; dcl error_table_$invalidsegno fixed bin (35) external; dcl error_table_$known_in_other_rings fixed bin (35) external; dcl error_table_$lower_ring fixed bin (35) external; dcl error_table_$master_dir fixed bin (35) external; dcl error_table_$safety_sw_on fixed bin (35) external; dcl error_table_$seg_unknown fixed bin (35) external; dcl error_table_$segknown fixed bin (35) external; dcl error_table_$vtoce_connection_fail fixed bin (35) external; ; dcl pds$access_authorization bit (72) aligned external; dcl pds$process_group_id char (24) ext; dcl pds$processid bit (36) aligned ext; /* Entries */ dcl acc_name_$delete entry (ptr); dcl access_audit_check_ep_$self entry (bit (36) aligned, bit (36) aligned, ptr) returns (bit (1)); dcl access_audit_$log_entry_ptr entry (char (*), fixed bin, bit (36) aligned, bit (36) aligned, ptr, fixed bin (35), ptr, fixed bin (18), char (*)); dcl acl_$del_acl entry (fixed bin, bit (36) aligned, ptr); dcl aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl delete_vtoce entry (ptr, fixed bin (35)); dcl fs_alloc$free entry (ptr, fixed bin, ptr); dcl hash$out entry (ptr, ptr, ptr, fixed bin (35)); dcl level$get entry returns (fixed bin); dcl lock$dir_lock_write entry (ptr, fixed bin (35)); dcl lock$dir_unlock entry (ptr); dcl lock$dir_unlock_given_uid entry (bit (36) aligned); dcl makeknown_ entry (ptr, fixed bin, fixed bin, fixed bin (35)); dcl makeunknown_ entry (fixed bin, bit (36) aligned, bit (1) aligned, fixed bin (35)); dcl mountedp entry (bit (36) aligned) returns (fixed bin (35)); dcl pathname_am$clear entry (fixed bin (17)); dcl pathname_am$flush entry (bit (36) aligned); dcl sum$dirmod entry (ptr); dcl syserr entry options (variable); dcl syserr$error_code entry options (variable); dcl terminate_$id entry (bit (36) aligned, fixed bin, fixed bin (35)); dcl vtoc_attributes$get_quota entry (bit (36) aligned, bit (36) aligned, fixed bin, ptr, fixed bin, fixed bin (35)); /* Misc */ dcl (addr, fixed, ptr, rel, null, baseptr, unspec) builtin; dcl bad_dir_ condition; dcl seg_fault_error condition; %page; salv_delete_branch: entry (a_ep, a_code); /* Make branch go awayy */ ep = a_ep; dp = ptr (ep, 0); dirl = "0"b; /* Don't unlock dir */ code = 0; damaged = "1"b; /* Couldnt get inferior dir */ segptr = null; /* didn't touch inferior */ segl = "0"b; /* or lock it */ if ^entry.bs then type = link_br; else if entry.dirsw then type = directory; else type = segment; go to remove; /* Remove the branch */ retv: entry (a_dirname, a_ename, a_code); e_sw = retv; goto set_code; priv_dfile: entry (a_dirname, a_ename, a_code); priv_entry = "1"b; dfile: entry (a_dirname, a_ename, a_code); e_sw = file; /* indicate through which entry point entered */ set_code: code = 0; /* clear return status code */ dirname = a_dirname; /* copy arguments */ ename = a_ename; if e_sw ^= retv & ^priv_entry then call dc_find$obj_delete (dirname, ename, DC_FIND_NO_CHASE, ep, code); else call dc_find$obj_delete_priv (dirname, ename, DC_FIND_NO_CHASE, ep, code); /* get ptr to entry + lock dir for writing */ if code ^= 0 then go to ret; go to common; dseg: entry (a_sp, a_code); code = 0; /* clear return status code */ e_sw = seg; /* indicate through entry point we entered */ sp = a_sp; /* copy arg */ call dc_find$obj_delete_ptr (sp, ep, code); /* get ptr to entry + lock for write */ if code ^= 0 then go to ret; go to common; duid_mdir_priv: entry (a_uidpath, a_trp, a_code); /* entry to delete given uidpathname */ e_sw = uid_mdir; /* name type entry */ uidpath = a_uidpath; /* copy path */ call dc_find$obj_delete_priv_uid (uidpath, dirname, ename, ep, code); /* find the thing */ if code ^= 0 then go to ret; priv_entry = "1"b; trp = 0; goto common; duid_mdir: entry (a_uidpath, a_trp, a_code); /* entry to delete given uidpathname */ e_sw = uid_mdir; /* name type entry */ uidpath = a_uidpath; /* copy path */ call dc_find$obj_delete_uid (uidpath, dirname, ename, ep, code); /* find the thing */ if code ^= 0 then go to ret; trp = 0; common: dp = ptr (ep, 0); dirl = "1"b; if ^ep -> entry.bs then do; /* link case */ type = link_br; /* set type of entry */ go to remove; end; else if ^ep -> entry.dirsw then type = segment; /* non-directory branch */ else type = directory; /* directory branch */ if e_sw ^= retv & ^priv_entry then do; ring = level$get (); /* get validation level */ if (type = segment & ring > fixed (ep -> entry.ring_brackets (1), 3)) | (type ^= segment & ring > fixed (ep -> entry.ex_ring_brackets (1), 3)) then do; code = error_table_$lower_ring; /* ringbrackets must be consistent with validation level */ go to finale; end; if entry.copysw then do; /* branch cannot be deleted if copy on */ code = error_table_$copy_sw_on; go to finale; end; if entry.safety_sw then do; /* branch may not be deleted if safety switch on */ code = error_table_$safety_sw_on; go to finale; end; end; /* If ename is a directory branch, be sure there are */ if type = directory then do; /* no entries in that directory before deleting it */ if e_sw = seg then do; /* Forbid use of ptr entry */ code = error_table_$dirseg; go to finale; end; seg_uid = entry.uid; /* Make sure nobody deletes it */ segptr = null; on seg_fault_error begin; damaged = "1"b; goto dir_glop; end; unspec (mk_info) = "0"b; mk_info.uid = seg_uid; mk_info.entryp = ep; mk_info.dirsw = "1"b; mk_info.allow_write = "1"b; mk_info.activate = "1"b; call makeknown_ (addr (mk_info), segno, (0), code); if code = 0 | code = error_table_$segknown then segptr = baseptr (segno); else if code = error_table_$vtoce_connection_fail then damaged = "1"b; else goto finale; call dc_find$finished (dp, "1"b); /* unlock and unreference (initiated dir will hold parent) - allows seg_fault to work */ dirl = "0"b; if damaged then goto dir_glop; /* skip segfault on next statement */ if segptr -> dir.uid = "0"b then do; /* If the directory's UID is 0 we cant lock it */ call syserr (4, "delentry: deleting damaged dir ^a>^a for ^a", dirname, ename, pds$process_group_id); damaged = "1"b; /* .. but then, nobody else can either */ end; else do; call lock$dir_lock_write (segptr, code);/* Lock the dir to be deleted */ if code ^= 0 then go to finale; segl = "1"b; end; dir_glop: revert seg_fault_error; if e_sw = seg then call dc_find$obj_delete_ptr (sp, ep, code); /* refind dir */ else if e_sw = retv | priv_entry then call dc_find$obj_delete_priv (dirname, ename, DC_FIND_NO_CHASE, ep, code); else call dc_find$obj_delete (dirname, ename, DC_FIND_NO_CHASE, ep, code); if code ^= 0 then do; if segptr ^= null then do; call lock$dir_unlock (segptr); /* Gack. How does this happen */ call makeunknown_ (segno, "0"b, ("0"b), ignore); /* .. ayway cleanup */ end; go to ret; end; dp = ptr (ep, 0); /* Regenerate dp just in case */ dirl = "1"b; if seg_uid ^= entry.uid then do; /* Check that our access check above .. */ code = error_table_$invalidsegno; /* .. hasn't been interfered with */ go to finale; /* nasty */ end; if ^damaged then do; /* Various validity checks. skip for bad dir */ if segptr -> dir.master_dir then if e_sw ^= uid_mdir & ^priv_entry then do; code = error_table_$master_dir; /* Do not delete master directory */ go to finale; end; if segptr -> dir.seg_count ^= 0 /* check if directory has any branches */ | segptr -> dir.dir_count ^= 0 | segptr -> dir.lcount ^= 0 then do; code = error_table_$fulldir; if /* tree */ ^aim_check_$equal (pds$access_authorization, segptr -> dir.access_class) then /* audit possible covert channel */ if ^addr (pds$access_authorization) -> aim_template.privileges.dir then do; audit_eventflags = "0"b; addr (audit_eventflags) -> audit_event_flags.cc_10_100 = "1"b; if access_audit_check_ep_$self (audit_eventflags, access_operations_$fs_obj_delete, ep) then call access_audit_$log_entry_ptr ("delentry", level$get (), audit_eventflags, access_operations_$fs_obj_delete, ep, code, null, 0, ""); end; go to finale; end; if e_sw = uid_mdir then do; /* caller wants a time record product */ pvid = entry.pvid; vtocx = entry.vtocx; qcp = addr (qcell); call vtoc_attributes$get_quota (seg_uid, pvid, vtocx, qcp, 0, code); if code = 0 then trp = quota_cell.trp; /* save it if i got it */ end; end; end; /* Everything AOK. Remove segment and branch and go to finale. */ if type ^= link_br then do; if priv_entry | type = directory then code = 0; /* only check if unpriv or segment */ else code = mountedp (dir.sons_lvid); if code = 0 then do; call delete_vtoce (ep, code); if code ^= 0 then call syserr$error_code (LOG, code, "delentry: failed to delete_vtoce for ^w ^o.", ep -> entry.pvid, ep -> entry.vtocx); end; if code ^= 0 then /* error from delete_vtoce prob volume not up */ if ^priv_entry | code = error_table_$infcnt_non_zero then /* unprivileged attempt or dir contains known inferior segments */ go to finale; /* leave branch intact and return error code */ /* else call syserr$error_code (4, code, "delentry: priv_dfile error deleting vtoce for ^a>^a for ^a", dirname, ename, pds$process_group_id); -- Priv deletions used to be logged */ end; remove: dir.modify = pds$processid; /* mark dir unstable */ nrp = entry.name_brp; /* get rp to last name */ areap = ptr (dp, dir.arearp); /* get ptr to area */ nnames = fixed (entry.nnames, 18); /* pick up count of names */ ncnt = 0; name_loop: ncnt = ncnt + 1; /* keep track of number of names deleted */ if ncnt > nnames then signal bad_dir_; /* too many times through the loop */ np = ptr (dp, nrp); /* get ptr to name entry to be removed */ if np -> names.type ^= NAME_TYPE | np -> names.owner ^= entry.uid | np -> names.entry_rp ^= rel (ep) then signal bad_dir_; call hash$out (dp, addr (np -> names.name), onp, code); /* remove name from hash table */ if code ^= 0 then call syserr$error_code (4, code, "delentry: error from hash$out on ""^a"" for ^a", np -> names.name, pds$process_group_id); if np ^= onp then signal bad_dir_; /* check that hash table entry and name entry are consistent */ nrp = np -> names.bp; /* get rp to previous name on list */ if nrp then do; /* if not primary name stored in the entry */ entry.name_brp = nrp; /* thread name list to entry */ call fs_alloc$free (areap, active_hardcore_data$ensize, np); /* free name entry */ go to name_loop; /* continue removing names */ end; entry.name_frp, entry.name_brp = "0"b; /* clear name threads */ entry.nnames = 0; /* zero name count */ if type ^= link_br then do; /* in the branch case free the storage of the acl */ aclep = addr (entry.acl_frp); /* get pointer to start of acl */ acl_count = fixed (entry.acle_count, 18); /* get count of acls assoc with this entry */ call acl_$del_acl (acl_count, entry.uid, aclep); /* remove entire acl */ dir.acle_total = /* decrease count of acl entries in dir header */ dir.acle_total - acl_count; entry.acl_frp, entry.acl_brp = "0"b; /* zero out acl threads */ entry.acle_count = 0; /* zero out acl count in entry */ asize = active_hardcore_data$esize; /* size of area to be freed is entry size */ /* delete bc author and update pers and proj name lists */ call acc_name_$delete (addr (entry.bc_author)); mkunk_uid = entry.uid; /* get it unknown later */ segptr = null; end; else do; /* in link case set pathname size to zero */ ep -> link.pathname_size = 0; asize = ep -> link.size; /* pick up number of words in link entry (for freeing) */ end; call acc_name_$delete (addr (entry.author)); /* delete author and update pers and proj name lists */ if entry.ebrp then ptr (ep, entry.ebrp) -> entry.efrp = entry.efrp; /* unthread the entry */ if entry.efrp then ptr (ep, entry.efrp) -> entry.ebrp = entry.ebrp; if rel (ep) = dir.entrybrp then dir.entrybrp = entry.ebrp; if rel (ep) = dir.entryfrp then dir.entryfrp = entry.efrp; entry.ebrp, entry.efrp = "0"b; if type = link_br then dir.lcount = dir.lcount - 1; /* fix seg, dir, or link_br count in dir */ else if type = segment then dir.seg_count = dir.seg_count - 1; else dir.dir_count = dir.dir_count - 1; entry.uid = "0"b; /* clear uid */ entry.pvid = "0"b; call fs_alloc$free (areap, asize, ep); /* free the entry */ if type = directory & ^damaged then do; if ^entry.per_process_sw then call pathname_am$flush (mkunk_uid); else call pathname_am$clear (segno); call lock$dir_unlock_given_uid (seg_uid); segl = "0"b; end; if dirl then dir.modify = "0"b; /* If we locked dir, mark as ok now. */ call sum$dirmod (dp); finale: if segl then call lock$dir_unlock_given_uid (seg_uid); /* may not be all there */ if dirl then do; dir.modify = "0"b; if e_sw ^= seg then call dc_find$finished (dp, "1"b); else call lock$dir_unlock (dp); /* dont touch lot unless we locked dir */ if segptr ^= null then call makeunknown_ (segno, "0"b, ("0"b), ignore); /* implies dir */ else if mkunk_uid ^= "0"b then do; call terminate_$id (mkunk_uid, 0, code); if code ^= 0 then if code = error_table_$seg_unknown | code = error_table_$invalidsegno | code = error_table_$known_in_other_rings then code = 0; else call syserr$error_code (4, code, "delentry: error from terminate_ for ^a", pds$process_group_id); end; end; if e_sw = uid_mdir then a_trp = trp; ret: a_code = code; return; /* format: off */ %page; %include access_audit_eventflags; %page; %include aim_template; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include dir_header; %page; %include dir_link; %page; %include dir_name; %page; %include fs_obj_access_codes; %page; %include fs_types; %page; %include makeknown_info; %page; %include quota_cell; %page; %include syserr_constants; %page; /* format: on */ /* BEGIN MESSAGE DOCUMENTATION Message: delentry: deleting damaged dir PATH for USERID S: $log T: $run M: An attempt to delete a directory found that the directory header had a zero UID. The directory was deleted anyway. A: $ignore Message: delentry: priv_dfile error deleting vtoce for PATH for USERID. ERROR_CODE S: $log T: $run M: A privileged call to delete a segment discovered a branch with not VTOC entry. This situation is called a "connection failure." The branch was deleted anyway. A: $ignore Message: delentry: error from hash$out on "NAME" for USERID. ERROR_CODE S: $log T: $run M: An attempt to delete the entry name NAME from the directory hash table failed. $err A: $ignore Message: delentry: error from terminate_ for USERID. ERROR_CODE S: $log T: $run M: An error code was returned while trying to make a directory unknown while deleting it. $err A: $ignore END MESSAGE DOCUMENTATION */ end delentry;  demand_deactivate.pl1 11/11/89 1132.4r w 11/11/89 0800.4 33534 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ demand_deactivate: proc (a_segptr, a_code); /* Written March 30, 1976 by R. Bratt This module allows priveleged users to deactivate a segment if certain conditions obtain. These conditions are: * the segment must be known in the calling process * the segment must be active * all users who have connected to the aste must have specified explicit_deact_ok, * or this is force entry * the aste must be deactivateable Modified for external static SST, 04/19/81, W. Olin Sibert Modified for $force entrypoint, 04/21/81, WOS Modified for $force_given_segno entrypoint, 02/28/82, J. Bongiovanni Modified to lock ast on search, 05/30/83, E. N. Kittlitz Modified to respect threaded-out-ness, 84-01-08 BIM. */ dcl a_segptr ptr parameter; dcl a_seg_uid bit (36) aligned parameter; dcl a_code fixed bin (35) parameter; dcl segno fixed bin (17); dcl code fixed bin (35); dcl uid bit (36) aligned; dcl force_sw bit (1) aligned; dcl sst$demand_deact_attempts fixed bin (35) external static; dcl sst$demand_deactivations fixed bin (35) external static; dcl deactivate entry (ptr, fixed bin (35)); dcl get_kstep entry (fixed bin, pointer, fixed bin (35)); dcl lock$lock_ast entry (); dcl lock$unlock_ast entry (); dcl search_ast entry (bit (36) aligned) returns (pointer); dcl error_table_$illegal_deactivation fixed bin(35) ext static; dcl (baseno, binary, null) builtin; %page; force_sw = "0"b; /* Don't, unless we're allowed to */ goto FIND_UID; demand_deactivate$force_given_segno: entry (a_segptr, a_code); force_sw = "1"b; FIND_UID: segno = binary (baseno (a_segptr), 18); /* Find the UID for the segment */ call get_kstep (segno, kstep, code); if code ^= 0 then do; /* Bad segno, or something */ a_code = code; return; end; uid = kste.uid; goto COMMON; demand_deactivate$force: entry (a_seg_uid, a_code); /* Deactivate by UID, rather than segno, and force */ uid = a_seg_uid; force_sw = "1"b; /* Deactivate, if at all possible */ COMMON: code = 0; /* Assume success */ sst$demand_deact_attempts = sst$demand_deact_attempts + 1; call lock$lock_ast (); /* we don't go to the expense of deriving pvid, vtocx. If we have a double-uid, we'll either find the right segment active, or we'll harrass the other segment with the same uid. In either case, the segment we want will end up inactive, if possible. */ astep = search_ast (uid); if astep ^= null () then if force_sw | aste.explicit_deact_ok then do;/* We're allowed to try it */ if (astep -> aste.fp | astep -> aste.bp) = ""b then do; code = error_table_$illegal_deactivation; go to RETURN; end; call deactivate (astep, code); /* See what happens */ if code = 0 then sst$demand_deactivations = sst$demand_deactivations + 1; end; /* Record successes */ RETURN: call lock$unlock_ast (); a_code = code; return; /*format: off */ %page; %include aste; %page; %include kst; end demand_deactivate;  fs_get.pl1 08/21/90 1511.9rew 08/21/90 1449.2 125451 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-08,GDixon), approve(86-08-08,MCR7388), audit(86-09-02,Farley), install(86-09-08,MR12.0-1150): Remove the include of kst.incl.pl1, since reference to variables in the program was removed in an early release. 2) change(86-08-20,Lippard), approve(86-09-08,MCR7539), audit(86-10-15,Farley), install(86-10-20,MR12.0-1189): Modified by Jim Lippard to fix ref names allocation bug, fix supplied by Steve Harris (UNCA). 3) change(90-07-26,WAAnderson), approve(90-07-26,MCR8182), audit(90-08-10,Schroth), install(90-08-21,MR12.4-1030): Replaced call to ref_name_$get_refnames with call to ref_name_$get_refname. This change reduces stack space requirements and corrects the list_ref_names infinite loop bug. END HISTORY COMMENTS */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ fs_get: proc; /* Modified 03/05/85 by Melanie Weaver to remove entry label $call_name */ /* Modified 02/25/85 by Keith Loepere to use dc_find for name lookup check for path_name. */ /* Modified 10/16/84 by Keith Loepere to use dc_find for access computations. */ /* Modified 7/17/84 by Keith Loepere to use the new dc_find. */ /* Modified 5/17/83 by E. N. Kittlitz to decrement ref on get_link_target. /* Modified 1/3/83 by Jay Pattin to add access_modes entry */ /* Modified 01/15/79 by C. D. Tavares to compute access correctly w.r.t. dir extended ring brackets */ /* Modified March 1977 by M. Weaver to get rntp from stack */ /* Modified March 1976 by R. Bratt for initiated_mode and to fix get_search_rules bug */ /* Modified April 1975 by E. Stone to put access info in kst */ /* Modified April 1975 by R. Bratt for new kst */ /* Modified Feb 1975 by R. Bratt to use get_pathname_ */ /* Modified by Kobziar July 74 to call appropriate entry point in access_mode */ /* -- -> fs_get$brackets returns the mode and ring brackets of the current user for the segment specified by segptr. USAGE: call fs_get$brackets (segptr, mode, rings, code); 1) segptr ptr - - - pointer to segment 2) mode fixed bin(5) - - - mode of user (output) 3) rings (3) fixed bin(6) - - - ring brackets of user (output) 4) code fixed bin - - - error code (output) -- -> fs_get$ex_mode_name returns the mode, brackets, extended access, and primary name of a segment for the current user. USAGE: call fs_get$ex_mode_name(segptr,mode,rings,ex_mode,name,code); 4) ex_mode is the extended access mode. 5) name is the primary name of the segment. All other arguments same as fs_get$brackets. -- -> fs_get$mode returns the mode of the current user at the current validation level for the segment specified by segptr. USAGE: call fs_get$mode (segptr, mode, code); The arguments are the same as for fs_get$brackets. -- -> fs_get$access_modes returns both mode and extended modes. USAGE: call fs_get$access_modes (segptr, mode, exmodes, code); -- -> fs_get$segptr returns a pointer to a segment given its reference name. USAGE: call fs_get$segptr (refname, segptr, code); 1) refname char(*) - - - refernce name of segment 2) segptr ptr - - - pointer to segment (output) 3) code fixed bin - - - error code (output) -- -> fs_get$search_rules returns in a space provided by the user a list of of the search rules currently in use by the user for his validation level. USAGE:call fs_get$search_rules (search_rules_ptr); 1) search_rules_ptr ptr - - - is a pointer to the space where the list of names will be stored. The names are stored in a structure of the form: dcl 1 ret_struc aligned, 2 num fixed bin, number of rules 2 names(21) char(168) aligned; -- -> fs_get$path_name returns the pathname of the directory immediately superior to, and the entry name of the segment specified by segptr. USAGE: call fs_get$path_name (segptr, dirname, lnd, ename, code); 1) segptr ptr - - - pointer to the segment 2) dirname char(168) - - - pathname of superior directory (output) 3) lnd fixed bin - - - number of significant chars in pathname (output) 4) ename char(32) - - - entry name of segment (output) 5) code fixed bin - - - error code (output) -- -> fs_get$dir_name returns the pathname of the directory immediatetly superior to the segment specified by segptr. USAGE: call fs_get$dir_name (segptr, dirname, lnd, code); The arguments are the same as fs_get$path_name. -- -> fs_get$ref_name returns the reference name corresponding to namecnt for the segment specified by segptr. USAGE: call fs_get$ref_name (segptr, namecnt, refname, code); 1) segptr ptr - - - pointer to the segment 2) namecnt fixed bin(17) - - - number of the reference name desired 3) refname char(*) - - - reference name (output) 4) code fixed bin - - - error code (output) -- -> fs_get$trans_sw returns the current value of the transparent usage/modification switch and sets it to a new value. USAGE: call fs_get$trans_sw (newsw, oldsw) 1) newsw fixed bin - - - new value for switch, if > 3, don't set switch 2) oldsw fixed bin - - - old value of switch (output) */ /* Parameters */ dcl a_code fixed bin (35) parameter; dcl a_dirname char (*) parameter; dcl a_ename char (*) parameter; dcl a_ex_mode bit (*) parameter; /* extended access bits EX ACC */ dcl a_ex_modes bit (36) aligned parameter; dcl a_ldir char (*) parameter; dcl a_lentry char (*) parameter; dcl a_lnd fixed bin (17) parameter; dcl a_mode fixed bin (5) parameter; dcl a_name char (*) parameter; /* name of segment EX ACC */ dcl a_namecnt fixed bin (17) parameter; dcl a_new_mode bit (36) aligned parameter; dcl a_newsw fixed bin (17) parameter; dcl a_oldsw fixed bin (17) parameter; dcl a_ptr ptr parameter; dcl a_refname char (*) parameter; dcl a_rings (3) fixed bin (3) parameter; dcl a_rname char (*) parameter; dcl a_segptr ptr parameter; /* Constants */ dcl access_modes fixed bin static options (constant) init (5); dcl brackets fixed bin static options (constant) init (3); dcl ex_mode_name fixed bin static options (constant) init (4); dcl just_mode fixed bin static options (constant) init (0); /* Variables */ dcl aptr ptr; dcl code fixed bin (35); dcl dirsw bit (1) aligned; dcl dlen fixed bin (17); dcl end_rule fixed bin (17); dcl entry_point fixed bin; dcl extended_mode bit (36) aligned; dcl i fixed bin; dcl l fixed bin; dcl ldir char (168); dcl lentry char (32); dcl mode bit (36) aligned; dcl namecnt fixed bin (17); dcl newsw fixed bin (17); dcl oldsw fixed bin (17); dcl pathname char (201) varying; dcl rb (3) fixed bin (3); dcl return_ename bit (1) aligned; dcl ring fixed bin; dcl rname char (32) varying; dcl segnum fixed bin (17); dcl segptr ptr; dcl srpp ptr; /* Based */ dcl 1 ret_struc based aligned, 2 num fixed bin, 2 names (21) char (168); dcl 1 sr (22) based aligned, 2 segno fixed bin (17) unaligned, 2 offset fixed bin (17) unaligned, 2 uid bit (36); /* External */ dcl error_table_$dirseg fixed bin (35) external; dcl error_table_$noentry fixed bin (35) external; dcl error_table_$root fixed bin (35) external; dcl pds$stacks (0:7) ptr external; dcl pds$transparent bit (2) external aligned; /* Entries */ dcl get_pathname_ entry (fixed bin (17), char (*) varying, fixed bin (35)); dcl level$get entry returns (fixed bin); dcl ref_name_$get_refname entry (fixed bin (17), fixed bin (17), char (*) varying, fixed bin (35)); dcl ref_name_$get_segno entry (char (32) varying, fixed bin (17), fixed bin (35)); /* Misc */ dcl (baseno, baseptr, binary, fixed, hbound, index, lbound, length, max, null, reverse, segno, substr) builtin; %page; mode: entry (a_segptr, a_mode, a_code); entry_point = just_mode; /* Set entry switch */ go to join_mode; brackets: entry (a_segptr, a_mode, a_rings, a_code); entry_point = brackets; /* Set entry switch */ go to join_mode; access_modes: entry (a_segptr, a_new_mode, a_ex_modes, a_code); /* new_mode because has correct dcl */ entry_point = access_modes; /* Set entry switch */ go to join_mode; ex_mode_name: entry (a_segptr, a_mode, a_rings, a_ex_mode, a_name, a_code); /* extended acess entry EX ACC */ entry_point = ex_mode_name; /* set entry switch EX ACC */ join_mode: segptr = a_segptr; /* copy arg */ call dc_find$obj_modes_ptr (segptr, mode, extended_mode, rb, code); if code ^= 0 then if code = error_table_$dirseg then do; code = 0; dirsw = "1"b; end; else go to err0; else dirsw = "0"b; if (entry_point = brackets) | (entry_point = ex_mode_name) then do; a_rings = rb; if entry_point = ex_mode_name then do; a_ex_mode = extended_mode; a_name = ""; end; end; if entry_point = access_modes then do; if dirsw then code = error_table_$dirseg; else do; a_new_mode = mode; a_ex_modes = extended_mode; end; end; else do; if dirsw then mode = substr (mode, 1, 1) || "1"b || substr (mode, 2, 2); a_mode = fixed (substr (mode, 1, 4), 5); end; err0: a_code = code; return; %page; /* * * * * * * * * * * * * * * * * * * */ seg_ptr: entry (a_rname, a_segptr, a_code); call ref_name_$get_segno ((a_rname), segnum, code); if code = 0 then a_segptr = baseptr (segnum); else a_segptr = null (); a_code = code; return; /* * * * * * * * * * * * * * * * * * * * */ search_rules: entry (a_ptr); aptr = a_ptr; /* copy arg */ ring = level$get (); rntp = pds$stacks (ring) -> stack_header.rnt_ptr; srpp = rntp -> rnt.srulep; end_rule = binary (END_RULE); /* pull computation out of loop */ do i = lbound (srpp -> sr, 1) to hbound (srpp -> sr, 1) while (srpp -> sr (i).offset ^= end_rule); /* now get the search rule names */ if srpp -> sr (i).offset ^= 0 then aptr -> ret_struc.names (i) = search_rule_names (srpp -> sr (i).offset); else do; segnum = srpp -> sr (i).segno; segptr = baseptr (segnum); call dc_find$obj_existence_ptr (segptr, ep, code); if code ^= 0 then aptr -> ret_struc.names (i) = "invalid search rule pointer"; else do; call get_pathname_ (segnum, pathname, code); if code ^= 0 then aptr -> ret_struc.names (i) = "invalid search rule pointer"; else aptr -> ret_struc.names (i) = pathname; /* copy name */ call dc_find$finished (ep, DC_FIND_UNLOCK_DIR); end; end; end; aptr -> ret_struc.num = i - 1; return; /* * * * * * * * * * * * * * * * * * * * */ get_link_target: entry (a_ldir, a_lentry, a_dirname, a_ename, a_code); ldir = a_ldir; /* copy input arguments */ lentry = a_lentry; a_dirname = ""; /* set default values for return arguments */ a_ename = ""; call dc_find$link_target (ldir, lentry, code); if code = 0 | code = error_table_$noentry then do; a_dirname = ldir; a_ename = lentry; end; a_code = code; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ path_name: entry (a_segptr, a_dirname, a_lnd, a_ename, a_code); return_ename = "1"b; goto name_join; dir_name: entry (a_segptr, a_dirname, a_lnd, a_code); return_ename = "0"b; name_join: code = 0; segptr = a_segptr; call dc_find$obj_existence_ptr (segptr, ep, code); if code = 0 then do; call get_pathname_ (segno (segptr), pathname, code); call dc_find$finished (ep, DC_FIND_UNLOCK_DIR); end; else if code = error_table_$root then do; code = 0; pathname = ">"; end; else goto name_return; i = index (reverse (pathname), ">"); l = length (pathname); dlen = max (l - i, 1); if return_ename then if dlen = 1 then dlen = 0; a_dirname = substr (pathname, 1, dlen); a_lnd = dlen; if return_ename then a_ename = substr (pathname, l + 2 - i, i - 1); name_return: a_code = code; return; /* * * * * * * * * * * * * * * * * * */ ref_name: entry (a_segptr, a_namecnt, a_refname, a_code); namecnt = max(a_namecnt, 1); segnum = fixed (baseno (a_segptr), 17); call ref_name_$get_refname (segnum, namecnt, rname, code); if code = 0 then do; a_refname = rname; a_code = 0; end; else a_code = code; return; /* * * * * * * * * * * * * * * * * * */ trans_sw: entry (a_newsw, a_oldsw); newsw = a_newsw; oldsw = fixed (pds$transparent, 2); if newsw > 3 then go to fin2; /* newsw > 3 means only go to fin2 oldsw, don't change newsw */ if newsw < 0 then go to fin2; if newsw = 0 then pds$transparent = "0"b; else if newsw = 1 then pds$transparent = "01"b; else pds$transparent = "11"b; /* can't have modified transparent without used */ fin2: a_oldsw = oldsw; return; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include dir_name; %page; %include fs_types; %page; %include rnt; %page; %include sdw; %page; %include search_rule_flags; %page; %include stack_header; end fs_get;  fs_move.pl1 11/11/89 1132.4rew 11/11/89 0800.4 76005 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ fs_move: proc; /* Modified by E. Stone 8/73 to convert to version 2 and to check the max length of the TO segment */ /* Modified January 1983 by Keith Loepere so as to truncate target AFTER all validations */ /* Modified February 1983 by E. N. Kittlitz for 256K segments */ /* Modified November 1984 by Keith Loepere to rename terminate to terminate_ */ ffile: entry (a_dirname_from, a_ename_from, a_sw, a_dirname_to, a_ename_to, a_code); dcl a_dirname_from char (*); dcl a_dirname_to char (*); dcl a_ename_from char (*); dcl a_ename_to char (*); dcl a_sw fixed bin (2); dcl a_code fixed bin (35); dcl created_seg bit (1) aligned; dcl dirname_from char (168); dcl dirname_to char (168); dcl ename_from char (32); dcl ename_to char (32); dcl curlen fixed bin; dcl ldirname_from fixed bin; dcl ldirname_to fixed bin; dcl target_len bit (12); dcl entry_point fixed bin; dcl options bit (2) unaligned; dcl append_sw bit (1) unaligned def (options) pos (1); dcl truncate_sw bit (1) unaligned def (options) pos (2); dcl max_length fixed bin (19); dcl words fixed bin (19); dcl tcode fixed bin (35); dcl code fixed bin (35); dcl ptr_from ptr; dcl ptr_to ptr; dcl dptr ptr; dcl copy (words) bit (36) aligned based; dcl file fixed bin static init (0) options (constant); dcl seg fixed bin static init (1) options (constant); dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$segknown fixed bin (35) ext static; dcl error_table_$clnzero fixed bin (35) ext static; dcl error_table_$no_s_permission fixed bin (35) ext static; dcl error_table_$no_move fixed bin (35) external; dcl append$branch entry (char (*), char (*), fixed bin (5), fixed bin (35)); dcl fs_get$path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl status_$get_max_length_ptr entry (ptr, fixed bin (19), fixed bin (35)); dcl initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl status_$long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl terminate_$noname entry (ptr, fixed bin (35)); dcl truncate$trseg entry (ptr, fixed bin, fixed bin (35)); dcl quota$check_file entry (char (*), char (*), fixed bin, fixed bin (35)); dcl set$max_length_path entry (char (*), char (*), fixed bin (19), fixed bin (35)); dcl (addr, bit, fixed, null) builtin; dcl 1 lbranch aligned, /* structure to return long branch status */ (2 (type bit (2), nnames bit (16), nrp bit (18)), 2 dtm bit (36), 2 dtu bit (36), 2 (mode bit (5), pad1 bit (13), records bit (18)), 2 dtd bit (36), /* date time file and branch dumped */ 2 dtem bit (36), /* date time branch modified */ 2 acct bit (36), /* account number to which storage is charged */ 2 (curlen bit (12), bitcnt bit (24)), /* highest 1024-word block used, bit count */ 2 (did bit (4), mdid bit (4), copysw bit (1), pad3 bit (9), rbs (0:2) bit (6)), 2 uid bit (36)) unaligned; %page; entry_point = file; /* indicate that entry was via pathname entry point */ dirname_from = a_dirname_from; /* copy arguments */ ename_from = a_ename_from; dirname_to = a_dirname_to; ename_to = a_ename_to; options = bit (a_sw, 2); /* get options user has requested */ created_seg = "0"b; /* we didn't make output segment */ code, tcode = 0; /* initialize status codes */ call initiate (dirname_from, ename_from, "", 0, 0, ptr_from, code); /* get pointer to FROM segment */ if code ^= 0 then if code ^= error_table_$segknown then go to fin0; try2: call initiate (dirname_to, ename_to, "", 0, 0, ptr_to, code); /* get pointer to TO segment */ if code ^= 0 then if code ^= error_table_$segknown then do; /* if TO segment does not exist */ if created_seg then do; if code = 0 then code = error_table_$no_move; go to fin1; end; if code = error_table_$noentry then do; if append_sw then do; /* if append option given, try to make new TO seg */ created_seg = "1"b; /* first try to create */ call status_$get_max_length_ptr (ptr_from, max_length, code); /* get max length of FROM segment */ if code ^= 0 then go to fin1; call append$branch (dirname_to, ename_to, 01011b, code); if code ^= 0 then go to fin1; /* boo hoo */ call set$max_length_path (dirname_to, ename_to, max_length, code); if code = 0 then go to try2; end; end; go to fin1; /* unable to initiate TO seg or unable to create it */ end; go to common; fseg: entry (a_ptr_from, a_ptr_to, a_sw, a_code); dcl (a_ptr_from, a_ptr_to) ptr; entry_point = seg; /* indicate that entry was via the pointer entry point */ ptr_from = a_ptr_from; /* copy arguments */ ptr_to = a_ptr_to; options = bit (a_sw, 2); /* get options user has requested */ code, tcode = 0; /* initialize status codes */ call fs_get$path_name (ptr_from, dirname_from, ldirname_from, ename_from, code); /* get pathname of FROM segment */ if code ^= 0 then go to fin0; call fs_get$path_name (ptr_to, dirname_to, ldirname_to, ename_to, code); /* get pathname of TO sement */ if code ^= 0 then go to fin0; common: dptr = addr (lbranch); /* get pointer to storage for status_ info */ call status_$long (dirname_to, ename_to, 1, dptr, null, code); /* get status info on TO segment */ if code ^= 0 then if code = error_table_$no_s_permission then code = 0; /* non fatal error */ else go to fin2; /* serious error */ target_len = lbranch.curlen; /* save for later chec */ if lbranch.type ^= "01"b then do; /* make sure that entry is a segment */ badmove: code = error_table_$no_move; go to fin2; end; if (lbranch.mode & "01010"b) ^= "01010"b then go to badmove; /* need RW on TO segment */ call status_$long (dirname_from, ename_from, 1, dptr, null, code); /* get status info on FROM segment */ if code ^= 0 then if code = error_table_$no_s_permission then code = 0; /* non fatal error */ else go to fin2; /* serious error */ if lbranch.type ^= "01"b then go to badmove; /* make sure that entry is a segment */ if (lbranch.mode & "01000"b) = "0"b then go to badmove; /* need R on FROM segment */ curlen = fixed (lbranch.curlen, 12); /* save current length in pages of FROM segment */ words = curlen * 1024; /* get number of words of FROM segment */ call status_$get_max_length_ptr (ptr_to, max_length, code); /* get max length of TO segment */ if code ^= 0 then go to badmove; if words > max_length then go to badmove; /* make sure that TO segment has big enough max length */ call quota$check_file (dirname_to, ename_to, curlen, code); /* make sure that there is enough quota to perform the copy */ if code ^= 0 then go to badmove; /* it wont fit */ if target_len then /* if TO seg has non-zero length */ if truncate_sw then do; /* and if truncate option given, truncate TO seg */ call truncate$trseg (ptr_to, 0, code); if code ^= 0 then go to fin2; end; else do; /* and if truncate option not given, return status code */ code = error_table_$clnzero; go to fin2; end; ptr_to -> copy = ptr_from -> copy; /* copy FROM segment to TO segment */ call truncate$trseg (ptr_from, 0, code); /* truncate FROM segment */ fin2: if entry_point = seg then go to fin0; /* if entered via pointer entry, skip terminating segs */ call terminate_$noname (ptr_to, tcode); /* terminate TO seg */ if tcode ^= 0 then go to fin0; fin1: if entry_point = seg then go to fin0; call terminate_$noname (ptr_from, tcode); /* terminate FROM seg */ fin0: if tcode ^= 0 then a_code = tcode; else a_code = code; return; end;  fs_search.pl1 11/11/89 1132.4rew 11/11/89 0800.5 118395 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-05-02,Elhard), approve(86-05-02,MCR7391), audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222): Modified to add extra indirection when applying the referencing_dir rule if the referencing segment is an object MSF component, and to add the same_directory entrypoint for object MSF link snapping. END HISTORY COMMENTS */ /* format: style2,indcomtxt */ fs_search: procedure (a_refptr, a_refname, a_MSF_sw, a_segptr, a_code); /**** Modified 85-04-09 by Keith Loepere to remove extraneous error codes from set_wdir. Modified 85-02-25 by Keith Loepere for name lookup error I missed last time. Modified 84-10-15 by Keith Loepere for auditing. Also to not beep console on RNT damage. Modified 84-06-25 by Keith Loepere to use the new dc_find. Modified 83-12-08 BIM to protect against bad user ring pointers, flush get_rel_segment, and clean up pigsties. Modified 1/83 by Keith Loepere for object on unmounted logical volume. Modified 2/79 W. Olin Sibert to make fs_search return correct error code for error_table_$moderr Modified 3/77 by M. Weaver to use search rules in user ring and not zero lot entry Modified 8/76 by M. Weaver to initialize LOT entry directly Init search rules for ring 8/76 THVV Modified June 1976 by R. Bratt to dereference old wdirs Massively reorganized April 1975 by R. Bratt for new kst 8/7/75 by S. Webber to remove get_seg_count, get_seg_ptr, and get_segment entries and to add fs_search entry */ /* Parameters */ dcl a_code fixed bin (35) parameter; /* returned status code */ dcl a_pathcnt fixed bin (17) parameter; dcl a_pathptr ptr parameter; dcl a_refname char (*) parameter;/* segment referenced */ dcl a_refptr ptr parameter; /* pointer to segment attempting to link */ dcl a_segptr ptr parameter; /* returned pointer to segment referenced */ dcl a_MSF_sw bit (1) aligned parameter; /* on if refp refers to an MSF */ dcl a_wdir char (*) parameter;/* path name of new working directory */ /* Variables */ dcl bc fixed bin (24); dcl code fixed bin (35); dcl dirname char (168); dcl i fixed bin; dcl old_ep ptr; dcl pathname char (168) varying; dcl refname char (32); dcl refptr ptr; /* temporary storage */ dcl ring fixed bin (3); /* variable for validation level */ dcl segment_number fixed bin; dcl segment_uid bit (36) aligned; dcl segptr ptr; /* temporary storage */ dcl srp ptr; /* pointer to search rules in current use */ dcl test_stack_reference bit (36) aligned; dcl type fixed bin (2); dcl MSF_sw bit (1) aligned; dcl wdir char (168); dcl wdp ptr; /* working directory pointer */ /* Based */ dcl based_reference bit (36) aligned based; dcl dname char (168) based aligned; dcl 1 sr (22) based aligned,/* search rule declaration */ ( 2 base bit (18), /* segment number */ 2 off bit (18), /* offset or code */ 2 uid bit (36) ) unaligned; /* unique id */ /* External */ dcl error_table_$dirseg ext fixed bin (35); dcl error_table_$inconsistent_rnt ext fixed bin (35); dcl error_table_$logical_volume_not_defined ext fixed bin (35); dcl error_table_$moderr ext fixed bin (35); dcl error_table_$root ext fixed bin (35); dcl error_table_$seg_not_found ext fixed bin (35); dcl error_table_$segknown ext fixed bin (35); dcl pds$stacks (0:7) ptr ext; dcl pds$process_group_id char (32) ext static; dcl pds$wdir (0:7) ptr ext; /* pointers to working directories (per ring) */ dcl pds$wdir_uid (0:7) ext bit (36); /* Entries */ dcl get_kstep entry (fixed bin (17), ptr, fixed bin (35)); dcl get_pathname_ entry (fixed bin (17), char (*) varying, fixed bin (35)); dcl initiate$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl initiate$initiate_seg_count entry (ptr, char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl level$get entry returns (fixed bin); dcl lock$dir_unlock entry (ptr); dcl ref_name_$get_segno entry (char (32) varying, fixed bin (17), fixed bin (35)); dcl segno_usage$decrement entry (fixed bin (17), fixed bin (35)); dcl status_$minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl syserr entry options (variable); dcl terminate_proc entry (fixed bin (35)); /* Misc */ dcl any_other condition; dcl (addr, baseptr, hbound, length, null, ptr, rtrim, segno) builtin; %page; refptr = a_refptr; /* copy arguments */ refname = a_refname; MSF_sw = a_MSF_sw; segptr = null; code = 0; ring = level$get (); test_stack_reference = pds$stacks (ring) -> based_reference; /* in a new ring this will fault on stack which will cause makestack to be invoked which will init rnt and search rules */ on any_other call USER_RING_DAMAGED ("stack_header.rnt_ptr", ring); /* now, however, a fault is evidence of a real problem */ rntp = pds$stacks (ring) -> stack_header.rnt_ptr; on any_other call USER_RING_DAMAGED ("rnt.srulep", ring); srp = rnt.srulep; /* get pointer to search rules */ on any_other call USER_RING_DAMAGED ("the RNT", ring); /* start the search */ do i = 1 to hbound (srp -> sr, 1); if srp -> sr (i).off then do; /* special code */ /* do this for special codes */ if srp -> sr (i).off = INITIATED_RULE then do; /* search RNT */ call ref_name_$get_segno ((refname), segment_number, code); if code = 0 then do; segptr = baseptr (segment_number); addr (segptr) -> its_unsigned.ringno = 0; /* writearound for compiler bug to force ring num = ring of exec (i.e., 0) */ go to return; end; end; else if srp -> sr (i).off = REFERENCING_DIR_RULE then do; /* search parent of referencing proceedure */ if refptr ^= null then do; /* must have pointer to referencing proceedure */ call get_kstep (segno (refptr), kstep, code); if code = 0 then do; /* see if we have to go up another level for an MSF */ if MSF_sw then call get_kstep (segno (kste.entryp), kstep, code); dp = ptr (kste.entryp, 0); go to init_seg; end; end; end; else if srp -> sr (i).off = WDIR_RULE then do; /* search the working directory */ dp = pds$wdir (ring); /* get the working directory for this ring */ if dp ^= null then do; call get_kstep (segno (dp), kstep, code); if code = 0 then if pds$wdir_uid (ring) = kstep -> kste.uid /* check uid to make sure */ then go to init_seg; end; end; else if srp -> sr (i).off = END_RULE then do; /* not found */ code = error_table_$seg_not_found; goto return; end; else if srp -> sr (i).off = BAD_RULE then ; /* ignore bad rule */ end; /* come here for fixed directory search rules */ else do; dp = baseptr (srp -> sr (i).base); /* set up pointer to directory */ call get_kstep (segno (dp), kstep, code); if code = 0 then if srp -> sr (i).uid = kstep -> kste.uid then do; /* check uid to make sure */ init_seg: call initiate$initiate_seg_count (dp, refname, refname, (0), 1b, segptr, code); if segptr ^= null then do; if code = error_table_$segknown then code = 0; /* Clear residual code */ go to return; end; else if code = error_table_$moderr | code = error_table_$logical_volume_not_defined then go to return; else if code = error_table_$dirseg then do; call dc_find$obj_existence_ptr (dp, ep, code); if code = 0 then do; call get_pathname_ (segno (dp), pathname, code); call dc_find$finished (ep, DC_FIND_UNLOCK_DIR); end; if code = 0 then do; dirname = pathname; call status_$minf (dirname, refname, 1, type, bc, code); end; if code = 0 & bc > 0 & type = 2 then do; dirname = rtrim (pathname) || ">" || refname; call initiate$initiate_count (dirname, "0", refname, (0), 1, segptr, code); if segptr ^= null then do; if code = error_table_$segknown then code = 0; /* Clear residual code */ go to return; end; else if code = error_table_$moderr | code = error_table_$logical_volume_not_defined then go to return; end; end; end; end; end; code = error_table_$seg_not_found; /* If fall through, indicate not found */ return: a_segptr = segptr; /* return segptr to caller */ a_code = code; return; /* and return */ %page; same_directory: entry (a_refptr, a_refname, a_segptr, a_code); refptr = a_refptr; refname = a_refname; /* preset return values */ segptr = null; code = 0; if refptr ^= null then do; call get_kstep (segno (refptr), kstep, code); if code = 0 then do; dp = ptr (kste.entryp, 0); call initiate$initiate_seg_count (dp, refname, "", 0, 1b, segptr, code); if code = error_table_$segknown then code = 0; end; end; else code = error_table_$seg_not_found; a_segptr = segptr; a_code = code; return; %page; set_wdir: entry (a_wdir, a_code); wdir = a_wdir; /* copy args */ call dc_find$dir_initiate (wdir, dp, code); if code = 0 /* user has access to see object */ then do; ring = level$get (); /* which ring is this for */ segment_number = segno (pds$wdir (ring)); segment_uid = pds$wdir_uid (ring); pds$wdir (ring) = dp; /* save the pointer */ pds$wdir_uid (ring) = dp -> dir.uid; /* and the uid */ call lock$dir_unlock (dp); call get_kstep (segment_number, kstep, code); if code = 0 then if segment_uid = kstep -> kste.uid then do; /* dereference old wdir */ call dc_find$obj_terminate_ptr (baseptr (segment_number), old_ep, code); /* audit termination */ if code = 0 then call lock$dir_unlock (ptr (old_ep, 0)); if code = error_table_$root then code = 0; if code = 0 then call segno_usage$decrement (segment_number, (0)); end; code = 0; end; a_code = code; return; %page; get_wdir: entry (a_pathptr, a_pathcnt); /* to return the path name of the working directory */ pathname = ""; /* in case of error */ ring = level$get (); /* which ring is this for */ wdp = pds$wdir (ring); call get_kstep (segno (wdp), kstep, code); if code = 0 then if pds$wdir_uid (ring) = kstep -> kste.uid then do; call dc_find$obj_existence_ptr (wdp, ep, code); if code = 0 then do; call get_pathname_ (segno (wdp), pathname, code); call dc_find$finished (ep, DC_FIND_UNLOCK_DIR); end; else if code = error_table_$root then do; code = 0; pathname = ">"; end; end; a_pathptr -> dname = pathname; a_pathcnt = length (pathname); return; %page; USER_RING_DAMAGED: procedure (Damaged_thing, Ring); dcl Damaged_thing char (*) parameter; dcl Ring fixed bin (3) parameter; call syserr (JUST_LOG, "fs_search: Fatal damage detected to ^a in ring ^d for ^a.", Damaged_thing, Ring, pds$process_group_id); call terminate_proc (error_table_$inconsistent_rnt); end USER_RING_DAMAGED; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include dir_header; %page; %include its; %page; %include kst; %page; %include rnt; %page; %include search_rule_flags; %page; %include stack_header; %page; %include syserr_constants; %page; /* BEGIN MESSAGE DOCUMENTATION Message: fs_search: Fatal damage detected to WHAT in ring RING for USER. S: $log T: $run M: Some object crucial to the operation of the dynamic linker in ring RING was detected damaged. Since the dynamic linker cannot operate in the process, it is terminated. A: $ignore END MESSAGE DOCUMENTATION */ end fs_search;  get_defname_.pl1 11/11/89 1132.4r w 11/11/89 0800.5 65115 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ get_defname_: proc (a_linkptr, a_defptr, a_offset, a_section, a_ename, a_code); /* Get_defname is a routine which is given an entry offset . and returns a pointer to the corresponding entry name in acc format. USAGE: dcl get_defname ext entry (ptr, bit(18) aligned, ptr, fixed bin); call get_defname (linkptr, offset, acc_name_ptr, code); 1) linkptr a pointer to the linkage section for the entry (Input) 2) defptr a ptr to the def section or to the seg if seg is a gate 3) offset the offset of the entry (Input) 4) section the object section offset is relative to 5) ename the entry name from the defs 6) code a standard file system status code (Output) Converted for the follow-on 645 by Craig Jensen on 6/27/72. Recoded as get_def_name_ by M. Weaver 12 June 1973 Modified 8/76 by M. Weaver to reference kst_info instead of unsnap_service Modified 10/84 by Keith Loepere to restructure so as to avoid access checks. */ /* Parameters */ dcl a_code fixed bin (35) parameter; dcl a_defptr ptr parameter; dcl a_ename char (*) parameter; dcl a_linkptr ptr parameter; dcl a_offset bit (18) aligned parameter; dcl a_section fixed bin parameter; /* Variables */ dcl acc_name_ptr ptr; dcl bitcnt fixed bin (24); dcl class fixed bin; dcl code fixed bin (35); dcl def_count fixed bin; dcl defptr ptr; dcl first_defptr ptr; dcl link_count fixed bin; dcl linkptr ptr; dcl offset bit (18) aligned; dcl 1 oi aligned like object_info; dcl old_flag fixed bin; dcl savering fixed bin (3); dcl section fixed bin; dcl type fixed bin (2); /* Entries */ dcl level$get entry () returns (fixed bin (3)); dcl level$set entry (fixed bin (3)); dcl link_man$get_lp entry (ptr, ptr); dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)); dcl status_$mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); /* Misc */ dcl (addr, addrel, bin, null, rel, unspec) builtin; /* External */ dcl error_table_$defs_loop ext fixed bin (35); dcl error_table_$no_ext_sym ext fixed bin (35); /* Based */ dcl 1 acc aligned based, /* template for acc string */ 2 count fixed bin (8) unaligned, 2 string char (0 refer (count)) unaligned; /* OLD DEFINITION FORMAT */ dcl 1 ext_sym_definition based aligned, /* external symbol definition block */ 2 next_ext_ptr bit (18) unal, /* pointer to next definition */ 2 trap_ptr bit (18) unal, /* pointer to trap information */ 2 value bit (18) unal, /* value of the defined symbol */ 2 class bit (18) unal, /* says what value is relative to */ 2 nchars bit (9) unaligned, /* number of characters in external def */ 2 char_string bit (279) unaligned;/* external symbol */ %page; code = 0; /* first do some initialization */ link_count = 0; def_count = 0; linkptr = a_linkptr; defptr = a_defptr; offset = a_offset; section = a_section; savering = level$get (); if defptr ^= null then if rel (defptr) ^= "0"b then ; /* user could find definitions in user ring */ else do; /* must find definitions given pointer to object */ /* This program used to handle cases where the segment was a hardcore segment (segno < stack_0) in which the user's validation level was within the call bracket. However, the only two such segments are return_to_ring_0_ and restart_fault, neither of which has anything to look up. */ call dc_find$obj_linkage_ring_ptr (defptr, code); /* let user read through call bracket */ if code ^= 0 then go to no_name; call status_$mins (defptr, type, bitcnt, code); if code ^= 0 then go to no_name; oi.version_number = object_info_version_2; call object_info_$brief (defptr, bitcnt, addr (oi), code); if code = 0 then defptr = oi.defp; else if addr (defptr) -> its_unsigned.ringno ^= 0 then go to no_name; else do; /* hardcore objects had their definitions removed - use get_lp to find them */ call level$set (0); /* allow get_lp to work */ call link_man$get_lp (defptr, linkptr); call level$set (savering); if linkptr ^= null then /* can still find defs from linakge */ if unspec (linkptr -> header.def_ptr) = "0"b then go to no_name; else defptr = linkptr -> header.def_ptr; /* pointer to base of definition section */ end; end; else do; /* must find definitions via linkage info */ if unspec (linkptr -> header.def_ptr) = "0"b then go to no_name; defptr = linkptr -> header.def_ptr; /* pointer to base of definition section */ call dc_find$obj_linkage_ring_ptr (defptr, code); if code ^= 0 then do; no_name: code = error_table_$no_ext_sym; go to return; end; end; first_defptr = defptr; if defptr -> definition.flags.new then do; /* this is new format */ old_flag = 0; if defptr -> definition.flags.ignore then /* skip header in std obj segs */ defptr = addrel (first_defptr, defptr -> definition.forward); end; else old_flag = 1; /* this is old format */ go to test; /* got good def so skip next */ next: defptr = addrel (first_defptr, defptr -> definition.forward); next3: if defptr -> definition.forward = "0"b then /* no more definitions */ goto no_name; def_count = def_count + 1; /* increment definition count */ if def_count >= 4000 then do; /* too many definitions */ code = error_table_$defs_loop; go to return; end; test: if old_flag = 0 then do; /* new_format */ if defptr -> definition.class = "011"b then do; /* check for class 3 */ defptr = addrel (first_defptr, defptr -> definition.segname); /* get to first def quickly */ go to next3; end; end; if defptr -> definition.value ^= offset then go to next; /* no match */ if section > -1 then do; /* use only defs for proper section */ if old_flag = 0 then class = bin (defptr -> definition.class, 3); else class = bin (defptr -> ext_sym_definition.class, 18); if section ^= class then go to next; end; if old_flag = 0 then /* new format */ acc_name_ptr = addrel (first_defptr, defptr -> definition.symbol); else acc_name_ptr = addrel (defptr, 2); /* old format */ a_ename = acc_name_ptr -> acc.string; /* fill in name */ return: a_code = code; return; %page; %include dc_find_dcls; %page; %include definition; %page; %include its; %page; %include linkdcl; %page; %include object_info; end;  hc_page_trace.pl1 11/11/89 1132.4rew 11/11/89 0800.5 48771 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2,indcomtxt */ /**** hc_page_trace: user interface to pds trace buffer Written at an unknown time by an unknown party. Modified 83-12-03 BIM for pgt_ signal. */ /* Entries: declare hc_page_trace entry (pointer); call hc_page_trace (data_ptr); Where: data_ptr points to the structure "trace" in sys_trace.incl.pl1. The entry array is declared with a bound of 1024, and the last_available field is used to tell the size. declare hc_page_trace$get_signal entry (bit (1) aligned, fixed bin (17)); call hc_page_trace$get_signal (ips_signal_enabled, threshold_percent); Where: ips_signal_enabled is "1"b is pgt_ is sent when the buffer is threshold_percent filled. threshold_percent (between 50 and 100) is the % threshold at which a pgt_ is sent. declare hc_page_trace$set_signal entry (bit (1) aligned, fixed bin (17), bit (1) aligned, fixed bin (35)); call hc_page_trace$set_signal (ips_signal_enabled, threshold_percent, changed, old_enabled, old_threshold, code); Where: ips_signal_enabled (Input) is as in get_signal threshold_percent (Input) is as in get_signal if it is < 0, then threshold is not changed. changed (Output) is "1"b if either value was changed. old_enabled (Output) is the old value of signal_enabled old_threshold (Output) is the old value of threshold code (Output) is error_table_$bigarg or error_table_$smallarg if threshold_percent is not between 50 and 100. */ hc_page_trace$get_page_trace: procedure (Data_ptr); declare ( Data_ptr pointer, Old_signal bit (1) aligned, New_signal bit (1) aligned, Old_threshold fixed bin (17), New_threshold fixed bin (17), Changed bit (1) aligned, Code fixed bin (35) ) parameter; declare dp pointer; declare copy_data (copy_length) bit (36) aligned based; declare copy_length fixed bin (19); declare signal_enabled bit (1) aligned; declare threshold_percent fixed bin (17); declare threshold fixed bin (16); declare code fixed bin (35); declare error_table_$bigarg fixed bin (35) ext static; declare error_table_$smallarg fixed bin (35) ext static; declare pds$trace bit (36) aligned external static; declare pds$process_group_id char (32) external static; declare syserr entry options (variable); declare (addr, decimal, fixed, float, round, wordno) builtin; %include sys_trace; dp = Data_ptr; /* copy argument */ trace_ptr = addr (pds$trace); copy_length = wordno (addr (trace.data)) + (2 * trace.last_available); /* entries are doublewords */ /*** if user supplied insufficient space, tough! */ dp -> copy_data = trace_ptr -> copy_data; /* copy the trace data */ return; get_signal: entry (Old_signal, Old_threshold); call setup_get_old; return; set_signal: entry (New_signal, New_threshold, Changed, Old_signal, Old_threshold, Code); code = 0; call setup_get_old; signal_enabled = New_signal; threshold_percent = New_threshold; if threshold_percent ^< 0 /* changing threshold */ then do; if threshold_percent < 50 then code = error_table_$smallarg; else if threshold_percent > 100 then code = error_table_$bigarg; if code ^= 0 then go to RETURN; end; else threshold_percent = get_threshold_percent (); threshold = round (fixed (float (decimal (threshold_percent)) / 1.0e2 * float (decimal (trace.last_available)), 17, 1), 0); /* calculate in decimal to make 100 work right */ Changed = (signal_enabled ^= trace.send_ips) | (threshold ^< 0 & threshold ^= trace.threshold); trace.send_ips = signal_enabled; trace.threshold = threshold; RETURN: Code = code; return; setup_get_old: procedure; trace_ptr = addr (pds$trace); Old_signal = trace.send_ips; Old_threshold = get_threshold_percent (); return; end setup_get_old; get_threshold_percent: procedure returns (fixed bin (17)); if trace.threshold = 0 then call syserr (TERMINATE_PROCESS, "hc_page_trace: pds$trace.threshold found zero for ^a.", pds$process_group_id); else return ( round ( fixed (float (decimal (trace.threshold)) / float (decimal (trace.last_available)) * 1.00e2, 17, 1), 0) ); end get_threshold_percent; %include syserr_constants; /* BEGIN MESSAGE DOCUMENTATION Message: hc_page_trace: pds$trace.threshold found zero for USER. M: The signalling threshold for page tracing was found to be zero for USER. This indicates that the user's pds has been damaged. S: $term T: $run A: Investigate the saved dead process. END MESSAGE DOCUMENTATION */ end hc_page_trace$get_page_trace;  initiate_.pl1 11/11/89 1132.4r w 11/11/89 0800.0 289224 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: off */ /* This program was formatted via emacs. */ initiate_: initiate: procedure (a_dname, a_ename, a_rname, a_segsw, a_copysw, a_segptr, a_code); /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* History of earlier versions of the program: */ /* Modified on 05/74 by E Stone to call status_$long when copy made */ /* (to get curlen and to cause a branch update) */ /* Modified by Kobziar July 74 to call new entry in access_mode */ /* and to add privileged initate entries */ /* Modified on 03/76 by R. Bratt to check mountedness of LV before okaying */ /* makeknown */ /* Modified on 06/01/76 by R. Bratt to call find_$finished */ /* Modified on 06/02/76 by R. Bratt to cleanup a piece of trash! */ /* Modified 760317 by L. Scheffler to properly call dir_control_error */ /* entries */ /* Modified on 03/29/77 by M. Weaver to set lot fault when segment is first */ /* initiated in ring */ /* Modified on 78/02/21 by M. Weaver to call link_man$grow_lot at proper */ /* boundary */ /* Modified on 79/08/29 by Mike Grady to fix bug handling reserved segno's */ /* and copy sw */ /* Modified on 81/04/06 by J. Bongiovanni to fix max lot size check */ /* Modified May 1981 by C. Hornig to remove references to the copy switch. */ /* Modified 04/30/84 by S. Herbst to add $get_segment_ptr_path */ /* Modified 07/18/84 by Keith Loepere to use the new dc_find. */ /* Modified 10/19/84 by Keith Loepere to do the right thing for initiating */ /* directories. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /****^ HISTORY COMMENTS: 1) change(85-12-10,GDixon), approve(86-08-09,MCR7388), audit(86-09-12,Farley), install(86-09-08,MR12.0-1150): Completely rewritten to: a) improve program structure and reduce number of switches used in code; b) keep directory locked while calling makeknown_, so that the pointer to dir entry remains valid; c) use dc_find$finished for most directory unlocking. END HISTORY COMMENTS */ /* Parameters */ dcl a_code fixed bin (35) parameter; dcl a_copysw fixed bin (2) parameter; dcl a_dname char (*) parameter; dcl a_dp ptr parameter; dcl a_ename char (*) parameter; dcl a_rname char (*) parameter; dcl a_count fixed bin (17); dcl a_segptr ptr parameter; dcl a_segsw fixed bin (1) parameter; dcl a_uid bit (36) parameter; /* Variables */ dcl 1 in aligned, /* copies of input parms. */ 2 segp ptr, 2 dirp ptr, 2 dname char(168) unal, 2 ename char(32) unal, 2 rname char(32) varying; dcl 1 entrypoint aligned, /* per-entrypoint controls */ 2 dc_find entry (char(168), char(32), ptr, fixed bin(35)) variable, 2 should_call_find_finished bit(1), 2 should_unlock_dir bit(1), 2 priv bit(1); dcl 1 seg aligned, /* intermediate data for */ 2 dirp ptr, /* segment being initiated.*/ 2 entp ptr, 2 directory bit(1), 2 hash_bucket fixed bin(17); dcl 1 out aligned, /* copies of output data. */ 2 segp ptr, 2 bc fixed bin(24), 2 uid bit(36), 2 code fixed bin(35); /* External */ dcl error_table_$dirseg external fixed bin (35); dcl error_table_$invalid_copy external fixed bin (35); dcl error_table_$seg_unknown external fixed bin (35); dcl error_table_$segknown external fixed bin (35); /* Entries */ dcl kstsrch entry (bit (36) aligned, fixed bin (17), ptr); /* Misc */ dcl (addr, baseno, baseptr, fixed, null, ptr, rtrim, unspec) builtin; dcl (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant); /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* NAME: initiate */ /* */ /* This module is a primitive which calls other routines to make a segment */ /* known, i.e., to assign a segment number to the segment or a copy of the */ /* segment. */ /* */ /* ENTRY: initiate */ /* */ /* This is the main entrypoint. Besides making a segment identified by */ /* pathname known (optionally by a given reference name), it allows the */ /* caller to optionally specify the segment number by which the segment */ /* will be known. The copysw argument is obsolete; a value of 2 (always */ /* make a copy of the segment in the pdir) is diagnosed as an error; */ /* otherwise the switch is ignored. */ /* */ /* USAGE: call initiate (a_dname, a_ename, a_rname, a_segsw, a_copysw, */ /* a_segptr, a_code); */ /* */ /* a_dname (char(*)) */ /* pathname of parent directory of the segment to be initiated (Input) */ /* a_ename (char(*)) */ /* entryname of the segment to be initiated (Input) */ /* a_rname (char(*)) */ /* reference name by which the segment is to be made known if this */ /* argument is of zero length, then the segment is made known by a null */ /* name (Input) */ /* a_segsw (fixed bin (1)) */ /* reserve segment switch (Input) */ /* (= 0 if no segment number reserved, */ /* = 1 if segment number reserved) */ /* a_copysw (fixed bin (2)) */ /* formerly copy switch (Input) */ /* (= 0 if default setting of copy switch to be used, */ /* = 1 if segment never to be copied, */ /* = 2 if segment always to be copied into process dir prior to */ /* initiation. This alternative is no longer implemented. It */ /* produces an error.) */ /* a_segptr (pointer) */ /* normally output. If segsw = 1 then input pointer to previously known */ /* segment (used to input reserve segment number) . */ /* a_code (fixed bin (35)) */ /* status code (Output) */ /* */ /* ENTRY: priv_init */ /* */ /* This entry is identical to the initiate entrypoint, except that it */ /* ignores the impact of AIM and ring brackets when determining whether the */ /* user has access to initiate the segment. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* The real procedure statement is up above. This one is useful documentation. initiate_: initiate: proc (a_dname, a_ename, a_rname, a_segsw, a_copysw, a_segptr, a_code); */ call setup_args$initiate(); entrypoint.dc_find = dc_find$obj_initiate; go to INITIATE_COMMON; /* * * * * * * * * * * * * * * * * * * * * * * * * */ priv_init: entry (a_dname, a_ename, a_rname, a_segsw, a_copysw, a_segptr, a_code); call setup_args$initiate(); entrypoint.dc_find = dc_find$obj_initiate_raw; entrypoint.priv = TRUE; INITIATE_COMMON: if out.code = 0 then do; call entrypoint.dc_find (in.dname, in.ename, seg.entp, out.code); if out.code = 0 then do; entrypoint.should_call_find_finished = TRUE; entrypoint.should_unlock_dir = FALSE; call check_entry(); call make_entry_known_and_unlock_dir(); end; end; a_segptr = out.segp; a_code = out.code; return; /* * * * * * * * * * * * * * * * * * * * * * * * * */ setup_args$initiate: proc; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Input Args: */ /* a_dname, a_ename, a_rname, */ /* a_segsw, a_copysw, a_seg_ptr */ /* input parameters, to be copied and tested. Meanings of these parms */ /* are given in entrypoint descriptions above. */ /* */ /* Function: */ /* 1) copy a_dname, a_ename, a_rname. */ /* 2) copy, test and apply a_segsw to initial value of in.segp. */ /* 3) initialize out.segp, out.bc out.uid & entrypoint.priv. */ /* 4) copy and test a_copysw. Set out.code according to test results. */ /* */ /* Output Args: */ /* in.dname, in.ename, in.rname */ /* copies of input parameters. */ /* in.segp */ /* copy of a_segptr if a_segsw is on; otherwise set to null. */ /* out.segp */ /* initialized to null (default output value if error occurs). */ /* out.bc */ /* set to 0 (unused return argument). */ /* out.uid */ /* set to "0"b (unused return argument). */ /* out.code */ /* result of test of a_copysw. */ /* entrypoint.priv */ /* set to off, assuming not entered at privileged */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl copysw fixed bin (2); dcl segsw fixed bin (1); copysw = a_copysw; segsw = a_segsw; in.dname = a_dname; in.ename = a_ename; in.rname = rtrim(a_rname); if segsw = 0 then /* a_segptr can only be */ in.segp = null; /* copied if segsw ^= 0. */ else /* Otherwise, it must not */ in.segp = a_segptr; /* be touched, since its */ /* storage may not be in */ /* ptr format. */ out.segp = null; out.bc = 0; out.uid = "0"b; if copysw = 2 then out.code = error_table_$invalid_copy; else out.code = 0; entrypoint.priv = FALSE; end setup_args$initiate; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* ENTRY: initiate_count */ /* */ /* This entry is the same as initiate except that a bit count parameter */ /* replaces the a_segsw parm. */ /* */ /* USAGE: call initiate$initiate_count */ /* (a_dname, a_ename, a_rname, a_count, a_copysw, a_segptr, a_code);*/ /* */ /* a_count (fixed bin(24)) */ /* bit count of initiated segment (Output) */ /* */ /* ENTRY: priv_init_count */ /* */ /* This entry is like initiate_count, except that it ignores the impact of */ /* AIM and ring brackets when determining whether the user has access to */ /* initiate the segment. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ initiate_count: entry (a_dname, a_ename, a_rname, a_count, a_copysw, a_segptr, a_code); call setup_args$initiate_count(); entrypoint.dc_find = dc_find$obj_initiate; go to INITIATE_COUNT_COMMON; /* * * * * * * * * * * * * * * * * * * * * * * * * */ priv_init_count: entry (a_dname, a_ename, a_rname, a_count, a_copysw, a_segptr, a_code); call setup_args$initiate_count(); entrypoint.dc_find = dc_find$obj_initiate_raw; entrypoint.priv = TRUE; INITIATE_COUNT_COMMON: if out.code = 0 then do; call entrypoint.dc_find (in.dname, in.ename, seg.entp, out.code); if out.code = 0 then do; entrypoint.should_call_find_finished = TRUE; entrypoint.should_unlock_dir = FALSE; call check_entry(); call make_entry_known_and_unlock_dir(); end; end; a_count = out.bc; a_segptr = out.segp; a_code = out.code; return; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ setup_args$initiate_count: proc; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Input Args: */ /* a_dname, a_ename, a_rname, a_copysw */ /* input parameters, to be copied and tested. Meanings of these parms */ /* are given in entrypoint descriptions above. */ /* */ /* Function: */ /* 1) copy a_dname, a_ename, a_rname. */ /* 2) initialize in.segp, out.segp, out.bc, out.uid & entrypoint.priv. */ /* 3) copy and test a_copysw. Set out.code according to test results. */ /* */ /* Output Args: */ /* in.dname, in.ename, in.rname */ /* copies of input parameters. */ /* in.segp */ /* set to null (no reserved segment number specified). */ /* out.segp */ /* set to null (default output value if error occurs). */ /* out.bc */ /* set to value for bit count to be output if error occurs (0). */ /* out.uid */ /* set to "0"b (unused output value). */ /* out.code */ /* result of test of a_copysw. */ /* entrypoint.priv */ /* set to off, assuming not entered at privileged entrypoint. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl copysw fixed bin (2); copysw = a_copysw; in.dname = a_dname; in.ename = a_ename; in.rname = rtrim(a_rname); in.segp = null; out.segp = null; out.bc = 0; out.uid = "0"b; if copysw = 2 then out.code = error_table_$invalid_copy; else out.code = 0; entrypoint.priv = FALSE; end setup_args$initiate_count; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* ENTRY: initiate_seg_count */ /* */ /* This entry is the same as initiate_count except that it takes a */ /* directory pointer instead of a directory path name. It is used solely */ /* by fs_search. */ /* */ /* NOTE: a contract has been made that this entry can only be called by */ /* fs_search. dc_find knows this. As such, dc_find does not do its normal */ /* name lookup access check for this routine, and merely returns no_info */ /* if the name doesn't exist or if the user doesn't have access. */ /* */ /* USAGE: call initiate$initiate_seg_count */ /* (a_dp, a_ename, a_rname, a_count, a_copysw, a_segptr, a_code); */ /* */ /* a_dp (ptr) */ /* pointer to directory of entry ename. (Input) */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ initiate_seg_count: entry (a_dp, a_ename, a_rname, a_count, a_copysw, a_segptr, a_code); call setup_args$initiate_seg_count(); if out.code = 0 then do; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Note that dc_find$obj_initiate_for_linker_dp, knowing it is called only */ /* for fs_search, does not perform its normal name lookup access checks. */ /* If the entry is not found, dc_find will return no_info, as it will (for */ /* this one entry only) if the user lacks access to see the object. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ call dc_find$obj_initiate_for_linker_dp (in.dirp, in.ename, seg.entp, out.code); if out.code = 0 then do; if in.dirp = null then do; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This means ename was a link to an object in another directory besides */ /* that pointed to by in.dirp. Therefore, we cannot unlock the dir but */ /* must instead tell dc_find to do it. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ entrypoint.should_unlock_dir = FALSE; entrypoint.should_call_find_finished = TRUE; end; else do; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This is the normal case, in which we can unlock in.dirp directly without */ /* having to call dc_find. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ entrypoint.should_call_find_finished = FALSE; entrypoint.should_unlock_dir = TRUE; end; call check_entry(); call make_entry_known_and_unlock_dir(); end; end; a_count = out.bc; a_segptr = out.segp; a_code = out.code; return; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ setup_args$initiate_seg_count: proc; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Input Args: */ /* a_dp, a_ename, a_rname, */ /* a_copysw */ /* input parameters, to be copied and tested. Meanings of these parms */ /* are given in entrypoint descriptions above. */ /* */ /* Function: */ /* 1) copy a_dp, a_ename, a_rname. */ /* 2) initialize in.segp, out.segp, out.bc, out.uid & entrypoint.priv. */ /* 3) copy and test a_copysw. Set out.code according to test results. */ /* */ /* Output Args: */ /* in.dirp, in.ename, in.rname */ /* copies of input parameters. */ /* in.segp */ /* set to null (no reserved segment number specified). */ /* out.segp */ /* set to null (default output value if error occurs). */ /* out.bc */ /* set to value for bit count to be output if error occurs (0). */ /* out.uid */ /* set to "0"b (unused output value). */ /* out.code */ /* result of test of a_copysw. */ /* entrypoint.priv */ /* set to off, not a privileged entrypoint. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl copysw fixed bin (2); in.dirp = a_dp; in.ename = a_ename; in.rname = rtrim(a_rname); in.segp = null; out.segp = null; out.bc = 0; out.uid = "0"b; copysw = a_copysw; if copysw = 2 then out.code = error_table_$invalid_copy; else out.code = 0; entrypoint.priv = FALSE; end setup_args$initiate_seg_count; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* ENTRY: get_segment_ptr_path */ /* */ /* This entry point returns a ptr and uid if the segment is already */ /* initiated; it returns an error if the segment is not already initiated. */ /* */ /* USAGE: call initiate_$get_segment_ptr_path (a_dname, a_ename, a_segptr, */ /* a_uid, a_code); */ /* */ /* a_dname (char(*)) */ /* parent directory. (Input) */ /* a_ename (char(*)) */ /* entry name. (Input) */ /* a_segptr (ptr) */ /* pointer to the segment, or null. (Output) */ /* a_uid (bit(36)) */ /* file system uid. (Output) */ /* a_code (fixed(35)) */ /* zero or error_table_$seg_unknown. (Output) */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ get_segment_ptr_path: entry (a_dname, a_ename, a_segptr, a_uid, a_code); call setup_args$get_segment_ptr_path(); call dc_find$obj_initiate (in.dname, in.ename, seg.entp, out.code); if out.code = 0 then do; entrypoint.should_call_find_finished = TRUE; entrypoint.should_unlock_dir = FALSE; call check_entry(); if seg.directory then do; out.code = error_table_$dirseg; out.uid = "0"b; end; else do; call kstsrch (out.uid, seg.hash_bucket, kstep); if kstep = null then do; out.code = error_table_$seg_unknown; out.uid = "0"b; end; else out.segp = baseptr (kste.segno); end; call unlock_dir(); end; a_uid = out.uid; a_segptr = out.segp; a_code = out.code; return; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ setup_args$get_segment_ptr_path: proc; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Input Args: */ /* a_dname, a_ename */ /* input parameters, to be copied. Meanings of these parms are given in */ /* entrypoint descriptions above. */ /* */ /* Function: */ /* 1) copy a_dname and a_ename */ /* 2) initialize in.segp, out.segp, out.bc, out.uid, out.code and */ /* entrypoint.priv. */ /* */ /* Output Args: */ /* in.dname, in.ename */ /* copies of input parameters. */ /* in.segp */ /* set to null (no reserved segment number specified). */ /* out.segp */ /* set to null (default output value if segment not known). */ /* out.bc */ /* set to 0 (unused return argument). */ /* out.uid */ /* set to uid value to output if error occurs (0). */ /* out.code */ /* set to 0. */ /* entrypoint.priv */ /* set to off, not a privileged entrypoint. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ in.dname = a_dname; in.ename = a_ename; in.segp = null; out.segp = null; out.bc = 0; out.uid = "0"b; out.code = 0; entrypoint.priv = FALSE; end setup_args$get_segment_ptr_path; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ check_entry: proc; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Input Args: */ /* seg.entp */ /* pointer to the dir branch for the entry to be initiated. */ /* */ /* Function: */ /* 1) Check if target entry being initiated is the root dir. If so */ /* fabricate information. */ /* 2) Otherwise, extract output information from dir branch for the entry. */ /* */ /* Output Args: */ /* seg.dirp */ /* pointer to the containing dir. */ /* seg.directory */ /* on if entry being initiated is a directory. */ /* out.uid */ /* entry's unique ID */ /* out.bc */ /* entry's bit count */ /* entrypoint.should_call_find_finished, */ /* entrypoint.should_unlock_dir */ /* switches controlling whether/how directory is unlocked. These are */ /* turned off if the entry is the root dir. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ if seg.entp = null then do; /* root */ seg.dirp = null; seg.directory = TRUE; out.uid = "777777777777"b3; out.bc = 0; entrypoint.should_call_find_finished, /* didn't lock anything */ entrypoint.should_unlock_dir = FALSE; end; else do; seg.dirp = ptr (seg.entp, 0); seg.directory = seg.entp -> entry.dirsw; out.uid = seg.entp -> entry.uid; out.bc = seg.entp -> entry.bc; end; end check_entry; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ make_entry_known_and_unlock_dir: proc; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Input Args: */ /* in.segp */ /* reserved segment number to use for initiate_ entrypoint */ /* in.rname */ /* name by which segment is to be referenced (for ref_name_$insert) */ /* seg.dirp */ /* pointer to dir containing entry. */ /* seg.entp */ /* pointer to entry's dir branch. */ /* seg.directory */ /* on if entry being initiated is a directory. */ /* entrypoint.priv */ /* on if calling entrypoint is privileged (for call to makeknown_) */ /* out.uid */ /* entry's unique ID (for call to makeknown_) */ /* */ /* Function: */ /* 1) Ensures disk holding target entry is mounted. */ /* 2) Makes target entry known to process. */ /* 3) Unlocks containing directory. */ /* 4) Adds reference name table (RNT) entry for the known segment. */ /* 5) Sets LOT entry for the segment (in target ring) to lot_fault value. */ /* */ /* Output Args: */ /* out.segp */ /* pointer to initiated segment (remains unchanged if makeknown_ fails). */ /* out.bc */ /* bit count (set to 0 if makeknown_ fails). */ /* out.code */ /* results from call to mountedp, makeknown_ and ref_name_$insert. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Variables */ dcl ecode fixed bin (35); dcl 1 mk_info aligned like makeknown_info; dcl ring fixed bin (3); dcl segno fixed bin; dcl use_count fixed bin (17); /* External */ dcl pds$stacks (0:7) ptr ext; dcl 1 pds$useable_lot aligned ext, 2 flags (0:7) bit (1) unal; /* Entries */ dcl level$get entry returns (fixed bin (3)); dcl link_man$grow_lot entry (fixed bin (3)); dcl makeknown_ entry (ptr, fixed bin, fixed bin, fixed bin (35)); dcl mountedp entry (bit (36) aligned, fixed bin (35)); dcl ref_name_$insert entry (char (32) varying, fixed bin, fixed bin (35)); if ^seg.directory then do; /* ensure LV is mounted */ call mountedp (seg.dirp -> dir.sons_lvid, out.code); if out.code ^= 0 then do; call unlock_dir(); out.bc = 0; /* Don't return bit count */ return; /* if errors occur. */ end; end; unspec (mk_info) = FALSE; mk_info.uid = out.uid; mk_info.entryp = seg.entp; /* dir locked, seg.entp */ /* has been validated by */ /* dc_find. */ mk_info.dirsw = seg.directory; mk_info.priv_init = entrypoint.priv; mk_info.allow_write = TRUE; if in.segp ^= null then do; mk_info.rsw = TRUE; segno = fixed (baseno (in.segp), 17); end; else mk_info.rsw = FALSE; call makeknown_ (addr (mk_info), segno, use_count, out.code); call unlock_dir(); /* The dir must stay */ /* locked until after */ if out.code = 0 then; /* makeknown_ returns, as */ else if out.code = error_table_$segknown then;/* per interface specs. */ else do; out.bc = 0; /* Don't return bit count */ return; /* if errors occur. */ end; out.segp = baseptr (segno); /* From this point on, */ /* makeknown_ has succeeded*/ if in.rname ^= "" then do; /* Add ref name to segment.*/ call ref_name_$insert (in.rname, segno, ecode); if ecode ^= 0 then out.code = ecode; /* Be careful not to zero */ end; /* segknown code needlessly*/ if use_count = 1 then do; /* Made known for first */ ring = level$get (); /* time in a ring? */ if pds$useable_lot.flags (ring) then do; /* diddle user ring lot */ if segno >= pds$stacks (ring) -> stack_header.cur_lot_size then if segno < pds$stacks (ring) -> stack_header.max_lot_size then do; call link_man$grow_lot (ring); unspec (pds$stacks (ring) -> stack_header.lot_ptr -> lot.lp (segno)) = lot_fault; /* flag lot entry to tell */ end; /* run unit seg is known. */ else; /* high segno might be OK */ /* if seg not linked to. */ else unspec (pds$stacks (ring) -> stack_header.lot_ptr -> lot.lp (segno)) = lot_fault; end; end; end make_entry_known_and_unlock_dir; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ unlock_dir: proc; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Input Args: */ /* seg.dirp */ /* pointer to dir containing entry. */ /* seg.entp */ /* pointer to entry's dir branch. */ /* entrypoint.should_call_find_finished */ /* on to call dc_find$finished to unlock and unhold dir. */ /* entrypoint.should_unlock_dir */ /* on to call lock$unlock_dir to unlock dir. */ /* */ /* Function: unlock dir containing target entry. Normally, it was locked */ /* by dc_find$obj_initiate, which also holds the directory (by incrementing */ /* its usage count) to keep it from being KST-garbage-collected. So */ /* dc_find$finished must be called to undo this dir holding. */ /* */ /* However, the linker calls $initiate_seg_count, which uses */ /* dc_find$obj_initiate_for_linker_dp, which does NOT hold the containing */ /* dir unless ename matches a link in the containing dir and the link gets */ /* chased. If no links were chased, then the dir is NOT held and */ /* lock$dir_unlock can be called directly. If links were chased, then */ /* dc_find$finished must be called to unhold the dir containing the chased */ /* link target. */ /* */ /* Finally, if the entry being initiated is the root, then there is no */ /* containing directory to unlock. The input flags are set appropriately */ /* by callers to cause the correct operation to occur. */ /* */ /* Output Args: */ /* entrypoint.should_call_find_finished, */ /* entrypoint.should_unlock_dir */ /* turned off on output. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Entries */ dcl lock$dir_unlock entry (pointer); if entrypoint.should_call_find_finished then call dc_find$finished (seg.entp, DC_FIND_UNLOCK_DIR); else if entrypoint.should_unlock_dir then call lock$dir_unlock(seg.dirp); entrypoint.should_call_find_finished, entrypoint.should_unlock_dir = FALSE; end unlock_dir; /* * * * * * * * * * * * * * * * * * * * * * * * * */ %include dc_find_dcls; %include dir_entry; %include dir_header; %include kst; %include lot; %include makeknown_info; %include stack_header; end initiate_;  initiate_search_rules.pl1 11/11/89 1132.4r w 11/11/89 0800.5 109233 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ initiate_search_rules: proc (a_ptr, a_code); /* Last Modified: (Date and Reason) 10/15/84 by Keith Loepere for auditing info. 06/22/84 by Keith Loepere to use the new dc_find (including access checks). 03/77 by M. Weaver to put search rules in user ring 07/76 by THVV for Bicentennial 04/03/75 by R. Bratt for new kst / rnt system 08/11/71 by Richard H. Gumpertz to make length of pds$process_dir_name = 32 instead of 52 08/04/71 by Mosley Meer for new KST format originally coded by Mosley Meer */ /* This routine is called to initiate and insert the search rules passed to it through the pointer argument USAGE: call initiate_search_rules(ptr, code); 1) ptr pointer to a data array. (Input) 2) code return status code. (Output) NOTE: the data array is of the form dcl 1 input_arg based aligned, 2 number fixed bin, 2 name (22) char (168) unal; All search rules are checked to be directories. */ /* Parameters */ dcl a_code fixed bin (35) parameter; /* return status code */ dcl a_ptr ptr parameter; /* pointer to input search rule array */ dcl syscode fixed bin (35) parameter; dcl sysptr ptr parameter; /* Based */ dcl based_area area based; dcl 1 input_arg based (ap) aligned, /* form of input name structure array */ 2 number fixed bin, 2 name (22) char (168) unal; dcl 1 search_rules (22) based (srp) aligned, ( 2 base bit (18), 2 offset bit (18), 2 uid bit (36)) unaligned; /* Variables */ dcl ap ptr; /* input array pointer */ dcl 1 arg aligned like input_arg; dcl code fixed bin (35); dcl count fixed bin; /* count of rules in pointer array */ dcl firstarg fixed bin; /* first arg to scan (2 for ssd, else 1) */ dcl i fixed bin; dcl new_ring bit (1); dcl old_ep ptr; dcl ring fixed bin; dcl 1 search_rule_temp (22) aligned like search_rules; /* Stack copy */ dcl segnum fixed bin (15); /* segment number from pointer */ dcl srp ptr; /* pointer to a single search rule in KST */ dcl 1 ssd_dft_rules (22) aligned like search_rules; dcl ssd_wdir_index fixed bin; /* location of rule after WDIR rule */ dcl xcode fixed bin (35); /* Entries */ dcl get_kstep entry (fixed bin (15), ptr, fixed bin (35)); dcl level$get entry returns (fixed bin); dcl lock$dir_unlock entry (ptr); dcl lock$lock_fast entry (ptr); dcl lock$unlock_fast entry (ptr); dcl segno_usage$decrement entry (fixed bin (15), fixed bin (35)); /* External */ dcl ahd$n_sr_tags fixed bin ext; dcl ahd$n_sys_rules fixed bin ext; dcl 1 ahd$search_rule (50) aligned ext, 2 name char (168) unal, 2 flag bit (36); dcl 1 ahd$sr_tag (10) aligned ext, 2 name char (32), 2 flag bit (36); dcl ahd$search_rules_lock ext; dcl error_table_$bad_arg ext fixed bin (35); dcl error_table_$bad_string ext fixed bin (35); dcl error_table_$root ext fixed bin (35); dcl error_table_$too_many_sr ext fixed bin (35); dcl pds$home_dir ext char (168) aligned; dcl pds$process_dir_name ext char (32) aligned; dcl pds$stacks (0:7) ptr ext; /* Misc */ dcl (addr, baseptr, binary, bit, hbound, null, segno, substr) builtin; %page; new_ring = "0"b; /* entry used by ssr command */ goto join; init_ring: entry (a_ptr, a_code); new_ring = "1"b; /* called by makestack */ join: ap = a_ptr; /* copy the array pointer */ arg = input_arg; /* Copy whole input structure */ code = 0; ring = level$get (); /* get ring for this search rule set */ rntp = pds$stacks (ring) -> stack_header.rnt_ptr; count = 1; /* count of elements in pointer array */ firstarg = 1; if arg.number < 1 | arg.number >= hbound (search_rules, 1) then do; a_code = error_table_$bad_arg; return; end; call lock$lock_fast (addr (ahd$search_rules_lock)); if arg.name (1) = "default" then do; call process_rule ("default", 0, code); /* Get all rules tagged "default" */ if code ^= 0 then go to fin; /* .. might have changed since proc created */ count = count + 1; go to thru; end; if arg.name (1) = "set_search_directories" then do; /* Set default rules but with extras after wdir */ call process_rule ("default", 0, code); /* Expand default rules */ if code ^= 0 then go to fin; search_rule_temp (count + 1).offset = END_RULE; /* Flag end of list */ do count = 1 to hbound (search_rules, 1) while (search_rule_temp (count).offset ^= WDIR_RULE); end; if count > hbound (search_rules, 1) then go to too_many_err; ssd_wdir_index, count = count + 1; /* Note pos of wdir */ ssd_dft_rules = search_rule_temp; /* Save spare copy of defaults */ firstarg = 2; /* Scan from rule 2 on */ end; do i = firstarg to arg.number; /* Scan strings in user input */ call process_rule (arg.name (i), 0, code); /* Expand each rule */ if code = 1 then i = arg.number; /* Force end of loop */ else if code ^= 0 then go to fin; count = count + 1; if count > hbound (search_rules, 1) then go to too_many_err; /* too many search rules */ end; if arg.name (1) = "set_search_directories" then do; /* Did user rules, now finish sandwich */ do i = ssd_wdir_index to hbound (search_rules, 1); /* Finish copy of default search rules */ if count > hbound (search_rules, 1) then go to too_many_err; search_rule_temp (count) = ssd_dft_rules (i); if search_rule_temp (count).offset = END_RULE then go to thru; count = count + 1; end; go to too_many_err; /* shouldn't get here */ end; /* Insert search termination code */ thru: search_rule_temp (count).uid = "0"b; /* Put in an end marker */ search_rule_temp (count).base = "0"b; search_rule_temp (count).offset = END_RULE; /* insert the code */ /* check if space allocated for these search rules (this ring) */ srp = rnt.srulep; /* ptr to list for current ring */ if srp = null then do; /* First time in a virgin ring */ allocate search_rules in (rnt.areap -> based_area) set (srp); rnt.srulep = srp; /* put it in pointer list */ end; else do i = 1 to hbound (search_rules, 1) while (search_rules (i).offset ^= END_RULE); if search_rules (i).uid ^= "0"b then do; /* Must decrement usage counts of old rules */ segnum = binary (search_rules (i).base, 18); call get_kstep (segnum, kstep, xcode); if xcode = 0 then if search_rules (i).uid = kste.uid then do; call dc_find$obj_terminate_ptr (baseptr (segnum), old_ep, xcode); /* audit termination */ if xcode = 0 then call lock$dir_unlock (ptr (old_ep, 0)); if xcode = error_table_$root then xcode = 0; if xcode = 0 then call segno_usage$decrement (segnum, (0)); end; end; end; search_rules = search_rule_temp; /* Copy search rules into KST */ fin: call lock$unlock_fast (addr (ahd$search_rules_lock)); a_code = code; return; too_many_err: code = error_table_$too_many_sr; go to fin; %page; /* This entry is called from the initializer to set the system default search rules */ set_system_rules: entry (sysptr, syscode); xsp = sysptr; syscode = 0; i = dft_sr_arg.ntags; if i > hbound (dft_sr_arg.tags, 1) then do; syscode = error_table_$bad_arg; return; end; count = dft_sr_arg.nrules; if count > hbound (dft_sr_arg.rules, 1) then do; syscode = error_table_$bad_arg; return; end; call lock$lock_fast (addr (ahd$search_rules_lock)); /* Nobody use whilst i am changing */ ahd$n_sys_rules = count; ahd$n_sr_tags = i; ahd$n_sys_rules = dft_sr_arg.nrules; do i = 1 to ahd$n_sr_tags; ahd$sr_tag (i).name = dft_sr_arg.tags (i).name; ahd$sr_tag (i).flag = dft_sr_arg.tags (i).flag; end; do i = 1 to ahd$n_sys_rules; ahd$search_rule (i).name = dft_sr_arg.rules (i).name; ahd$search_rule (i).flag = dft_sr_arg.rules (i).flag; end; call lock$unlock_fast (addr (ahd$search_rules_lock)); return; /* This entry returns them to the user */ get_system_rules: entry (sysptr, syscode); syscode = 0; xsp = sysptr; call lock$lock_fast (addr (ahd$search_rules_lock)); do i = 1 to ahd$n_sr_tags; dft_sr_arg.tags (i).name = ahd$sr_tag (i).name; dft_sr_arg.tags (i).flag = ahd$sr_tag (i).flag; end; do i = 1 to ahd$n_sys_rules; dft_sr_arg.rules (i).name = ahd$search_rule (i).name; dft_sr_arg.rules (i).flag = ahd$search_rule (i).flag; end; dft_sr_arg.ntags = ahd$n_sr_tags; dft_sr_arg.nrules = ahd$n_sys_rules; call lock$unlock_fast (addr (ahd$search_rules_lock)); return; %page; process_rule: proc (dn, depth, code); dcl code fixed bin (35) parameter; dcl depth fixed bin parameter; dcl dn char (168) parameter; dcl j fixed bin; dcl jj fixed bin; dcl nfound fixed bin; code, nfound = 0; search_rule_temp (count).base = "0"b; search_rule_temp (count).offset = "0"b; search_rule_temp (count).uid = "0"b; if substr (dn, 1, 1) = ">" then do; call initiate_name; end; else if dn = search_rule_names (1) then do; /* "initiated_segments" */ search_rule_temp (count).offset = INITIATED_RULE; /* search KST code */ end; else if dn = search_rule_names (2) then do; /* "referencing_dir" */ search_rule_temp (count).offset = REFERENCING_DIR_RULE; /* parent of referencing proceedure search */ end; else if dn = search_rule_names (3) then do; /* "working_dir" */ search_rule_temp (count).offset = WDIR_RULE; /* search working directory code */ end; else if dn = "process_dir" then do; /* process directory */ dn = pds$process_dir_name; call initiate_name; end; else if dn = "home_dir" then do; /* home or login directory */ dn = pds$home_dir; call initiate_name; end; else if dn = search_rule_names (4) then do; /* End of rules */ code = 1; /* Force end of loop */ end; else do; /* Unrecognized. */ if depth = 0 then do; /* Keyword ok? */ do j = 1 to ahd$n_sr_tags while (dn ^= ahd$sr_tag (j).name); end; if j <= ahd$n_sr_tags then do; do jj = 1 to ahd$n_sys_rules; if (ahd$search_rule (jj).flag & ahd$sr_tag (j).flag) ^= "0"b then do; call process_rule (ahd$search_rule (jj).name, 1, code); if code ^= 0 then return; nfound = nfound + 1; count = count + 1; end; end; if nfound = 0 then code = 2; else count = count - 1; /* count incr by loop above once more than req'd */ return; end; end; code = error_table_$bad_string; end; return; initiate_name: proc; call dc_find$dir_initiate (dn, dp, code); if code = 0 then do; segnum = segno (dp); search_rule_temp (count).base = bit (binary (segnum, 18), 18); /* put away base of pointer */ search_rule_temp (count).uid = dp -> dir.uid; /* store uid */ call lock$dir_unlock (dp); /* don't dereference dir */ end; else if new_ring then do; /* new ring so do best we can */ code = 0; search_rule_temp (count).offset = BAD_RULE; /* special code for bad entry during proc init */ end; return; end initiate_name; end process_rule; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include dir_header; %page; %include kst; %page; %include rnt; %page; %include search_rule_flags; %page; %include stack_header; %page; %include system_dft_sr; end initiate_search_rules;  ips_.alm 11/11/89 1132.4rew 11/11/89 0800.5 92349 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(87-09-03,GDixon), approve(87-09-10,MECR0006), " audit(87-09-30,Farley), install(87-09-10,MR12.1-1104): " A) Change $reset_ips_mask to only reset the mask if the control bit " is on in the incoming mask. Otherwise, it will only return the " current mask value. " 2) change(87-10-07,GDixon), approve(87-10-07,MCR7770), " audit(87-11-02,Farley), install(87-11-30,MR12.2-1004): " A) Formally install changes covered by MECR0006 (change 1 above). " END HISTORY COMMENTS " Name: ips_ " " The procedure "ips_" controls the enabling and disabling of " interprocess signal (IPS) interrupts. Each ring of each process " has an IPS mask and an automatic IPS mask stored in the "pds". " Individual bits of the mask words correspond to specific IPS " interrupts. The correspondence is defined by the procedure " "create_ips_mask_". The following "ips_" entries inspect or " modify the IPS mask or the automatic IPS mask of the calling " process's current validation level. Entries that change a mask " return the former value of the mask. The entries are all " accessible via the hardcore gate "hcs_". " " The last (thirty-sixth) bit of an IPS mask does not " correspond to an interrupt, but is instead a control bit. The " control bit of each IPS mask and each automatic IPS mask stored " in the "pds" is always zero. On mask values input to procedure " "ips_", the control bit is ignored. On masks returned from " "ips_", the control bit is set to either "0"b or "1"b, as " specified in the individual entry descriptions below, to notify " the user that the requested action has been performed. No " process interrupts can occur in the time interval between the " requested mask modification and the return of the old mask and " control bit. Hence, each call on an "ips_" entry behaves as an " atomic operation. " " " " Entry: ips_$get_ips_mask " " This entry returns the value of the current IPS mask without " modifying it. The control bit is returned as "0"b. " " Usage: " " dcl ips_$get_ips_mask entry(bit(36)aligned); " " call ips_$get_ips_mask(oldmask); " " 1) oldmask is the current value of the IPS mask, with a " control bit of "0"b (output). " " " " Entry: ips_$set_ips_mask " " This entry replaces the entire IPS mask with a supplied " value and returns the previous value of the mask with a control " bit of "1"b. " " Usage: " " dcl ips_$set_ips_mask entry(bit(36)aligned,bit(36)aligned); " " call ips_$set_ips_mask(mask,oldmask); " " 1) mask is the new value to replace the IPS mask " (input). " " 2) oldmask is the former value of the IPS mask, with a " control bit of "1"b (output). " " " " Entry: ips_$reset_ips_mask " " This entry is exactly the same as "ips_$set_ips_mask" except " that the control bit in the returned former mask is "0"b. These " two entries can be used to bracket sections of critical code " during which interrupts must be masked. The control bit then " serves as rigorous identification of whether control is in a " critical section. " " Usage: " " dcl ips_$reset_ips_mask entry(bit(36)aligned,bit(36)aligned); " " call ips_$reset_ips_mask(mask,oldmask); " " 1) mask is the new value to replace the IPS mask " (input). " " 2) oldmask is the former value of the IPS mask, with a " control bit of "0"b (output). " " " " Entry: ips_$unmask_ips " " This entry disables specified IPS interrupts. Bits in the " supplied mask value cause corresponding bits of the IPS mask to " be reset. The former value of the IPS mask is returned with a " control bit of "1"b. Warning: for historical reasons, this entry " is misnamed (it masks rather than unmasks). " " Usage: " " dcl ips_$unmask_ips entry(bit(36)aligned,bit(36)aligned); " " call ips_$unmask_ips(mask,oldmask); " " 1) mask for each bit on in this word, the " corresponding bit in the IPS mask is turned " off--i.e., the corresponding IPS interrupt is " disabled (input). " " 2) oldmask is the former value of the IPS mask, with a " control bit of "1"b (output). " " " " Entry: ips_$mask_ips " " This entry enables specified IPS interrupts. Bits in the " supplied mask value cause corresponding bits of the IPS mask to " be set. The former value of the IPS mask is returned with a " control bit of "0"b. Entry "ips_$unmask_ips" and this entry can " be used to bracket sections of critical code during with certain " interrupts must be masked. The control bit then serves as " rigorous identification of whether control is in a critical " section. Warning: for historical reasons, this entry is misnamed " (it unmasks rather than masks). " " Usage: " " dcl ips_$mask_ips entry(bit(36)aligned,bit(36)aligned); " " call ips_$mask_ips(mask,oldmask); " " 1) mask for each bit on in this word, the " corresponding bit in the IPS mask is turned " on--i.e., the corresponding IPS interrupt is " enabled (input). " " 2) oldmask is the former value of the IPS mask, with a " control bit of "0"b (output). " " " " Entry: ips_$set_automatic_ips_mask " " This entry replaces the entire automatic IPS mask with a " supplied value and returns the previous value of the mask with a " control bit of "1"b. " " Usage: " " dcl ips_$set_automatic_ips_mask " entry(bit(36)aligned,bit(36)aligned); " " call ips_$set_automatic_ips_mask(mask,oldmask); " " 1) mask is the new value to replace the automatic IPS " mask (input). " " 2) oldmask is the former value of the automatic IPS " mask, with a control bit of "1"b (output). " " " " " Modified August 1981 by J. Bongiovanni for IPS signals to take " immediately when unmasked (or shortly thereafter) " entry get_ips_mask Inspect IPS mask without changing it. entry set_ips_mask Replace entire IPS mask. entry reset_ips_mask Replace entire IPS mask. entry unmask_ips Disable specific IPS interrupts. entry mask_ips Enable specific IPS interrupts. entry set_automatic_ips_mask Replace entire auto IPS mask. " " " " Entry: ips_$get_ips_mask(oldmask) " get_ips_mask: lxl7 pds$validation_level Validation level to X7. ldq pds$ips_mask,7 Save old IPS mask in the Q. anq =o777777777776 Make sure control bit is 0. stq ap|2,* Pass it back to caller. short_return Return to caller. " " " " Entry: ips_$set_ips_mask(mask,oldmask) " set_ips_mask: lxl7 pds$validation_level Validation level to X7. ldq pds$ips_mask,7 Save old IPS mask in the Q. lda ap|2,* Caller's desired new mask. ana =o777777777776 Control bit must be off. sta pds$ips_mask,7 Set new IPS mask. ret1: orq =o1,dl Set control bit 1 in old mask. stq ap|4,* Pass it back to caller. tra check_ips_pending Make pending, unmasked IPS take " And return to caller. " " " " Entry: ips_$reset_ips_mask(mask,oldmask) " reset_ips_mask: lxl7 pds$validation_level Validation level to X7. ldq pds$ips_mask,7 Save old IPS mask in the Q. lda ap|2,* Caller's desired new mask. cana 1,dl Check if control bit is on. tze ret0 No, don't reset mask. ana =o777777777776 Control bit must be off. sta pds$ips_mask,7 Set new IPS mask. ret0: anq =o777777777776 Set control bit 0 in old mask. stq ap|4,* Pass it back to caller. tra check_ips_pending Make pending, unmasked IPS take " And return to caller. " " " " Entry: ips_$unmask_ips(mask,oldmask) " unmask_ips: lxl7 pds$validation_level Validation level to X7. ldq pds$ips_mask,7 Save old IPS mask in the Q. lda ap|2,* Get bits to be cleared. era =o777777777776 Change bits to zeros for logical AND. ansa pds$ips_mask,7 Clear selected bits of IPS mask. tra ret1 Return old mask with control bit 1. " " " " Entry: ips_$mask_ips(mask,oldmask) " mask_ips: lxl7 pds$validation_level Validation level to X7. ldq pds$ips_mask,7 Save old IPS mask in the Q. lda ap|2,* Get bits to be set. ana =o777777777776 Control bit must remain off. orsa pds$ips_mask,7 Set selected bits of IPS mask. tra ret0 Return old mask with control bit 0. " " " " Entry: ips_$set_automatic_ips_mask(mask,oldmask) " set_automatic_ips_mask: lxl7 pds$validation_level Validation level to X7. ldq pds$auto_mask,7 Save old auto IPS mask in the Q. lda ap|2,* Caller's desired new mask. ana =o777777777776 Control bit must be off. sta pds$auto_mask,7 Set new auto IPS mask. tra ret1 Return old auto mask with control bit 1. " " " " " Internal procedure to check for pending IPS signals which are unmasked " as a result of this call. If any are found, ring_alarm is called " to determine and set an appropriate value of the ring_alarm register " so that the recently unmasked IPS signal will take within a short " amount of time. " " On entry, x7 = current validation level " " This routine will exit to the caller of ips_ " check_ips_pending: eppbp pds$apt_ptr,* bp -> APTE for this process lda bp|apte.ips_message Get pending IPS signals ana pds$ips_mask,7 Check for unmasked in ring of validation tnz set_ring_alarm Pending IPS found short_return None found -- return to caller set_ring_alarm: push " For call out call ring_alarm$reset return Return to caller " include apte end  kst_info.pl1 11/11/89 1132.4r w 11/11/89 0800.5 20313 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ kst_info: proc; /* Written July 7, 1976 by Richard Bratt Last Modified: 8/26/76 by M. Weaver to add high_low_seg_count entry 11/1/84 by K. Loepere to remove hdr. This module contains entries to extract information from a process' KST. These entries may be called by hardcore gates ---> get_uid (segptr, uid, code) This entry translates a segment number (represented as a segptr) into the unique identifier of the object to which the segment number is bound. */ get_uid: entry (a_segptr, a_uid, a_code); /* Parameters */ dcl a_code fixed bin (35, 0) parameter; dcl a_hcsc fixed bin (17) parameter; dcl a_high_seg fixed bin (17) parameter; dcl a_segptr ptr parameter; dcl a_uid bit (36) aligned parameter; /* Variables */ dcl code fixed bin (35, 0); dcl segptr ptr; /* Entries */ dcl get_kstep entry (fixed bin (17), ptr, fixed bin (35)); /* Misc */ dcl segno builtin; %page; segptr = a_segptr; a_uid = "0"b; call get_kstep (segno (segptr), kstep, code); if code ^= 0 then do; a_code = code; return; end; a_uid = kste.uid; a_code = 0; return; %page; high_low_seg_count: entry (a_high_seg, a_hcsc); /* 1) high_seg the number to add to hcsc to get the highest segment number being used. 2) hcsc is the lowest non-hardcore segment number. */ kstp = pds$kstp; a_hcsc = kstp -> kst.lowseg; a_high_seg = kstp -> kst.highest_used_segno - kstp -> kst.lowseg; return; %page; %include kst; end kst_info;  level_0_.pl1 11/11/89 1132.4rew 11/11/89 0800.6 36666 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ level_0_: proc; /* This a program to set the level to 0 before call the access primitives. */ /* Last modified 01/11/79 by C. D. Tavares to add dir_ring_brackets code */ /* Modified 04/26/82 by S Krupp to change declaration of dname and ename to char(*). */ dcl dname char (*), ename char (*), aptr ptr, acount fixed bin, dbit bit (1) aligned, /* daemon bit */ code fixed bin (35), dir_ring_brackets (2) fixed bin (5), ring_brackets (3) fixed bin (5), esw fixed bin, save_level fixed bin; dcl level$get entry (fixed bin), level$set entry (fixed bin), asd_$add_sentries entry (char (*), char (*), ptr, fixed bin (17), fixed bin (35)), asd_$add_dentries entry (char (*), char (*), ptr, fixed bin (17), fixed bin (35)), asd_$replace_sall entry (char (*), char (*), ptr, fixed bin (17), bit (1) aligned, fixed bin (35)), asd_$replace_dall entry (char (*), char (*), ptr, fixed bin (17), bit (1) aligned, fixed bin (35)), asd_$del_sentries entry (char (*), char (*), ptr, fixed bin (17), fixed bin (35)), asd_$del_dentries entry (char (*), char (*), ptr, fixed bin (17), fixed bin (35)), ringbr_$set entry (char (*), char (*), (3) fixed bin (5), fixed bin (35)), ringbr_$set_dir entry (char (*), char (*), (2) fixed bin (5), fixed bin (35)), delentry$priv_dfile entry (char (*), char (*), fixed bin (35)); add_acl_entries: entry (dname, ename, aptr, acount, code); esw = 0; /* add name or names to acl */ go to start; add_dir_acl_entries: entry (dname, ename, aptr, acount, code); esw = 1; /* add name or names to dir acl */ go to start; replace_acl: entry (dname, ename, aptr, acount, dbit, code); esw = 2; /* replace acls */ go to start; replace_dir_acl: entry (dname, ename, aptr, acount, dbit, code); esw = 3; /* replace for a dir */ go to start; delete_acl_entries: entry (dname, ename, aptr, acount, code); esw = 4; /* delete acls */ go to start; delete_dir_acl_entries: entry (dname, ename, aptr, acount, code); esw = 5; /* delete for a dir */ go to start; set_ring_brackets: entry (dname, ename, ring_brackets, code); esw = 6; /* modify the ring brackets */ go to start; set_dir_ring_brackets: entry (dname, ename, dir_ring_brackets, code); esw = 7; /* modify the dir ring brackets */ go to start; delentry_file: entry (dname, ename, code); esw = 8; /* delete a segment */ goto start; start: call level$get (save_level); /* save the current level */ call level$set (0); /* set it to zero */ if esw = 0 then call asd_$add_sentries (dname, ename, aptr, acount, code); else if esw = 1 then call asd_$add_dentries (dname, ename, aptr, acount, code); else if esw = 2 then call asd_$replace_sall (dname, ename, aptr, acount, dbit, code); else if esw = 3 then call asd_$replace_dall (dname, ename, aptr, acount, dbit, code); else if esw = 4 then call asd_$del_sentries (dname, ename, aptr, acount, code); else if esw = 5 then call asd_$del_dentries (dname, ename, aptr, acount, code); else if esw = 6 then call ringbr_$set (dname, ename, ring_brackets, code); else if esw = 7 then call ringbr_$set_dir (dname, ename, dir_ring_brackets, code); else if esw = 8 then call delentry$priv_dfile (dname, ename, code); call level$set (save_level); /* restore the proper level */ return; end;  link_man.pl1 11/11/89 1132.4rew 11/11/89 0800.0 151875 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-06-24,DGHowe), approve(86-06-24,MCR7396), audit(86-08-01,Schroth), install(86-11-20,MR12.0-1222): initialize the heap_header_ptr to null in get_initial_linkage. 2) change(86-10-01,Fawcett), approve(86-10-01,MCR7473), audit(86-10-22,Farley), install(86-11-03,MR12.0-1206): Changed to eliminate stack_header.old_lot_ptr, this obsolete ptr was replaced by stack_header.cpm_data_ptr for Control Point Management. END HISTORY COMMENTS */ /* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */ link_man$other_linkage: proc (atxp, alp, astp, asymbp, acode); /* LINK_MAN " This program is the utility program used by the Multics ring 0 linker. Last modified (date and reason): 9/20/74 by S.Webber Complete rewrite from an earlier version as part of combining stacks, lots, and clr's. rewritten 8/76 by M. Weaver to turn linkage regions into areas. modified 4/77 by M. Weaver to add entry combine_linkage for lot_fault_handler_ modified 5/77 by M. Weaver to process perprocess_static bit modified 9/77 by M. Weaver to change assign_linkage to use assign_linkage_ptr modified 2/78 by M. Weaver to grow lot at correct boundary Modified April 1981 by J. Bongiovanni to fix recursive grow_lot bug Modified May, 1981, Charlie Hornig, to convert for ADP SDW formats Modified August 1981, E. N. Kittlitz per S. Harris (UNCA), check lot size in getlp Modified 83-12-08 BIM to flush support for .link segments, once and for all. Modified April 10, 1984 by M. Weaver to check ring arg in $combine_linkage Modified 84-07-02 BIM to check ring arg in grow_lot. Modified 85-01-22 Keith Loepere to increment usage count for segment in target ring when its linkage is combined. */ /* Parameters */ dcl acode fixed bin (35); dcl alp ptr; dcl aring fixed bin; dcl astp ptr; dcl asymbp ptr; dcl atxp ptr; /* Automatic */ dcl 1 ainfo aligned like area_info; dcl cl fixed bin (14); dcl cl_sw bit (1) aligned; dcl code fixed bin (35); dcl count fixed bin (24); dcl dummy bit (36) aligned; dcl lp ptr; dcl nwords fixed bin (18); dcl 1 oi like object_info; dcl ring fixed bin; dcl rings (3) fixed bin; dcl 1 sdwi aligned like sdw_info; dcl sp ptr; dcl stack_end fixed bin (18); dcl stp ptr; dcl target fixed bin; dcl target_sp ptr; dcl tcode fixed bin (35); dcl txp ptr; dcl type fixed bin (2); /* Entries */ dcl define_area_ entry (ptr, fixed bin (35)); dcl level$get entry returns (fixed bin); dcl makestack entry (fixed bin); dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)); dcl sdw_util_$dissect entry (ptr, ptr); dcl segno_usage$increment_other_ring entry (fixed bin, fixed bin, fixed bin (35)); dcl status_$mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); dcl terminate_proc entry (fixed bin (35)); /* External */ dcl dseg$ (0:1) fixed bin (71) ext; dcl error_table_$bad_segment fixed bin (35) ext; dcl error_table_$badringno fixed bin (35) ext; dcl error_table_$invalidsegno fixed bin (35) ext; dcl error_table_$no_linkage fixed bin (35) ext; dcl error_table_$noalloc fixed bin (35) ext; dcl error_table_$nrmkst fixed bin (35) ext; dcl error_table_$termination_requested fixed bin (35) ext; dcl pds$clr_stack_size (0:7) fixed bin (18) ext; dcl pds$lot_stack_size (0:7) fixed bin (17) ext; dcl pds$max_lot_size (0:7) fixed bin (17) ext; dcl pds$stacks (0:7) ptr ext; dcl sys_info$max_seg_size ext fixed bin (19); /* Builtins */ dcl (addr, addrel, baseno, bin, bit, divide, max, mod, null, ptr, size, segno, string, substr, wordno) builtin; /* Conditions */ dcl area condition; dcl cleanup condition; /* Based */ dcl based_area area (100) based; dcl based_array (nwords) bit (36) aligned based; dcl based_ptr ptr based; dcl based_word fixed bin based; dcl linkage_section (oi.llng) bit (36) aligned based; dcl static_section (oi.ilng) bit (36) aligned based; %page; /* EXECUTION OF LINK_MAN$OTHER_LINKAGE BEGINS HERE */ cl_sw = "0"b; acode = 0; txp = atxp; alp = null; astp = null; asymbp = null; ring = level$get (); /* Now get the target ring of the linkage fault, i.e. the ring in which the snapped link will be relevant */ /* The following sequence of code (through the reference to sdw.r3) should be replaced by a call to fs_get$brackets when that entry becomes efficient */ retry: code = txp -> based_word; /* touch the segment to make SDW valid */ call sdw_util_$dissect (addr (dseg$ (segno (txp))), addr (sdwi)); if sdwi.faulted then /* try again */ goto retry; cl = sdwi.gate_entry_bound + 1; /* get offset of linkage pointer in ring zero gates */ rings (1) = bin (sdwi.r1, 3); /* copy ring numbers */ rings (2) = bin (sdwi.r2, 3); rings (3) = bin (sdwi.r3, 3); if ring < rings (1) then target = rings (1); /* calculate target ring ... */ else if ring > rings (2) then target = rings (2); else target = ring; if target = 0 then do; /* snapping a link to hardcore gate */ alp = ptr (txp, cl + mod (cl, 2)) -> based_ptr; /* fetch linkage pointer from text */ return; /* that's all for hardcore gates */ end; target_sp = get_sp (target); lp = null; call getlp (target_sp, txp, lp, stp); if lp ^= null then do; /* yes, just return */ ret: alp = lp; astp = stp; asymbp = lp -> header.symbol_ptr; addr (alp) -> its_unsigned.ringno = target; /* So we can link to gates */ return; end; cl_join: call status_$mins (txp, type, count, code); /* get bit count for object info call */ if code ^= 0 then goto error; code = error_table_$bad_segment; oi.version_number = object_info_version_2; /* set version number of structure */ oi.symbp = null; /* in case object_info_ doesn't fill it in */ if count > 0 then call object_info_$brief (txp, count, addr (oi), code); if code = error_table_$bad_segment then do; /* all format flags are turned off */ acode = error_table_$no_linkage; return; end; else if code ^= 0 then do; error: acode = code; return; end; tcode = 1; if oi.linkp -> its.its_mod = "100011"b then lp, stp = oi.linkp; /* .link segment; pre-initialized when created */ else do; on area call terminate_proc (error_table_$noalloc); allocate linkage_section in (target_sp -> stack_header.clr_ptr -> based_area) set (lp); dummy = lp -> linkage_section (oi.llng); /* avoid bounds fault during EIS copy */ lp -> linkage_section = oi.linkp -> linkage_section; lp -> header.original_linkage_ptr = oi.linkp; if lp -> virgin_linkage_header.first_ref_relp then lp -> virgin_linkage_header.first_ref_relp = "000000000001000000"b; /* replace offset with flag */ if oi.separate_static then do; /* must copy static separately */ lp -> header.stats.static_length = bit (bin (oi.ilng, 18), 18); allocate static_section in (target_sp -> stack_header.combined_stat_ptr -> based_area) set (stp); dummy = stp -> static_section (oi.ilng);/* avoid bounds fault during EIS copy */ stp -> static_section = oi.statp -> static_section; end; else do; /* combined static already copied */ lp -> header.stats.static_length = bit (bin (bin (lp -> header.stats.begin_links, 18) - size (header), 18), 18); /* static section is between header & first link */ stp = lp; end; lp -> header.stats.segment_number = baseno (txp); lp -> header.symbol_ptr = oi.symbp; end; call setlp (txp, lp, stp, target); substr (lp -> its.pad2, 9, 1) = oi.perprocess_static; /* set flag in 1st word of def_ptr for run unit manager */ if cl_sw then return; /* no output arguments for this entry */ goto ret; %page; combine_linkage: entry (atxp, aring, acode); /* This entry is available through hcs_ and is intended for the lot_fault handler */ cl_sw = "1"b; txp = atxp; target = aring; if target ^= level$get () then do; /* caller must set level to correct ring */ acode = error_table_$badringno; return; end; target_sp = get_sp (target); acode = 0; lp = null; goto cl_join; %page; own_linkage: entry (atxp, alp, astp, asymbp, acode); /* Entry to return information about a segment and its linkage which has been set up earlier in the process */ acode = 0; txp = atxp; alp, astp, asymbp = null; ring = level$get (); sb = get_sp (ring); call getlp (sb, txp, lp, stp); if lp = null then do; acode = error_table_$no_linkage; return; end; ; alp = lp; astp = stp; asymbp = lp -> header.symbol_ptr; return; %page; /* SET_LP " */ set_lp: entry (atxp, alp); /* This entry is obsolete. It is used by the trap-before-link stuff, however, and must be supported. The callers of the entry must assume that no separate static will be allocated, hence, the static pointer passed to setlp is the same as the linkage pointer. */ ring = level$get (); call setlp (atxp, alp, alp, ring); return; %page; /* GET_LP " */ get_lp: entry (atxp, alp); /* OBSOLETE */ ring = level$get (); /* get caller's validation level */ sb = get_sp (ring); call getlp (sb, atxp, alp, (null)); return; %page; /* ASSIGN_LINKAGE " */ assign_linkage: entry (aamount, rp, rcode); dcl aamount fixed bin (18); dcl rcode fixed bin (35); dcl rp ptr; rcode = 0; rp = null; on area go to a_l_error; sb = get_sp ((level$get ())); nwords = aamount; allocate based_array in (sb -> stack_header.assign_linkage_ptr -> based_area) set (rp); /* must go in same seg as ipc static */ return; a_l_error: rcode = error_table_$noalloc; return; %page; /* GET_INITIAL_LINKAGE " */ get_initial_linkage: entry (aring); /* This entry is called only by makestack when a new ring is being created. The program makestack may have been called by link_man. */ sp = pds$stacks (aring); stack_end = wordno (sp -> stack_header.stack_end_ptr); /* allocate space for lot in stack */ nwords = pds$lot_stack_size (aring); if nwords = 0 then nwords = 512; /* force 512 word lot in stack */ lotp = sp; /* unused part of lot overlays stack header */ sp -> stack_header.cur_lot_size = nwords; stack_end = max (stack_end, nwords * 2); /* the "2" is for isot as well as lot */ stack_end = divide (stack_end + 15, 16, 17, 0) * 16; /* round up */ /* set up linkage section area */ if pds$clr_stack_size (aring) > 0 then do; /* initial area is in stack */ ainfo.size = pds$clr_stack_size (aring); ainfo.areap = ptr (sp, stack_end); stack_end = stack_end + ainfo.size; /* update length of stack */ stack_end = divide (stack_end + 15, 16, 17, 0) * 16; /* round up */ end; else do; /* clr is to go into separate seg */ ainfo.size = sys_info$max_seg_size; ainfo.areap = null; end; ainfo.version = area_info_version_1; string (ainfo.control) = "0"b; ainfo.control.extend = "1"b; ainfo.control.zero_on_free = "1"b; ainfo.control.system = "1"b; ainfo.owner = "linker"; call define_area_ (addr (ainfo), code); if code ^= 0 then call terminate_proc (error_table_$termination_requested); sp -> stack_header.max_lot_size = pds$max_lot_size (aring); sp -> stack_header.stack_end_ptr = ptr (sp, stack_end); sp -> stack_header.stack_begin_ptr = ptr (sp, stack_end); sp -> stack_header.lot_ptr = lotp; sp -> stack_header.isot_ptr = addrel (lotp, sp -> stack_header.cur_lot_size); sp -> stack_header.sct_ptr = addrel (lotp, sp -> stack_header.cur_lot_size); sp -> stack_header.system_free_ptr, sp -> stack_header.user_free_ptr, sp -> stack_header.assign_linkage_ptr, sp -> stack_header.clr_ptr, sp -> stack_header.combined_stat_ptr = ainfo.areap; sp -> stack_header.heap_header_ptr = null; sp -> stack_header.sys_link_info_ptr = null; return; %page; grow_lot: entry (a_ring); /* This entry is for initiate to call if it needs to before setting a lot_fault */ dcl a_ring fixed bin (3); dcl grow_lot_invalid_ring_ condition; ring = a_ring; if ring ^= level$get () then signal grow_lot_invalid_ring_; call make_lot (ring); return; %page; setlp: proc (txp, lp, stp, ring); dcl lp ptr; dcl ring fixed bin; dcl stp ptr; dcl txp ptr; dcl segnum fixed bin; dcl shp ptr; shp = get_sp (ring); segnum = segno (txp); if segnum >= shp -> stack_header.cur_lot_size then do; if segnum > shp -> stack_header.max_lot_size then do; code = error_table_$invalidsegno; go to error; end; call make_lot (ring); /* new lot will be max lot size */ end; call segno_usage$increment_other_ring (segnum, ring, code); /* setting linkage for segment in target ring is a good reason to hold segment - prevents termination of lower ring gates */ shp -> stack_header.lot_ptr -> lot.lp (segnum) = lp; shp -> stack_header.isot_ptr -> isot.isp (segnum) = stp; if baseno (lp) = "0"b then return; /* just zeroing slot */ /* don't disturb flags in lower half of 2nd word in linkage header */ if lp -> its.its_mod = "100011"b then return; /* def ptr already set */ else if lp -> its.its_mod = "0"b then lp -> its_unsigned.segno = segno (txp); /* defs in text */ else do; /* defs in linkage after links */ lp -> its_unsigned.segno = segno (lp); lp -> its_unsigned.offset = lp -> its_unsigned.offset + wordno (lp); end; lp -> its.its_mod = "100011"b; /* turn it into a pointer */ return; end setlp; %page; getlp: proc (gsp, gtxp, glp, gstp); dcl (glp, gsp, gstp, gtxp) ptr; dcl segnum fixed bin; glp, gstp = null; /* assume the worst */ segnum = segno (gtxp); if segnum >= gsp -> stack_header.cur_lot_size then return; /* lot isn't that big in this ring */ if baseno (gsp -> stack_header.lot_ptr -> lot.lp (segnum)) /* non-zero lot entry? */ then glp = gsp -> stack_header.lot_ptr -> lot.lp (segnum); else return; /* no linkage for this segno */ if baseno (gsp -> stack_header.isot_ptr -> isot.isp (segnum)) ^= "0"b then gstp = gsp -> stack_header.isot_ptr -> isot.isp (segnum); return; end; %page; make_lot: proc (ring); dcl ring fixed bin; dcl lotp ptr; dcl newisotp ptr; dcl newlotp ptr; dcl save_max_lot_size fixed bin; dcl sp ptr; /* This procedure is called to make a larger LOT than the initial lot given a process. It assumes the stack, lot, and clr are already there and makes a new lot by allocating one in the current linkage region. */ sp = pds$stacks (ring); lotp = sp -> stack_header.lot_ptr; if sp -> stack_header.cur_lot_size >= sp -> stack_header.max_lot_size then call terminate_proc (error_table_$nrmkst); nwords = 2 * sp -> stack_header.max_lot_size; /* Set stack_header.max_lot_size temporarily so that we won't be called recursively. Otherwise, this could happen if a segment is created to satisfy the allocate */ save_max_lot_size = sp -> stack_header.max_lot_size; sp -> stack_header.max_lot_size = sp -> stack_header.cur_lot_size; on cleanup begin; /* in case of crawlout */ sp -> stack_header.max_lot_size = save_max_lot_size; end; allocate based_array in (sp -> stack_header.clr_ptr -> based_area) set (newlotp); sp -> stack_header.max_lot_size = save_max_lot_size; revert cleanup; newisotp = addrel (newlotp, sp -> stack_header.max_lot_size); nwords = sp -> stack_header.cur_lot_size; newlotp -> based_array = lotp -> based_array; newisotp -> based_array = sp -> stack_header.isot_ptr -> based_array; sp -> stack_header.cur_lot_size = sp -> stack_header.max_lot_size; sp -> stack_header.lot_ptr = newlotp; sp -> stack_header.isot_ptr = newisotp; return; end make_lot; %page; get_sp: proc (ring) returns (ptr); /* This procedure returns a pointer to the initial stack in a ring */ dcl ring fixed bin; if pds$stacks (ring) = null then call makestack (ring); return (pds$stacks (ring)); end; %page; %include area_info; %include its; %include linkdcl; %include lot; %include object_info; %include sdw_info; %include stack_header; end;  link_snap.pl1 11/11/89 1132.4rew 11/11/89 0800.0 613602 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-05-02,Elhard), approve(86-05-02,MCR7391), audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222): Rewritten to support object multisegment files. In particular, support of indirect definitions, deferred initialization, partial links, and preliminary support for *heap links. 2) change(86-06-24,DGHowe), approve(86-06-24,MCR7396), audit(86-11-05,Elhard), install(86-11-20,MR12.0-1222): added a check for heap links and a call to set_ext_variable_$star_heap when a heap link is found. 3) change(86-06-24,DGHowe), approve(86-06-24,MCR7420), audit(86-11-05,Elhard), install(86-11-20,MR12.0-1222): added a segment pointer to the calling sequences of for_linker and star_heap for ext pointer initialization. 4) change(87-06-10,Elhard), approve(87-07-17,MCR7739), audit(87-06-10,RWaters), install(87-07-17,MR12.1-1043): Critical fix to correct snapping of CREATE_IF_NOT_FOUND (type 6) links to targets with no offset name, or nonexistent targets. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll79,initcol0,dclind4,idind24,struclvlind1,comcol41 */ link_snap: proc; /*** ****************************************************************/ /*** */ /*** Name: link_snap */ /*** Input: none */ /*** Function: This procedure implements the Multics dynamic */ /*** linking mechanism. Four entries exist in this */ /*** procedure: */ /*** link_snap$link_fault - This entry is called as */ /*** due to a fault_tag_2 */ /*** (linkage) fault. */ /*** link_snap$link_force - This entry corresponds */ /*** to the hcs_$link_force */ /*** gate entry. It basicly */ /*** duplicates the action of */ /*** a link_fault without */ /*** taking a fault. */ /*** link_snap$make_ptr - This entry corresponds */ /*** to the hcs_$make_ptr */ /*** gate entry. It simulates */ /*** a type-3 or type-4 link */ /*** fault and returns the */ /*** target as a pointer. */ /*** link_snap$make_entry - This entry corresponds */ /*** to the hcs_$make_entry */ /*** gate entry. It simulates */ /*** a type-3 or type-4 link */ /*** fault and returns the */ /*** target as an entry value */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); dcl indirect bit (6) static options (constant) init ("20"b3); dcl Link_fault fixed bin static options (constant) init (1); dcl Link_force fixed bin static options (constant) init (2); dcl Make_ptr fixed bin static options (constant) init (3); dcl Make_entry fixed bin static options (constant) init (4); dcl No_retry bit (1) static options (constant) init ("0"b); dcl Will_retry bit (1) static options (constant) init ("1"b); dcl zero_word bit (36) static options (constant) init (""b); dcl None fixed bin (18) unsigned unaligned static options (constant) init (0); /* parameters */ dcl a_mcp ptr parameter; dcl a_link_pairp ptr parameter; dcl a_dummy fixed bin parameter; dcl a_code fixed bin (35) parameter; dcl a_refp ptr parameter; dcl a_seg_name char (*) parameter; dcl a_offset_name char (*) parameter; dcl a_targetp ptr parameter; dcl a_targete entry parameter; /* procedures */ dcl condition_ entry (char (*), entry); dcl fs_search entry (ptr, char (*), bit (1) aligned, ptr, fixed bin (35)); dcl fs_search$same_directory entry (ptr, char (*), ptr, fixed bin (35)); dcl get_defptr_ entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl level$get entry () returns (fixed bin (3)); dcl level$set entry (fixed bin (3)); dcl link_man$other_linkage entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl link_man$own_linkage entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl page$enter_data entry (ptr unal, fixed bin); dcl set_ext_variable_$for_linker entry (char (*), ptr, ptr, ptr, bit (1) aligned, ptr, fixed bin (35), ptr, ptr, ptr, ptr); dcl set_ext_variable_$star_heap entry (char (*), ptr, ptr, ptr, bit (1) aligned, ptr, fixed bin (35)); dcl trap_caller_caller_ entry (ptr, ptr, ptr, ptr, ptr, ptr, fixed bin (35)); dcl usage_values entry (fixed bin (30) aligned, fixed bin (71) aligned); /* external */ dcl 01 ahd$link_meters (4) aligned external like link_meters; dcl error_table_$bad_class_def external fixed bin (35); dcl error_table_$bad_deferred_init external fixed bin (35); dcl error_table_$bad_indirect_def external fixed bin (35); dcl error_table_$bad_link_type external fixed bin (35); dcl error_table_$bad_self_ref external fixed bin (35); dcl error_table_$first_reference_trap external fixed bin (35); dcl error_table_$illegal_ft2 external fixed bin (35); dcl error_table_$no_defs external fixed bin (35); dcl error_table_$no_ext_sym external fixed bin (35); dcl error_table_$no_linkage external fixed bin (35); dcl error_table_$unexpected_ft2 external fixed bin (35); dcl pds$link_meters_bins (4) external fixed bin (30); dcl pds$link_meters_pgwaits (4) external fixed bin (30); dcl pds$link_meters_times (4) external fixed bin (35); dcl pds$stacks (0:7) external ptr; /* based */ dcl 01 based_entry aligned based, 02 code_ptr ptr, 02 env_ptr ptr; dcl 01 expr aligned like exp_word based (exprp); dcl 01 link_pair aligned like object_link based (link_pairp); dcl 01 offsetname aligned based (offsetnamep), 02 count fixed bin (9) unsigned unaligned, 02 string char (offsetname.count) unaligned; dcl 01 segname aligned based (segnamep), 02 count fixed bin (9) unsigned unaligned, 02 string char (segname.count) unaligned; dcl 01 type_pr aligned like type_pair based (type_prp); dcl 01 usage aligned based, 02 time fixed bin (71), 02 pf fixed bin (30); /* automatic */ dcl 01 automatic_offsetname aligned automatic, 02 count fixed bin (9) unsigned unaligned, 02 string char (256) unaligned; dcl 01 automatic_segname aligned automatic, 02 count fixed bin (9) unsigned unaligned, 02 string char (32) unaligned; dcl 01 call_info aligned automatic, 02 type fixed bin, 02 save_ring fixed bin, 02 mcp ptr, 02 codep ptr, 02 start aligned like usage, 02 finish aligned like usage, 02 search aligned like usage, 02 get_linkage aligned like usage, 02 def_search aligned like usage; dcl call_infop ptr automatic; dcl code fixed bin (35) automatic; dcl connect_fail_code fixed bin (35) automatic; dcl defp ptr automatic; dcl exprp ptr automatic; dcl init_infop ptr automatic; dcl instrp ptr automatic; dcl link_pairp ptr automatic; dcl linkp ptr automatic; dcl nchars fixed bin automatic; dcl offset_name char (256) automatic; dcl offsetnamep ptr automatic; dcl refp ptr automatic; dcl retry_sw bit (1) automatic; dcl seg_name char (32) automatic; dcl segnamep ptr automatic; dcl segp ptr automatic; dcl star_system_sw bit (1) automatic; dcl target_linkagep ptr automatic; dcl targetp ptr automatic; dcl textp ptr automatic; dcl type_prp ptr automatic; dcl MSF_sw bit (1) aligned automatic; /* builtin */ dcl addr builtin; dcl addrel builtin; dcl baseno builtin; dcl baseptr builtin; dcl bin builtin; dcl char builtin; dcl divide builtin; dcl index builtin; dcl length builtin; dcl ltrim builtin; dcl max builtin; dcl min builtin; dcl null builtin; dcl ptr builtin; dcl rtrim builtin; dcl substr builtin; dcl unspec builtin; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ link_fault: entry (a_mcp); /** machine conditions (i/o) */ /*** ****************************************************************/ /*** */ /*** Name: link_snap$link_fault */ /*** Input: mcp */ /*** Function: handles a fault_tag_2 (linkage) fault. The mcp */ /*** pointer points to the machine conditions at the */ /*** time of the fault. If the link snapping is */ /*** successfull, the machine conditions will be */ /*** adjusted to allow the fault to be restarted. */ /*** Output: mcp */ /*** */ /*** ****************************************************************/ /* copy the parameters into automatic storage */ mcp = a_mcp; call_infop = addr (call_info); call_info.type = Link_fault; call_info.mcp = mcp; call_info.save_ring = level$get (); /* since this is a fault, the trap routines can't set a return code */ call_info.codep = null; /* set validation level to the level that the fault occurred at */ scup = addr (mc.scu (0)); call level$set (bin (scu.ppr.prr, 3)); /* get a pointer to the faulting link pair and instruction */ link_pairp = ptr (baseptr (bin (scu.tpr.tsr, 15)), scu.ca); instrp = ptr (baseptr (bin (scu.ppr.psr, 15)), scu.ilc); /* trace the fault */ call page$enter_data ((instrp), linkage_fault_start); /* make sure the fault_tag_2 wasn't in an instruction */ if instrp -> its.its_mod = FAULT_TAG_2 then call exit (call_infop, error_table_$unexpected_ft2, null); goto link_join; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ link_force: entry (a_link_pairp, /** ptr to link to snap (in ) */ a_dummy, /** unused (---) */ a_code); /** error code (out) */ /*** ****************************************************************/ /*** */ /*** Name: link_snap$link_force */ /*** Input: link_pairp */ /*** Function: given a pointer to a link, snap it without taking */ /*** a fault. This entry is functionally the same as */ /*** link_snap$link_fault except that it is entered */ /*** via gate call rather than fault entry. */ /*** Output: code */ /*** */ /*** ****************************************************************/ /* not a fault entry */ mcp = null; /* copy parameters into automatic storage */ link_pairp = a_link_pairp; /* set up call info */ call_infop = addr (call_info); call_info.type = Link_force; call_info.mcp = null; call_info.save_ring = -1; /* save error code address in case we trap out to the user ring and */ /* the trap procedure needs to set the error code. */ call_info.codep = addr (a_code); /* for a link_force call, we use the link itself as the start point */ /* for tracing purposes. */ call page$enter_data ((link_pairp), linkage_fault_start); /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ link_join: /* clear out the metering information */ call_info.search.time = 0; call_info.search.pf = 0; call_info.get_linkage.time = 0; call_info.get_linkage.pf = 0; call_info.def_search.time = 0; call_info.def_search.pf = 0; /* meter the fault time etc. */ call usage_values (call_info.start.pf, call_info.start.time); if link_pair.tag ^= FAULT_TAG_2 then if call_info.type = Link_force then call exit (call_infop, 0, baseptr (0)); else call exit (call_infop, error_table_$illegal_ft2, null); /* get the linkage section and text pointers */ linkp = addrel (link_pairp, link_pair.header_relp); textp = baseptr (linkp -> linkage_header.stats.segment_number); target_linkagep = null; /* validate the definition pointer */ if addr (linkp -> linkage_header.def_ptr) -> its.its_mod ^= ITS_MODIFIER then call exit (call_infop, error_table_$no_defs, null); else defp = linkp -> linkage_header.def_ptr; /* validate that all first reference traps have been run */ if linkp -> virgin_linkage_header.first_ref_relp ^= 0 then call exit (call_infop, error_table_$first_reference_trap, null); /* now that things look reasonably valid, we start decoding the link */ exprp = addrel (defp, link_pair.expression_relp); type_prp = addrel (defp, expr.type_relp); /* first we check the link to see if it should be converted into a */ /* *system link. Trap-before links to datmk_ and certain type-6 */ /* links are converted to *system links. */ call convert_trap_link (call_infop, linkp, defp, type_prp, offset_name, init_infop, star_system_sw); if star_system_sw then do; /* the link either was a *system link, or has become one */ call star_system (call_infop, link_pairp, defp, linkp, type_prp, offset_name, init_infop, targetp); call snap (targetp, (expr.expression), link_pairp); call meter (call_infop, (type_pr.type)); call exit (call_infop, 0, targetp); end; /* see if we have a C *heap link */ if type_pr.type = LINK_SELF_OFFSETNAME & type_pr.segname_relp = CLASS_HEAP then do; /* C *heap links are similar to *system links except that they */ /* are allocated separately, and have a level associated with */ /* them so that recursive invocations get new copies and they */ /* can be released when the invocation returns. */ call star_heap (call_infop, defp, linkp, type_prp, targetp); call snap (targetp, (expr.expression), link_pairp); call meter (call_infop, (type_pr.type)); call exit (call_infop, 0, targetp); end; /* now see if there is a trap pointer. Anything with a trap */ /* pointer that wasn't converted to a *system link, and isn't a */ /* create link, we now treat as a trap-before link, and try to run */ /* the trap. */ if type_pr.type ^= LINK_CREATE_IF_NOT_FOUND & type_pr.trap_relp ^= None then do; /* actually is a trap-before link, trap out to the user */ /* ring to execute the trap procedure. */ /* NB. We don't try to complete tracing or metering in this */ /* case since it would be rather meaningless anyway. . . */ call adjust_mc (mcp); call trap_caller_caller_ (mcp, linkp, defp, type_prp, link_pairp, call_info.codep, code); /* usually we don't return, but. . . */ call exit (call_infop, code, baseptr (0)); end; /* at this point we assume we have a reasonably standard link and */ /* can just snap it according to type. */ if /* case */ type_pr.type = LINK_SELF_BASE then do; call self_reference (call_infop, (type_pr.segname_relp), textp, targetp); call snap (targetp, (expr.expression), link_pairp); call meter (call_infop, (type_pr.type)); call exit (call_infop, 0, targetp); end; else if type_pr.type = LINK_OBSOLETE_2 then call exit (call_infop, error_table_$bad_link_type, null); else if type_pr.type = LINK_REFNAME_BASE then do; segnamep = addrel (defp, type_pr.segname_relp); if defp -> definition_header.msf_map_relp ^= None then MSF_sw = true; else MSF_sw = false; call search_for_segment (call_infop, segnamep, textp, MSF_sw, segp, code); if segp = null then call exit (call_infop, code, null); call snap (segp, (expr.expression), link_pairp); call meter (call_infop, (type_pr.type)); call exit (call_infop, 0, segp); end; else if type_pr.type = LINK_REFNAME_OFFSETNAME then do; segnamep = addrel (defp, type_pr.segname_relp); if defp -> definition_header.msf_map_relp ^= None then MSF_sw = true; else MSF_sw = false; call search_for_segment (call_infop, segnamep, textp, MSF_sw, segp, code); if segp = null then call exit (call_infop, code, null); call condition_ ("seg_fault_error", connect_fail_handler_); call get_offsetnamep (call_infop, defp, type_prp, offsetnamep); call get_definition (call_infop, segnamep, offsetnamep, segp, No_retry, target_linkagep, targetp); call snap (targetp, (expr.expression), link_pairp); call meter (call_infop, (type_pr.type)); call trap (call_infop, target_linkagep, targetp); call exit (call_infop, 0, targetp); end; else if type_pr.type = LINK_SELF_OFFSETNAME then do; call self_reference (call_infop, (type_pr.segname_relp), textp, targetp); /* insure that segname won't be found */ segnamep = addr (zero_word); call get_offsetnamep (call_infop, defp, type_prp, offsetnamep); call get_definition (call_infop, segnamep, offsetnamep, textp, No_retry, (null), targetp); call snap (targetp, (expr.expression), link_pairp); call meter (call_infop, (type_pr.type)); call exit (call_infop, 0, targetp); end; else if type_pr.type = LINK_CREATE_IF_NOT_FOUND then do; /* NB. since we have already processed the trap case, we will */ /* assume that this link can be treated as a type-4 until */ /* something breaks. */ segnamep = addrel (defp, type_pr.segname_relp); if defp -> definition_header.msf_map_relp ^= None then MSF_sw = true; else MSF_sw = false; call search_for_segment (call_infop, segnamep, textp, MSF_sw, segp, code); if segp = null then do; /* OK. something broke. now we try to treat this as a */ /* *system link so that the caller will get something. */ call get_offsetnamep (call_infop, defp, type_prp, offsetnamep); if offsetnamep = null then offset_name = segname.string || "$"; else offset_name = segname.string || "$" || offsetname.string; if type_pr.trap_relp = 0 then init_infop = null; else init_infop = addrel (defp, type_pr.trap_relp); call star_system (call_infop, link_pairp, defp, linkp, type_prp, offset_name, init_infop, targetp); call snap (targetp, (expr.expression), link_pairp); call meter (call_infop, (type_pr.type)); call exit (call_infop, 0, targetp); end; call condition_ ("seg_fault_error", connect_fail_handler_); call get_offsetnamep (call_infop, defp, type_prp, offsetnamep); /* dont try to do a definition search if no entrypoint name was given */ if offsetnamep ^= null then call get_definition (call_infop, segnamep, offsetnamep, segp, No_retry, target_linkagep, targetp); else targetp = segp; call snap (targetp, (expr.expression), link_pairp); call meter (call_infop, (type_pr.type)); call trap (call_infop, target_linkagep, targetp); call exit (call_infop, 0, targetp); end; else call exit (call_infop, error_table_$bad_link_type, null); /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ make_ptr: entry (a_refp, /** referencing dir ptr (in ) */ a_seg_name, /** segname to find (in ) */ a_offset_name, /** entrypoint to find (in ) */ a_targetp, /** target ptr returned (out) */ a_code); /** error code (out) */ /*** ****************************************************************/ /*** */ /*** Name: link_snap$make_ptr */ /*** Input: refp, seg_name, offset_name */ /*** Function: Using the segname and optional offsetname given, */ /*** snap a simulated type-3 (if a null offsetname) */ /*** or type-4 (if non-null) link and return a pointer */ /*** to the target. The reference pointer is passed */ /*** to fs_search in order to evaluate the referencing */ /*** dir search rule. If it is null, the referencing */ /*** dir rule is skipped. */ /*** Output: targetp, code */ /*** */ /*** ****************************************************************/ /* preset the return values */ a_targetp = null; /* set up the call info */ call_info.type = Make_ptr; goto make_join; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ make_entry: entry (a_refp, /** referencing dir ptr (in ) */ a_seg_name, /** segname to find (in ) */ a_offset_name, /** entrypoint to find (in ) */ a_targete, /** entry returned (out) */ a_code); /** error code (out) */ /*** ****************************************************************/ /*** */ /*** Name: link_snap$make_entry */ /*** Input: refp, seg_name, offset_name */ /*** Function: performs the same function as link_snap$make_ptr */ /*** except that an entry value is returned instead of */ /*** a pointer value. The other difference between */ /*** calling make_entry and make_ptr is that if the */ /*** offsetname value is null on a call to make_entry */ /*** the target linkage section is combined and any */ /*** first reference traps run. This is because it is */ /*** assumed that if you want an entry returned, you */ /*** plan on calling it, and to call it the linkage */ /*** section should be combined. */ /*** Output: targete, code */ /*** */ /*** ****************************************************************/ call_info.type = Make_entry; /* preset the returned entry */ addr (a_targete) -> based_entry.code_ptr = null; addr (a_targete) -> based_entry.env_ptr = null; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ make_join: /* meter and trace the make_ptr/make_entry call */ call usage_values (call_info.start.pf, call_info.start.time); call page$enter_data (baseptr (0), linkage_fault_start); /* clear out the metering information */ call_info.search.time = 0; call_info.search.pf = 0; call_info.get_linkage.time = 0; call_info.get_linkage.pf = 0; call_info.def_search.time = 0; call_info.def_search.pf = 0; /* set up the common call_info stuff */ call_infop = addr (call_info); call_info.codep = addr (a_code); call_info.mcp, mcp = null; call_info.save_ring = -1; /* copy the args into automatic storage */ refp = a_refp; seg_name = a_seg_name; offset_name = a_offset_name; /* preset the return code */ a_code = 0; /* try to determine whether the ref pointer refers to an MSF */ if refp = null then MSF_sw = false; else do; call link_man$own_linkage (ptr (refp, 0), linkp, null, null, code); if code ^= 0 then MSF_sw = false; else if addr (linkp -> linkage_header.def_ptr) -> its.its_mod ^= ITS_MODIFIER then MSF_sw = false; else do; defp = linkp -> linkage_header.def_ptr; if defp -> definition_header.msf_map_relp ^= None then MSF_sw = true; else MSF_sw = false; end; end; /* search for the segment */ call fs_search (refp, seg_name, MSF_sw, segp, code); if code ^= 0 then call exit (call_infop, code, null); /* set up to handle connection failure gracefully */ call condition_ ("seg_fault_error", connect_fail_handler_); nchars = length (rtrim (offset_name)); if nchars = 0 then do; /* no offsetname, so just meter, finish tracing and return */ if call_info.type = Make_ptr then call meter (call_infop, (LINK_REFNAME_BASE)); else do; /* if we are returning an entry, we must combine the */ /* target linkage section first. If we combine the linkage */ /* section we should run any first reference traps. */ call combine_linkage (call_infop, segp, (null), target_linkagep, (null), (null)); call meter (call_infop, (LINK_REFNAME_BASE)); call trap (call_infop, target_linkagep, segp); end; call exit (call_infop, 0, segp); end; /* set up the segname/offsetname pointers */ segnamep = addr (automatic_segname); offsetnamep = addr (automatic_offsetname); /* clear them out */ unspec (automatic_segname) = ""b; unspec (automatic_offsetname) = ""b; /* save the passed segname/offsetname values */ automatic_segname.count = length (rtrim (seg_name)); substr (automatic_segname.string, 1, automatic_segname.count) = substr (seg_name, 1, automatic_segname.count); automatic_offsetname.count = length (rtrim (offset_name)); substr (automatic_offsetname.string, 1, automatic_offsetname.count) = substr (offset_name, 1, automatic_offsetname.count); /* if the offsetname and segname are the same, we want */ /* get_definition to retry using the offsetname "main_" */ /* if this attempt fails */ if seg_name = offset_name then retry_sw = Will_retry; else retry_sw = No_retry; call get_definition (call_infop, segnamep, offsetnamep, segp, retry_sw, target_linkagep, targetp); call meter (call_infop, (LINK_REFNAME_OFFSETNAME)); call trap (call_infop, target_linkagep, targetp); call exit (call_infop, 0, targetp); /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ convert_trap_link: proc (infop, /** call info pointer (in ) */ linkp, /** linkage pointer (in ) */ defp, /** definition pointer (in ) */ type_prp, /** type_pair pointer (in ) */ offset_name, /** entrypoint name (out) */ init_infop, /** init_info pointer (out) */ star_system_sw); /** *system or mapped (out) */ /*** ****************************************************************/ /*** */ /*** Name: convert_trap_link */ /*** Input: infop, linkp, defp, type_prp */ /*** Function: determines whether the link in question has a */ /*** trap_relp value. If it does, then the link is */ /*** a probably a *system link (type-5, class-5) or */ /*** should should be treated as one. If it is not */ /*** not a *system link, and should be, we determine */ /*** what the offset_name to be found is and what the */ /*** init_info pointer should be and then set the flag */ /*** to indicate that this is to be snapped as a */ /*** *system link. */ /*** Output: offset_name, init_infop, star_system_sw */ /*** */ /*** ****************************************************************/ /* parameters */ dcl infop ptr parameter; dcl linkp ptr parameter; dcl defp ptr parameter; dcl type_prp ptr parameter; dcl offset_name char (256) parameter; dcl init_infop ptr parameter; dcl star_system_sw bit (1) parameter; /* based */ dcl based_ptr ptr based; dcl 01 offsetname aligned based (offsetnamep), 02 count fixed bin (9) unsigned unaligned, 02 string char (offsetname.count) unaligned; dcl 01 segname aligned based (segnamep), 02 count fixed bin (9) unsigned unaligned, 02 string char (segname.count) unaligned; dcl 01 trap aligned like link_trap_pair based (trapp); dcl 01 type_pr aligned like type_pair based (type_prp); /* automatic */ dcl code fixed bin (35) automatic; dcl init_linkp ptr automatic; dcl offsetnamep ptr automatic; dcl segnamep ptr automatic; dcl trapp ptr automatic; segnamep = addrel (defp, type_pr.segname_relp); offsetnamep = addrel (defp, type_pr.offsetname_relp); /* preset output variables */ star_system_sw = false; offset_name = offsetname.string; if type_pr.trap_relp = None then init_infop = null; else init_infop = addrel (defp, type_pr.trap_relp); /* first see if it is actually a *system link */ if type_pr.type = LINK_SELF_OFFSETNAME & type_pr.segname_relp = CLASS_SYSTEM then do; star_system_sw = true; return; end; /* now check the conditions for converting a type 6 link */ if type_pr.type = LINK_CREATE_IF_NOT_FOUND then do; /* check for pl1 ext static */ if segname.string = "stat_" then do; star_system_sw = true; return; end; /* check for fortran common blocks */ if offsetname.count = 0 then if index (segname.string, ".com") = segname.count - 3 then do; star_system_sw = true; offset_name = substr (segname.string, 1, segname.count - 4); if offset_name = "b_" /* blank common */ then offset_name = "blnk*com"; return; end; else ; /* check for cobol FSB link */ else if segname.string = "cobol_fsb_" then do; offset_name = "cobol_fsb_" || offsetname.string; star_system_sw = true; return; end; end; if type_pr.type = LINK_REFNAME_OFFSETNAME & type_pr.trap_relp ^= None then do; /* if we have a type 4 link with a trap-before link to datmk_ */ /* we force-snap the info-link of the trap, use that as the */ /* init_info pointer and use the offsetname from the original */ /* link as the name and then treat as a *system link. */ trapp = addrel (defp, type_pr.trap_relp); if segname.string = "stat_" then if addrel (defp, addrel (defp, addrel (defp, addrel (linkp, trap.call_relp) -> object_link.expression_relp) -> exp_word.type_relp) -> type_pair.segname_relp) -> acc_string.string = "datmk_" then do; init_linkp = addrel (linkp, trap.info_relp); /* snap the info link */ call link_force (init_linkp, 0, code); if code ^= 0 then call exit (call_infop, code, null); init_infop = init_linkp -> based_ptr; star_system_sw = true; end; end; end convert_trap_link; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ star_system: proc (infop, /** call_info pointer (in ) */ link_pairp, /** pointer to link (in ) */ defp, /** definition pointer (in ) */ linkp, /** linkage pointer (in ) */ type_prp, /** type_pair pointer (in ) */ offset_name, /** ext var name string (in ) */ init_infop, /** init_info pointer (in ) */ targetp); /** target variable (out) */ /*** ****************************************************************/ /*** */ /*** Name: star_system */ /*** Input: infop, link_pairp, defp, linkp, type_prp, */ /*** offset_name, init_infop */ /*** Function: determines the target of a *system link. This */ /*** procedure calls set_ext_variable_ to return the */ /*** variable_node which defines the named external */ /*** variable, and then returns a pointer to the var */ /*** itself. */ /*** Output: targetp */ /*** */ /*** ****************************************************************/ /* parameters */ dcl infop ptr parameter; dcl link_pairp ptr parameter; dcl defp ptr parameter; dcl linkp ptr parameter; dcl type_prp ptr parameter; dcl offset_name char (256) parameter; dcl init_infop ptr parameter; dcl targetp ptr parameter; /* based */ dcl 01 info aligned like call_info based (infop); /* automatic */ dcl code fixed bin (35) automatic; dcl sb ptr automatic; /* set the stack base pointer */ if info.mcp = null then sb = pds$stacks (level$get ()); else sb = ptr (info.mcp -> mc.prs (6), 0); /* check to see if this variable has a deferred initialization type */ call deferred_init (infop, init_infop, linkp); /* now call set_ext_variable_ to get the variable node. Note that */ /* this call may not return if the target is an uninitialized VLA, */ /* since this requires a call to fortran_storage_manager_. We cant */ /* call this in ring 0 so we trap out to the user ring to call out */ /* to set up the VLA. The fortran_storage_manager_ is responsible */ /* for completing the link snap. */ call set_ext_variable_$for_linker (offset_name, init_infop, sb, ptr (init_infop, 0), ("0"b), targetp, code, info.mcp, def_ptr, type_prp, link_pairp); if code ^= 0 then call exit (infop, code, null); /* get a pointer to the actual variable instead of the node */ targetp = targetp -> variable_node.vbl_ptr; end star_system; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ star_heap: proc (infop, /** call_info pointer (in ) */ defp, /** def section ptr (in ) */ linkp, /** linkage section ptr (in ) */ type_prp, /** type_pair pointer (in ) */ targetp); /** target pointer (out) */ /*** ****************************************************************/ /*** */ /*** Name: star_heap */ /*** Input: infop, defp, linkp, type_prp */ /*** Function: given a pointer to the type_pair and definition */ /*** section for a link, get the offsetname and init */ /*** info pointer and call set_ext_variable_$star_heap */ /*** to find or create the variable. */ /*** Output: targetp */ /*** */ /*** ****************************************************************/ /* parameters */ dcl infop ptr parameter; dcl defp ptr parameter; dcl linkp ptr parameter; dcl type_prp ptr parameter; dcl targetp ptr parameter; /* based */ dcl 01 info aligned like call_info based (infop); dcl 01 offsetname aligned based (offsetnamep), 02 count fixed bin (9) unsigned unaligned, 02 string char (offsetname.count) unaligned; dcl 01 type_pr aligned like type_pair based (type_prp); /* automatic */ dcl init_infop ptr automatic; dcl offsetnamep ptr automatic; dcl sb ptr automatic; dcl offset_name char (256) automatic; /* extract the variable name and init_info pointer */ offsetnamep = addrel (defp, type_pr.offsetname_relp); offset_name = offsetname.string; if type_pr.trap_relp = None then init_infop = null; else init_infop = addrel (defp, type_pr.trap_relp); /* get the stack base pointer */ if info.mcp = null then sb = pds$stacks (level$get ()); else sb = ptr (info.mcp -> mc.prs (6), 0); /* get new init_info pointer if initialization type = INIT_DEFERRED */ call deferred_init (infop, init_infop, linkp); /* call set_ext_variable_$star_heap to allocate the variable and */ /* return a node ptr */ call set_ext_variable_$star_heap (offset_name, init_infop, sb, ptr (init_infop, 0), ("0"b), targetp, code); if code ^= 0 then call exit (infop, code, null); /* set the target to point to the variable itself */ targetp = targetp -> variable_node.vbl_ptr; end star_heap; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ deferred_init: proc (infop, /** call_info pointer (in ) */ init_infop, /** init_info pointer (i/o) */ linkp); /** linkage section ptr (in ) */ /*** ****************************************************************/ /*** */ /*** Name: deferred_init */ /*** Input: infop, init_infop, linkp */ /*** Function: locates the initialization info for deferred init */ /*** external or heap initialization. The procedure */ /*** for deferred initialization is as follows: */ /*** - check to see if the init type is deferred. */ /*** - if so, extract the target_relp and link_relp */ /*** from the init_info. */ /*** - make sure the link referenced by target_relp */ /*** has been snapped. */ /*** - chase the link to find the target segments */ /*** linkage header. */ /*** - extract the def_ptr and original_linkage_ptr */ /*** from the linkage_header. */ /*** - apply the link_relp to the original_linkage */ /*** pointer to find the unsnapped link. */ /*** - extract a pointer to the init_info from the */ /*** def_ptr and type_pair. */ /*** - return the actual init_info pointer. */ /*** Output: init_infop */ /*** */ /*** ****************************************************************/ /* parameters */ dcl infop ptr parameter; dcl init_infop ptr parameter; dcl linkp ptr parameter; /* based */ dcl 01 lh aligned like linkage_header based (lhp); dcl based_ptr ptr based; dcl 01 type_pr aligned like type_pair based (type_prp); dcl 01 expr aligned like exp_word based (exprp); dcl 01 link_pair aligned like object_link based (link_pairp); dcl 01 init_info aligned like link_init_deferred based (init_infop); /* automatic */ dcl target_ptr_ptr ptr automatic; dcl lhp ptr automatic; dcl exprp ptr automatic; dcl type_prp ptr automatic; dcl link_pairp ptr automatic; /* if no init_info, or init_info is not deferred, just return */ if init_infop = null then return; if init_info.header.type ^= INIT_DEFERRED then return; /* get the target partial link and make sure it is snapped */ target_ptr_ptr = addrel (linkp, init_info.target_relp); if target_ptr_ptr -> its.its_mod ^= ITS_MODIFIER then call exit (infop, error_table_$bad_deferred_init, null); /* make sure the target of the link looks somewhat like a linkage */ /* header and that the definition pointer is a pointer */ lhp = target_ptr_ptr -> based_ptr; if addr (lh.def_ptr) -> its.its_mod ^= ITS_MODIFIER then call exit (infop, error_table_$no_defs, null); else defp = lh.def_ptr; /* get a pointer to the link specified in the original linkage */ /* section and make sure it looks like an unsnapped link. */ link_pairp = addrel (lh.original_linkage_ptr, init_info.link_relp); if link_pair.tag ^= FAULT_TAG_2 then call exit (infop, error_table_$bad_deferred_init, null); /* now decode the link and get a pointer to the init_info */ exprp = addrel (defp, link_pair.expression_relp); type_prp = addrel (defp, expr.type_relp); if type_pr.trap_relp = None then init_infop = null; else init_infop = addrel (defp, type_pr.trap_relp); end deferred_init; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ self_reference: proc (infop, /** call_info pointer (in ) */ class, /** link class (in ) */ textp, /** segment pointer (in ) */ targetp); /** section pointer (out) */ /*** ****************************************************************/ /*** */ /*** Name: self_reference */ /*** Input: infop, class, textp */ /*** Function: given a link class and a pointer to the owners */ /*** text_section, get the other section pointers and */ /*** return a pointer to the section specified by the */ /*** class of the link. */ /*** Output: targetp */ /*** */ /*** ****************************************************************/ /* parameters */ dcl infop ptr parameter; dcl class fixed bin (18) unsigned parameter; dcl textp ptr parameter; dcl targetp ptr parameter; /* automatic */ dcl code fixed bin (35) automatic; dcl linkp ptr automatic; dcl staticp ptr automatic; dcl symbolp ptr automatic; /* get pointers to the various sections */ call link_man$own_linkage (textp, linkp, staticp, symbolp, code); if code ^= 0 then call exit (infop, code, null); /* return the section pointer based on the link class */ if /* case */ class = CLASS_TEXT then targetp = textp; else if class = CLASS_LINKAGE then targetp = linkp; else if class = CLASS_STATIC then targetp = staticp; else if class = CLASS_SYMBOL then targetp = symbolp; else call exit (infop, error_table_$bad_self_ref, null); end self_reference; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ search_for_segment: proc (infop, /** call_info pointer (in ) */ segnamep, /** segname acc pointer (in ) */ refp, /** referencing pointer (in ) */ MSF_sw, /** is caller an MSF (in ) */ segp, /** found segment ptr (out) */ code); /** error code (out) */ /*** ****************************************************************/ /*** */ /*** Name: search_for_segment */ /*** Input: infop, segnamep, refp */ /*** Function: calls fs_search to search for the refname given */ /*** by the acc_string pointer to by segnamep, and */ /*** meters the call. */ /*** Output: segp, code */ /*** */ /*** ****************************************************************/ /* parameters */ dcl infop ptr parameter; dcl segnamep ptr parameter; dcl refp ptr parameter; dcl MSF_sw bit (1) aligned parameter; dcl segp ptr parameter; dcl code fixed bin (35) parameter; /* based */ dcl 01 info aligned like call_info based (infop); dcl 01 segname aligned based (segnamep), 02 count fixed bin (9) unsigned unaligned, 02 string char (segname.count) unaligned; /* automatic */ dcl 01 finish aligned like usage automatic; dcl 01 start aligned like usage automatic; /* do the search and meter the time an pagewaits */ call usage_values (start.pf, start.time); call fs_search (refp, segname.string, MSF_sw, segp, code); call usage_values (finish.pf, finish.time); /* calculate the metering info and add it to the search metering */ info.search.pf = info.search.pf + (finish.pf - start.pf); info.search.time = info.search.time + (finish.time - start.time); end search_for_segment; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ get_offsetnamep: proc (infop, /** call_info pointer (in ) */ defp, /** definition pointer (in ) */ type_prp, /** type_pair pointer (in ) */ offsetnamep); /** offsetname pointer (out) */ /*** ****************************************************************/ /*** */ /*** Name: get_offsetnamep */ /*** Input: infop, defp, type_prp */ /*** Function: extract a pointer to the offsetname for the link */ /*** from the type_pair. If there is no offsetname */ /*** or the type is 6 and the offset name length is 0, */ /*** the null pointer is returned. */ /*** Output: offsetnamep */ /*** */ /*** ****************************************************************/ /* parameters */ dcl infop ptr parameter; dcl defp ptr parameter; dcl type_prp ptr parameter; dcl offsetnamep ptr parameter; /* based */ dcl 01 offsetname aligned based (offsetnamep), 02 count fixed bin (9) unsigned unaligned, 02 string char (offsetname.count) unaligned; dcl 01 type_pr aligned like type_pair based (type_prp); if type_pr.offsetname_relp = None then offsetnamep = null; else do; /* type-6 links use a valid acc_string with a zero length instead. */ offsetnamep = addrel (defp, type_pr.offsetname_relp); if type_pr.type = LINK_CREATE_IF_NOT_FOUND & offsetname.count = 0 then offsetnamep = null; end; end get_offsetnamep; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ combine_linkage: proc (infop, /** call_info pointer (in ) */ segp, /** target segment ptr (in ) */ textp, /** text section ptr (out) */ linkp, /** linkage section ptr (out) */ statp, /** static section ptr (out) */ symbp); /** symbol section ptr (out) */ /*** ****************************************************************/ /*** */ /*** Name: combine_linkage */ /*** Input: infop, segp */ /*** Function: given a pointer to a segment (segp), combine the */ /*** linkage section (if necessary) and return the */ /*** pointers to the various sections. This routine */ /*** also meters the call. */ /*** Output: textp, linkp, statp, symbp */ /*** */ /*** ****************************************************************/ /* parameters */ dcl infop ptr parameter; dcl segp ptr parameter; dcl textp ptr parameter; dcl linkp ptr parameter; dcl statp ptr parameter; dcl symbp ptr parameter; /* based */ dcl 01 info aligned like call_info based (infop); /* automatic */ dcl 01 finish aligned like usage automatic; dcl 01 start aligned like usage automatic; /* combine the linkage section and meter the time and pagewaits */ call usage_values (start.pf, start.time); textp = ptr (segp, 0); call link_man$other_linkage (textp, linkp, statp, symbp, code); call usage_values (finish.pf, finish.time); /* add in to metering info */ info.get_linkage.pf = info.get_linkage.pf + (finish.pf - start.pf); info.get_linkage.time = info.get_linkage.time + (finish.time - start.time); if code ^= 0 then call exit (infop, code, null); if linkp = null then call exit (infop, error_table_$no_linkage, null); end combine_linkage; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ get_definition: proc (infop, /** call_info pointer (in ) */ segnamep, /** segname acc ptr (in ) */ offsetnamep, /** offsetname acc ptr (in ) */ segp, /** segment to search (in ) */ retry, /** will retry "main_" (in ) */ target_linkagep, /** linkp of target seg (out) */ targetp); /** target pointer (out) */ /*** ****************************************************************/ /*** */ /*** Name: get_definition */ /*** Input: infop, segnamep, offsetnamep, segp, retry */ /*** Function: combines the linkage section for the segment */ /*** specified, and then searches the definition */ /*** section for a definition matching the segname */ /*** and offsetname given and meters the search. */ /*** A pointer to the definition target is then */ /*** generated based on the definition class, the */ /*** section pointers returned by combining the */ /*** linkage, and the definition offset. If the */ /*** search fails and the retry flag is set, we */ /*** try another search for the entrypoint "main_". */ /*** Output: targetp */ /*** */ /*** ****************************************************************/ /* constant */ dcl 01 main_acc aligned static options (constant), 02 count fixed bin (9) unsigned unaligned init (5), 02 string char (5) unaligned init ("main_"); /* parameters */ dcl infop ptr parameter; dcl segnamep ptr parameter; dcl offsetnamep ptr parameter; dcl retry bit (1) parameter; dcl target_linkagep ptr parameter; dcl segp ptr parameter; dcl targetp ptr parameter; /* based */ dcl based_ptr ptr based; dcl 01 def aligned like definition based (defp); dcl 01 info aligned like call_info based (infop); /* automatic */ dcl code fixed bin (35) automatic; dcl defp ptr automatic; dcl 01 finish aligned like usage automatic; dcl linkp ptr automatic; dcl 01 start aligned like usage automatic; dcl statp ptr automatic; dcl symbp ptr automatic; dcl textp ptr automatic; /* if we have no name to search for, don't bother trying */ if offsetnamep = null then return; /* combine the linkage section and get the section pointers */ call combine_linkage (infop, segp, textp, linkp, statp, symbp); /* save the linkage pointer in case we have first reference traps to run */ target_linkagep = linkp; call usage_values (start.pf, start.time); call get_defptr_ (linkp -> linkage_header.def_ptr, segnamep, offsetnamep, defp, code); call usage_values (finish.pf, finish.time); /* update the metering info */ info.def_search.pf = info.def_search.pf + (finish.pf - start.pf); info.def_search.time = info.def_search.time + (finish.time - start.time); if retry & code = error_table_$no_ext_sym then do; /* retry the search with an offsetname of "main_" */ call usage_values (start.pf, start.time); call get_defptr_ (linkp -> linkage_header.def_ptr, segnamep, addr (main_acc), defp, code); call usage_values (finish.pf, finish.time); /* add to the metering info */ info.def_search.pf = info.def_search.pf + (finish.pf - start.pf); info.def_search.time = info.def_search.time + (finish.time - start.time); end; if code ^= 0 then call exit (infop, code, null); /* check for an indirect definition */ if def.indirect then do; /* an indirect definition (used only in component 0 of an */ /* object MSF) is used to refer to something in another */ /* component by adding another indirection through a partial */ /* link. In this case the thing_relp is the offset in the */ /* linkage section of a partial link to the actual definition */ /* target. In some cases this link will have been snapped */ /* already by the msf_prelink_ first reference trap, if not, we */ /* snap the link, and then use the indirection to give us our */ /* definition target. */ if def.class ^= CLASS_LINKAGE then call exit (infop, error_table_$bad_indirect_def, null); /* if the link is snapped, just get the value and return */ targetp = addrel (linkp, def.thing_relp); if targetp -> its.its_mod = ITS_MODIFIER then do; targetp = targetp -> based_ptr; return; end; /* if not make sure it is a partial link */ if targetp -> its.its_mod ^= FAULT_TAG_3 then call exit (infop, error_table_$bad_indirect_def, null); /* then snap it, get the value and return */ call snap_partial_link (infop, targetp, textp); targetp = targetp -> based_ptr; return; end; /* calculate the target based on the definition class and offset */ if /* case */ def.class = CLASS_TEXT then targetp = addrel (textp, def.thing_relp); else if def.class = CLASS_LINKAGE then targetp = addrel (linkp, def.thing_relp); else if def.class = CLASS_STATIC then targetp = addrel (statp, def.thing_relp); else if def.class = CLASS_SYMBOL then targetp = addrel (symbp, def.thing_relp); else call exit (infop, error_table_$bad_class_def, null); end get_definition; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ snap_partial_link: proc (infop, /** call_info pointer (in ) */ link_pairp, /** link pair to snap (i/o) */ refp); /** ref ptr for search (in ) */ /*** ****************************************************************/ /*** */ /*** Name: snap_partial_link */ /*** Input: infop, link_pairp, refp */ /*** Function: snaps a partial link to another component in */ /*** the same directory. */ /*** Output: link_pairp */ /*** */ /*** ****************************************************************/ /* parameters */ dcl infop ptr parameter; dcl link_pairp ptr parameter; dcl refp ptr parameter; /* based */ dcl based_ptr ptr based; dcl 01 info aligned like call_info based (infop); dcl 01 link_pair aligned like partial_link based (link_pairp); /* automatic */ dcl 01 finish aligned like usage automatic; dcl linkp ptr automatic; dcl refname char (32) automatic; dcl 01 start aligned like usage automatic; dcl statp ptr automatic; dcl symbp ptr automatic; dcl textp ptr automatic; /* get the name of the other component */ refname = ltrim (char (link_pair.component)); /* perform the search and meter the time and pagewaits */ call usage_values (start.pf, start.time); call fs_search$same_directory (refp, refname, segp, code); call usage_values (finish.pf, finish.time); /* update the metering info */ info.search.pf = info.search.pf + (finish.pf - start.pf); info.search.time = info.search.time + (finish.time - start.time); /* if we didn't find it, something is broken . . . */ if code ^= 0 then call exit (infop, code, null); /* combine the target linkage section */ call combine_linkage (infop, segp, textp, linkp, statp, symbp); /* now snap the link based on the type and offset in the link */ if /* case */ link_pair.type = CLASS_TEXT then link_pairp -> based_ptr = addrel (textp, link_pair.offset); else if link_pair.type = CLASS_LINKAGE then link_pairp -> based_ptr = addrel (linkp, link_pair.offset); else if link_pair.type = CLASS_STATIC then link_pairp -> based_ptr = addrel (statp, link_pair.offset); else if link_pair.type = CLASS_SYMBOL then link_pairp -> based_ptr = addrel (symbp, link_pair.offset); else call exit (infop, error_table_$bad_indirect_def, null); end snap_partial_link; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ snap: proc (targetp, /** value to snap to (in ) */ expression, /** offset to add (in ) */ link_pairp); /** link pair to snap (i/o) */ /*** ****************************************************************/ /*** */ /*** Name: snap */ /*** Input: targetp, expression, link_pairp */ /*** Function: completes the snapping of the link and sets */ /*** targetp to point to the same value as the snapped */ /*** link; */ /*** Output: targetp, link_pairp */ /*** */ /*** ****************************************************************/ /* parameters */ dcl targetp ptr parameter; dcl expression fixed bin (17) parameter; dcl link_pairp ptr parameter; /* based */ dcl 01 link_as_its aligned like its based (link_pairp); dcl 01 link_pair aligned like object_link based (link_pairp); dcl link_ptr ptr based (link_pairp); /* automatic */ dcl modifier bit (6) automatic; dcl sb ptr automatic; /* add in the expression value */ targetp = addrel (targetp, expression); /* get the original modifier from the link */ modifier = link_pair.modifier; /* store the new pointer back into the link */ link_ptr = targetp; /* put the link modifier back in */ link_as_its.mod = modifier; /* put the run-depth into the pointer */ sb = pds$stacks (level$get ()); link_pair.run_depth = sb -> stack_header.run_unit_depth; end snap; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ meter: proc (infop, /** call_info pointer (in ) */ type); /** link type (in ) */ /*** ****************************************************************/ /*** */ /*** Name: meter */ /*** Input: infop, type */ /*** Function: given the call_info structure containing the */ /*** metering info for the last call, and the type of */ /*** link snapped, update the perprocess link meters */ /*** in pds and the system_wide meters in ahd. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl infop ptr parameter; dcl type fixed bin (18) unsigned parameter; /* based */ dcl 01 info aligned like call_info based (infop); dcl 01 lm aligned like link_meters based (lmp); /* automatic */ dcl elapsed_time fixed bin (35) automatic; dcl elapsed_pf fixed bin (30) automatic; dcl bin_no fixed bin automatic; dcl lmp ptr automatic; /* get the final metering values */ call usage_values (info.finish.pf, info.finish.time); /* calculate the elapsed time and pagewaits */ elapsed_time = bin (info.finish.time - info.start.time, 35); elapsed_pf = bin (info.finish.pf - info.start.pf, 30); /* determine which bin this fault goes into */ bin_no = max (1, min (4, divide (elapsed_time, 25000, 17, 0) + 1)); /* update the counts in pds */ pds$link_meters_bins (bin_no) = pds$link_meters_bins (bin_no) + 1; pds$link_meters_pgwaits (bin_no) = pds$link_meters_pgwaits (bin_no) + elapsed_pf; pds$link_meters_times (bin_no) = pds$link_meters_times (bin_no) + elapsed_time; /* update the ahd link meters */ lmp = addr (ahd$link_meters (bin_no)); lm.total = lm.total + 1; lm.pf = lm.pf + elapsed_pf; lm.time = lm.time + elapsed_time; if /* case */ (info.type = Link_fault | info.type = Link_force) & (type = LINK_REFNAME_BASE | type = LINK_REFNAME_OFFSETNAME) then do; lm.search_pf = lm.search_pf + info.search.pf; lm.search_time = lm.search_time + info.search.time; lm.get_linkage_pf = lm.get_linkage_pf + info.get_linkage.pf; lm.get_linkage_time = lm.get_linkage_time + info.get_linkage.time; lm.defsearch_pf = lm.defsearch_pf + info.def_search.pf; lm.defsearch_time = lm.defsearch_time + info.def_search.time; end; else if type = LINK_CREATE_IF_NOT_FOUND then do; lm.total_type_6 = lm.total_type_6 + 1; lm.type_6_pf = lm.type_6_pf + elapsed_pf; lm.type_6_time = lm.type_6_time + elapsed_time; end; else do; if info.type = Make_entry | info.type = Make_ptr then lm.tot_make_ptr = lm.tot_make_ptr + 1; lm.total_others = lm.total_others + 1; lm.others_pf = lm.others_pf + elapsed_pf; lm.others_time = lm.others_time + elapsed_time; end; end meter; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ trap: proc (infop, /** call_info pointer (in ) */ target_linkagep, /** target linkage scn (in ) */ targetp); /** return value (in ) */ /*** ****************************************************************/ /*** */ /*** Name: trap */ /*** Input: infop, target_linkagep, targetp */ /*** Function: executes first reference traps in the target of */ /*** the link snapped. Since this operation involves */ /*** calling back out to the user ring, we set fix up */ /*** the maching conditions, error codes, and return */ /*** values prior to calling trap_caller_caller_. */ /*** If there are no traps, we return and exit through */ /*** the normal mechanism. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl infop ptr parameter; dcl target_linkagep ptr parameter; dcl targetp ptr parameter; /* based */ dcl 01 info aligned like call_info based (infop); /* now we see if we have first reference traps to run in the target */ /* of the link we just finished snapping. */ if target_linkagep ^= null then do; if target_linkagep -> virgin_linkage_header.first_ref_relp ^= None then do; /* we adjust the machine conditions now, since we won't */ /* return from trap_caller_caller_ . . . */ call adjust_mc (mcp); /* set the return values */ if info.type ^= Link_fault then a_code = 0; if /* case */ info.type = Make_ptr then a_targetp = targetp; else if info.type = Make_entry then addr (a_targete) -> based_entry.code_ptr = targetp; /* now we complete tracing of the fault, since the trap */ /* should not return. */ call page$enter_data ((targetp), linkage_fault_end); /* trap back to the user ring and execute the firstref traps */ call trap_caller_caller_ (info.mcp, target_linkagep, null, null, null, info.codep, code); /* just in case we returned. . . */ if info.mcp ^= null then call exit (infop, code, null); end; end; end trap; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ adjust_mc: proc (mcp); /** machine conditions (in ) */ /*** ****************************************************************/ /*** */ /*** Name: adjust_mc */ /*** Input: mcp */ /*** Function: adjusts the fault machine conditions so that the */ /*** fault can be restarted. */ /*** Output: none. */ /*** */ /*** ****************************************************************/ /* parameters */ dcl mcp ptr parameter; /* based */ dcl 01 instr aligned based (instrp), 02 address bit (18) unaligned, 02 op_code bit (12) unaligned, 02 modifier bit (6) unaligned; /* automatic */ dcl scup ptr automatic; dcl instrp ptr automatic; /* don't try fixing machine conditions that aren't there. . . */ if mcp = null then return; scup = addr (mcp -> mc.scu); instrp = addr (scup -> scu.even_inst); instr.address = scup -> scu.ca; instr.modifier = indirect; end adjust_mc; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ connect_fail_handler_: proc (a_mcp, /** machine conditions (in ) */ a_condition_name, /** condition name (in ) */ a_wcp, /** crawlout info (in ) */ a_infop, /** condition info (in ) */ a_continue_flag); /** continue flag (out) */ /*** ****************************************************************/ /*** */ /*** Name: connect_fail_handler_ */ /*** Input: mcp, condition_name, wcp, infop, continue_flag */ /*** Function: handles the seg_fault condition. This handler */ /*** in enabled prior to the definition search in */ /*** type-4 and type-6 links. When invoked, the */ /*** faulting segment is compared with the global */ /*** variable segp, it the segments are not the same, */ /*** this means we have faulted somewhere unexpected, */ /*** so we continue to signal. If the fault occurred */ /*** on the expected segment, we assume it is because */ /*** of a connection failure and simply return abort */ /*** the link fault returning the appropriate code. */ /*** */ /*** NB. Because of the machanism involved, this */ /*** procedure assumes that the global variables */ /*** segp and call_infop are set prior to the */ /*** establishment of the condition handler. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl a_mcp ptr parameter; dcl a_condition_name char (*) parameter; dcl a_wcp ptr parameter; dcl a_infop ptr parameter; dcl a_continue_flag bit (1) parameter; /* automatic */ dcl faulted_segno fixed bin (18) automatic; dcl segno fixed bin (18) automatic; dcl scup ptr automatic; /* get the segment numbers of the faulting segment and the target */ /* segment of the current link snapping operation */ a_continue_flag = false; scup = addr (a_mcp -> mc.scu); faulted_segno = bin (scup -> scu.tpr.tsr, 18); segno = bin (baseno (segp), 18); /* if they are different, continue to signal */ if faulted_segno ^= segno then do; a_continue_flag = true; return; end; /* otherwise assume a connection failure, and return the code */ connect_fail_code = a_mcp -> mc.errcode; /* NB. here we set a global code and do a non-local goto which */ /* then calls the exit procedure rather than calling exit */ /* directly in order to keep the exit and adjust_mc procedures */ /* as quick procedures. */ goto CONNECT_FAIL_EXIT; end connect_fail_handler_; CONNECT_FAIL_EXIT: call exit (call_infop, connect_fail_code, null); /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ exit: proc (infop, /** call_info pointer (in ) */ code, /** code to return (in ) */ targetp); /** target (for trace) (in ) */ /*** ****************************************************************/ /*** */ /*** Name: exit */ /*** Input: info, code, targetp */ /*** Function: returns from the fault or gate entry and cleans */ /*** up. This procedure differs depending on where */ /*** we entered from: */ /*** link_fault - save the code in the machine */ /*** conditions, adjust the machine */ /*** conditions to allow restart, reset */ /*** the validation level back, */ /*** complete the fault trace, and exit */ /*** link_force - set the code to be returned, */ /*** complete the fault trace, and exit */ /*** make_ptr - set the return pointer and code, */ /*** complete the fault trace, and exit */ /*** make_entry - set the return entry and code, */ /*** complete the fault trace, and exit */ /*** */ /*** NB. When completing the fault trace, the code to */ /*** be returned is examined. If it it nonzero, */ /*** the info_ptr for the call to page$enter_data */ /*** is 0|0. If the code is zero, the targetp */ /*** value is passed to page$enter_data. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl infop ptr parameter; dcl code fixed bin (35) parameter; dcl targetp ptr parameter; /* based */ dcl 01 info aligned like call_info based (infop); dcl 01 exit_mc aligned like mc based (info.mcp); /* if we had a make_ptr or make_entry call, set the return value */ if /* case */ info.type = Make_ptr then a_targetp = targetp; else if info.type = Make_entry then addr (a_targete) -> based_entry.code_ptr = targetp; /* return the code */ if info.type = Link_fault then do; call level$set ((info.save_ring)); exit_mc.errcode = code; call adjust_mc (info.mcp); end; else a_code = code; /* complete fault tracing */ if code = 0 then call page$enter_data ((targetp), linkage_fault_end); else call page$enter_data (baseptr (0), linkage_fault_end); /* non-local goto to outer level and return */ goto EXIT; end exit; EXIT: return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ %page; /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include definition_dcls; %page; %include its; %page; %include link_meters; %page; %include mc; %page; %include object_link_dcls; %page; %include stack_header; %page; %include system_link_names; %page; %include trace_types; end link_snap;  list_inacl_all.pl1 11/11/89 1132.4r w 11/11/89 0800.6 77373 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ list_inacl_all: proc (a_dirname, a_area_ptr, a_acl_ptr, a_info_ptr, a_code); /* Modified 06/11/84 by Keith Loepere to use the new dc_find. */ /* Modified 05/10/79 by B Margulies to remove xmode check */ /* Modified 07/77 by THVV for bad_dir_ check */ /* modified by R. Bratt 06/01/76 to call find_$finished */ /* modified by Kobziar 1/24/75 to accept a null area ptr and return only counts */ /* coded RE Mullen: 4/13/74 */ dcl a_acl_ptr ptr parameter; dcl a_area_ptr ptr parameter; dcl a_code fixed bin (35) parameter; dcl a_dirname char (*) parameter; dcl a_info_ptr ptr parameter; dcl 1 acl_arrays aligned based (acl_ptr), 2 seg_aclsa (alloc_seg_acl_count) aligned like segment_acl_entry, 2 dir_aclsa (alloc_dir_acl_count) aligned like directory_acl_entry; dcl 1 dir_acls (dir_acl_count) aligned like directory_acl_entry based (da_ptr); dcl 1 inacl_info aligned based (info_ptr) like list_inacl_all_info; /* Our structure */ dcl 1 list aligned based, 2 frp bit (18) unal, 2 brp bit (18) unal; dcl 1 seg_acls (seg_acl_count) aligned like segment_acl_entry based (sa_ptr); dcl user_area area based (area_ptr); dcl 1 a_n aligned, 2 ac_name, 3 person char (32), 3 project char (32), 3 tag char (1), 2 mode bit (36), 2 ex_mode bit (36); dcl acls_listed fixed bin (17); dcl alloc_dir_acl_count fixed bin; dcl alloc_seg_acl_count fixed bin; dcl area_ptr pointer; dcl called_find bit (1) aligned; dcl code fixed bin (35); dcl d_s bit (1) aligned; dcl da_ptr pointer; dcl dir_acl_count fixed bin; dcl dir_aclx fixed bin; dcl dirname char (168); dcl i fixed bin (17); dcl info_ptr pointer; dcl lev fixed bin (17); dcl list_ptr pointer; dcl locked bit (1) aligned; dcl return_the_acls bit (1) aligned; dcl sa_ptr pointer; dcl saved_dir_change_pclock fixed bin (35); dcl seg_acl_count fixed bin; dcl seg_aclx fixed bin; dcl (area, bad_dir_, cleanup, seg_fault_error) condition; dcl acl_$list_entry entry (fixed bin, bit (36) aligned, ptr, ptr, fixed bin (17), fixed bin (35)); dcl lock$dir_lock_read entry (ptr, fixed bin (35)); dcl lock$dir_unlock entry (ptr); dcl error_table_$noalloc ext fixed bin (35); dcl error_table_$null_info_ptr ext fixed bin (35); dcl (addr, bin, bit, max, rtrim, null, ptr, rel, sum, unspec) builtin; %page; dirname = a_dirname; /* copy args befor locking dir */ area_ptr = a_area_ptr; info_ptr = a_info_ptr; RESTART: acl_ptr = null; locked, called_find = "0"b; sa_ptr, da_ptr = null; on cleanup call cleanup_; if info_ptr = null then call fatal_error (error_table_$null_info_ptr); return_the_acls = (area_ptr ^= null); /* Find the directory and lock it. */ call dc_find$dir_read (dirname, dp, code); if code ^= 0 then call fatal_error (code); called_find = "1"b; locked = "1"b; /* See how much info to return */ seg_acl_count = sum (dir.iacl_count.seg); dir_acl_count = sum (dir.iacl_count.dir); if seg_acl_count + dir_acl_count = 0 then do; unspec (inacl_info) = ""b; call unlock_dir; a_acl_ptr = null; a_code = 0; go to RETURN; end; if return_the_acls then do; saved_dir_change_pclock = dir.change_pclock; call lock$dir_unlock (dp); locked = "0"b; on area call fatal_error (error_table_$noalloc); alloc_seg_acl_count = max (1, seg_acl_count); alloc_dir_acl_count = max (1, dir_acl_count); allocate acl_arrays in (user_area) set (acl_ptr); revert area; sa_ptr = addr (seg_aclsa); /* avoid expensive runtime adress preparation */ da_ptr = addr (dir_aclsa); on seg_fault_error signal bad_dir_; call lock$dir_lock_read (dp, code); revert seg_fault_error; locked = "1"b; if code ^= 0 then call fatal_error (code); if dir.change_pclock ^= saved_dir_change_pclock then do; call unlock_dir; call free_storage; go to RESTART; end; end; /* Call internal proc for seg and dir iacls per ring */ seg_aclx, dir_aclx = 1; acls_listed = 0; d_s = "0"b; /* set switch for internal proc */ do lev = 0 to 7; /* do all rings */ call do_one_list (addr (dp -> dir.iacl (lev).seg_frp), dir.iacl_count (lev).seg); end; d_s = "1"b; do lev = 0 to 7; call do_one_list (addr (dp -> dir.iacl (lev).dir_frp), dir.iacl_count (lev).dir); end; if acls_listed < (seg_acl_count + dir_acl_count) then signal bad_dir_; /* make sure we found all we were supposed to */ call unlock_dir; a_code = 0; a_acl_ptr = acl_ptr; return; %page; do_one_list: proc (acl_start_ptr, a_n_iacls); dcl a_n_iacls fixed bin unal parameter; dcl acl_start_ptr pointer parameter; dcl access_name character (32); dcl n_iacls fixed bin; n_iacls = a_n_iacls; i = 0; list_ptr = acl_start_ptr; if n_iacls = 0 then do; if list_ptr -> list.frp ^= ""b then signal bad_dir_; else if d_s then do; inacl_info.dia_relp (lev) = ""b; inacl_info.dia_count (lev) = 0; end; else do; inacl_info.sia_relp (lev) = ""b; inacl_info.sia_count (lev) = 0; end; return; end; if d_s then do; inacl_info.dia_relp (lev) = rel_to_acl_ptr (addr (dir_acls (dir_aclx))); inacl_info.dia_count (lev) = n_iacls; end; else do; inacl_info.sia_relp (lev) = rel_to_acl_ptr (addr (seg_acls (dir_aclx))); inacl_info.sia_count (lev) = n_iacls; end; do while (list_ptr -> list.frp ^= ""b); list_ptr = ptr (list_ptr, list_ptr -> list.frp); i = i + 1; if i > n_iacls then signal bad_dir_; if return_the_acls then do; /* want all the info */ call acl_$list_entry (n_iacls, dir.uid, acl_start_ptr, addr (a_n), i, code); if code ^= 0 then call fatal_error (code); acls_listed = acls_listed + 1; access_name = rtrim (a_n.ac_name.person) || "." || rtrim (a_n.ac_name.project) || "." || a_n.ac_name.tag; if d_s then do; if dir_aclx > dir_acl_count then signal bad_dir_; dir_acls (dir_aclx).access_name = access_name; dir_acls (dir_aclx).mode = a_n.ex_mode; dir_acls (dir_aclx).status_code = 0; /* no per user errors on list */ dir_aclx = dir_aclx + 1; end; else do; if seg_aclx > seg_acl_count then signal bad_dir_; seg_acls (seg_aclx).access_name = access_name; seg_acls (seg_aclx).mode = a_n.mode; seg_acls (seg_aclx).extended_mode = a_n.ex_mode; seg_acls (seg_aclx).status_code = 0; seg_aclx = seg_aclx + 1; end; end; else acls_listed = acls_listed + 1; /* just count */ end; if i < n_iacls then signal bad_dir_; rel_to_acl_ptr: procedure (aptr) returns (bit (18)) reducible; dcl aptr pointer parameter; dcl relf fixed bin (18) uns; relf = bin (rel (aptr), 18) - bin (rel (acl_ptr), 18); return (bit (relf, 18)); end rel_to_acl_ptr; end do_one_list; fatal_error: procedure (c); dcl c fixed bin (35); call unlock_dir; call free_storage; a_code = c; go to ERR_RETURN; end fatal_error; RETURN: ERR_RETURN: return; unlock_dir: procedure; if called_find then call dc_find$finished (dp, locked); else if locked then call lock$dir_unlock (dp); end unlock_dir; free_storage: procedure; if acl_ptr ^= null then free acl_arrays; end free_storage; cleanup_: procedure; call free_storage; if called_find then call dc_find$finished (dp, "0"b); /* leave locked for verify lock */ end cleanup_; %page; %include acl_structures; %page; %include dc_find_dcls; %page; %include dir_header; %page; %include list_inacl_all_info; end list_inacl_all;  make_seg.pl1 11/11/89 1132.4rew 11/11/89 0800.6 29115 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* The make_seg procedure creates a branch in a specified directory with a specified entry name. Once the branch is created, the segment is made known to the process by a call to "initiate" and a pointer to the segment is returned to the caller. */ make_seg: procedure (adirname, aentry, arefname, amode, asegptr, acode); /* Modified by R. Bratt 04/76 to make "" and " " equivalent arguments for dname/ename */ /* Modified by E. Stone 10/73 to remove the $stack entry point */ dcl adirname char (*), /* is the directory in which to create "entry". */ aentry char (*), /* is the entry name in question. */ arefname char (*), /* is the desired reference name, or "". */ amode fixed bin (5), /* specifies the mode for this user. */ asegptr ptr, /* is an ITS pointer to the created segment. (Output) */ acode fixed bin; /* is a standard File System status code. (Output) */ dcl dirname char (168), /* copy of directory name */ entry char (32), /* copy of entry name */ (code1, code2) fixed bin (35); /* error codes */ dcl pds$process_dir_name char (32) ext, /* name of process directory */ error_table_$namedup fixed bin (35) ext; /* error code for name duplication */ dcl (null, length) builtin; dcl unique_chars_ ext entry (bit (*) aligned) returns (char (15)), append$branch entry (char (*), char (*), fixed bin (5), fixed bin (35)), initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); /* */ asegptr = null; /* Initialize pointer. */ dirname = adirname; if dirname = "" /* If supplied directory name is null ... */ then dirname = pds$process_dir_name; /* Use process directory name. */ entry = aentry; if entry = "" /* If supplied entry name is null ... */ then entry = unique_chars_ ("0"b); /* Use unique name. */ call append$branch (dirname, entry, amode, code1); /* Now create segment branch in hierarchy. */ if code1 ^= 0 then /* If error ... */ if code1 ^= error_table_$namedup then /* If not a name duplication ... */ go to make_rtn; /* Return the error code2. */ call initiate (dirname, entry, arefname, 0, 0, asegptr, code2); /* Initiate the segment. */ if code2 ^= 0 then /* If error in initiate ... */ acode = code2; /* Return error code from initiate. */ else /* Otherwise ... */ make_rtn: acode = code1; /* Return error code from append. */ return; /* Return to caller. */ end make_seg;  makestack.pl1 11/11/89 1132.4r w 11/11/89 0800.6 123669 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387), audit(86-05-13,Martinson), install(86-05-14,MR12.0-1056): Correct error message documentation. END HISTORY COMMENTS */ /* MAKESTACK * * This is a ring (0) procedure which is called to make a stack for a ring. * The number of the ring for which the stack is being made is passed as an argument to * makestack. All of the operations performed by makestack will be in behalf of this * ring. * * Last modified (date and reason): * 3/85 by Keith Loepere to not append stacks through links. * 6/79 by C. Hornig to do less for prelinked rings * 11/77 by M. Weaver to set aside a special area for ref names * 6/77 by M. Weaver to set static handlers for isot_fault and lot_fault * 3/77 by M. Weaver to add initialize_rnt code and to initialize ect_ptr * 11/76 by M. Weaver to extend stack header * 10/75 by R. Bratt for prelinking and to cleanup * 9/74 by S.Webber as part of combining stacks, lots, and clrs * Modified 12/73 by E. Stone to remove assumption that pl1_operators_ is the same in all rings * ,i.e. the placing of pointers to the alm operators in the stack header. * Modified 10/73 by E. Stone to set the max_length of the stack less than 256K * and to terminate the process if the stack exists or if the segment number has been used * and to place a pointer to operator_pointers_ in the stack header for B. Wolman * Recoded to include new stack format - 3/72 by Bill Silver * Recoded in PL/I - 8/70 by N. I. Morris */ makestack: procedure (a_ring_num); dcl a_ring_num fixed bin (3); /* ring number for stack */ dcl 1 instruction based aligned, 2 tra_offset bit (18) unaligned, /* References offset portion of tra instruction * in transfer vector table in pl1_operators_. These * tra instructions transfer to ALM linkage operators. */ 2 rest bit (18) unaligned; dcl ring_num fixed bin (3), /* Work variable where the ring number argument is copied. */ save_val fixed bin (3), /* Used to save the current validation level when the procedure is entered. */ segno fixed bin, /* segment number of new stack */ dirname char (168), stack_name char (8), /* The reference name ( and entry name ) of the new stack segment. */ pl1_op_ptr ptr, /* A pointer to the pl1 operators table. */ workptr ptr, /* A work pointer used in calls to link_snap$make_ptr */ /* And to construct ptrs to operators in the stack header. */ sctp (0:1) ptr unaligned based, 1 local_create_branch_info aligned like create_branch_info, code fixed bin (35); /* An internal error code. */ /* The following declarations are made in order to reference data in the * process data segment. */ dcl pds$stacks (0:7) pointer external; /* An array of stack pointers for all possible rings. */ dcl pds$prelinked_ring (7) bit (1) unaligned ext; dcl active_all_rings_data$stack_base_segno fixed bin (18) ext; /* Segment number of ring 0 stack. */ dcl pds$process_dir_name char (32) ext; dcl pds$process_group_id char (32) ext; dcl 1 pds$useable_lot aligned ext, 2 flags (0:7) bit (1) unal; /* MAKESTACK uses the following external entry points. */ dcl level$get ext entry (fixed bin (3)), level$set ext entry (fixed bin (3)), link_man$get_initial_linkage entry (fixed bin (3)), link_snap$make_ptr ext entry (ptr, char (*), char (*), ptr, fixed bin (35)), append$create_branch_ ext entry (char (*), char (*), ptr, fixed bin (35)), initiate ext entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)), ref_name_$insert entry (char (32) varying, fixed bin, fixed bin (35)), set$max_length_ptr ext entry (ptr, fixed bin (19), fixed bin (35)), syserr$error_code ext entry options (variable), terminate_proc ext entry (fixed bin (35)); dcl sys_info$default_stack_length fixed bin (19) ext; dcl error_table_$invalid_stack_creation ext fixed bin (35); dcl (addr, addrel, baseno, baseptr, fixed, null, ptr, rel, size, string, substr, unspec) builtin; %page; ring_num = a_ring_num; sb, pds$stacks (ring_num) = baseptr (ring_num + active_all_rings_data$stack_base_segno); /* Compute expected stack pointer. */ segno = fixed (baseno (sb), 17); if pds$prelinked_ring (ring_num) then do; stack_header.null_ptr = null (); /* force the stack to be copied */ pds$useable_lot.flags (ring_num) = "1"b; /* this saves trouble later */ return; end; call level$get (save_val); call level$set (ring_num); dirname = pds$process_dir_name; stack_name = "stack_" || substr ("1234567", ring_num, 1); unspec (local_create_branch_info) = "0"b; /* describe new stack, no chasing allowed */ local_create_branch_info.version = create_branch_version_2; local_create_branch_info.parent_ac_sw = "1"b; local_create_branch_info.mode = REW_ACCESS; local_create_branch_info.rings (*) = ring_num; local_create_branch_info.userid = pds$process_group_id; call append$create_branch_ (dirname, stack_name, addr (local_create_branch_info), code); if code ^= 0 then do; /* User cannot make his own stack */ call syserr$error_code (4, code, "makestack: error appending ^a", stack_name); call terminate_proc (error_table_$invalid_stack_creation); end; call initiate (dirname, stack_name, "", 1, 1, sb, code); /* can't use reference names yet */ if code ^= 0 then do; /* Prevent user from using reserved segment number */ call syserr$error_code (4, code, "makestack: error initiating ^a", stack_name); call terminate_proc (error_table_$invalid_stack_creation); end; call set$max_length_ptr (sb, sys_info$default_stack_length, code); if code ^= 0 then call syserr$error_code (2, code, "makestack: error from set$max_length_ptr on ^a.", stack_name); stack_header.null_ptr, stack_header.ect_ptr = null (); stack_header.stack_begin_ptr, stack_header.stack_end_ptr = ptr (sb, size (stack_header)); call link_man$get_initial_linkage (ring_num); pds$useable_lot.flags (ring_num) = "1"b; unspec (stack_header.lot_ptr -> lot.lp (segno)) = lot_fault; call initialize_rnt; /* allocate RNT and set search rules */ call ref_name_$insert ((stack_name), segno, code); /* now we can add reference name */ /* Now fill in the fields in the header of the new stack. */ stack_header.signal_ptr = get_ptr ("signal_", "signal_"); stack_header.unwinder_ptr = get_ptr ("unwinder_", "unwinder_"); stack_header.trans_op_tv_ptr = get_ptr ("operator_pointers_", "operator_pointers_"); pl1_op_ptr = get_ptr ("pl1_operators_", "operator_table"); /* Get the following pl1 operator pointers from offsets within the pl1 operator table transfer vector */ workptr = addrel (pl1_op_ptr, tv_offset); stack_header.pl1_operators_ptr = pl1_op_ptr; stack_header.call_op_ptr = ptr (workptr, addrel (workptr, call_offset) -> instruction.tra_offset); stack_header.push_op_ptr = ptr (workptr, addrel (workptr, push_offset) -> instruction.tra_offset); stack_header.return_op_ptr = ptr (workptr, addrel (workptr, return_offset) -> instruction.tra_offset); stack_header.return_no_pop_op_ptr = ptr (workptr, addrel (workptr, return_no_pop_offset) -> instruction.tra_offset); stack_header.entry_op_ptr = ptr (workptr, addrel (workptr, entry_offset) -> instruction.tra_offset); /* set up essential static handlers */ call link_snap$make_ptr (null (), "copy_on_write_handler_", "copy_on_write_handler_", workptr, code); ptr (sb, rel (stack_header.sct_ptr)) -> sctp (no_write_permission_sct_index) = workptr; ptr (sb, rel (stack_header.sct_ptr)) -> sctp (not_in_write_bracket_sct_index) = workptr; call link_snap$make_ptr (null (), "isot_fault_handler_", "isot_fault_handler_", workptr, code); ptr (sb, rel (stack_header.sct_ptr)) -> sctp (isot_fault_sct_index) = workptr; call link_snap$make_ptr (null (), "lot_fault_handler_", "lot_fault_handler_", workptr, code); ptr (sb, rel (stack_header.sct_ptr)) -> sctp (lot_fault_sct_index) = workptr; /* We have finished setting up the header of the new stack. There are no more calls to be * made so we will reset the validation level of this procedure to what it was when the procedure * was called. Then we will set up the two thread pointers in the first stack frame of the * new stack. Note the previous frame pointer is null since there is no previous frame. * The pointer to the first stack frame has been set up above in the stack_begin_ptr. */ call level$set (save_val); sp = stack_header.stack_end_ptr; sp -> stack_frame.prev_sp = null; sp -> stack_frame.next_sp = addrel (stack_header.stack_end_ptr, stack_frame_min_length); get_ptr: proc (refname, defname) returns (ptr); dcl (refname, defname) char (*); call link_snap$make_ptr (null (), refname, defname, workptr, code); if code ^= 0 then do; call syserr$error_code (0, code, "makestack: error finding ^a$^a for ^a.", refname, defname, stack_name); call terminate_proc (error_table_$invalid_stack_creation); end; return (workptr); end get_ptr; %page; initialize_rnt: proc; dcl rnt_space (2048) bit (36) aligned based; dcl 1 ainfo aligned like area_info; dcl size builtin; dcl error_table_$termination_requested ext fixed bin (35); dcl terminate_proc entry (fixed bin (35)); dcl define_area_ entry (ptr, fixed bin (35)); dcl pds$processid bit (36) aligned ext; dcl initiate_search_rules$init_ring entry (ptr, fixed bin (35)); dcl syserr$error_code entry options (variable); %include rnt; %include area_info; dcl 1 default_rules static options (constant) aligned, 2 number fixed bin init (1), 2 name char (168) init ("default"); %page; /* obtain an rnt area */ ainfo.version = area_info_version_1; string (ainfo.control) = "0"b; ainfo.control.zero_on_free = "1"b; ainfo.control.system = "1"b; ainfo.owner = "rnt"; ainfo.size = size (rnt_space); allocate rnt_space in (stack_header.clr_ptr -> based_rnt_area) set (ainfo.areap); call define_area_ (addr (ainfo), code); if code ^= 0 then call terminate_proc (error_table_$termination_requested); /* initialize the RNT itself */ allocate rnt in (ainfo.areap -> based_rnt_area) set (rntp); unspec (rnt) = "0"b; rnt.areap = ainfo.areap; rnt.rnt_area_size = ainfo.size; rnt.name_hash_table (*) = null (); rnt.segno_hash_table (*) = null (); rnt.srulep = null; stack_header.rnt_ptr = rntp; /* initialize the search rules */ call initiate_search_rules$init_ring (addr (default_rules), code); if code ^= 0 then do; call syserr$error_code (0, code, "makestack: error from initiate_search_rules."); call terminate_proc (error_table_$termination_requested); end; return; end initialize_rnt; %page; % include access_mode_values; % include create_branch_info; % include lot; % include stack_frame; % include stack_header; % include static_handlers; %page; /* BEGIN MESSAGE DOCUMENTATION Message: makestack: error from set$max_length_ptr on STACKNAME. S: $term T: $init Process/ring initialization. Just prior to using a new ring. M: The process directory is probably messed up. A: Ignore unless it's the initializer, in which case bring the system back up. If problem persists, contact the system administrator. Message: makestack: error appending STACKNAME S: $term T: $init Process/ring initialization. Just prior to using a new ring. M: The process directory is probably messed up. A: Ignore unless it's the initializer, in which case bring the system back up. If problem persists, contact the system administrator. Message: makestack: error getting bit count for original prelinked STACK_NAME S: $term T: $init Process/ring initialization. Just prior to using a new ring. M: A directory containing a prelinked subsystem is probably messed up. A: The directory should be prelinked again. Message: makestack: error initiating STACKNAME S: $term T: $init Process/ring initialization. Just prior to using a new ring. A: Ignore unless it's the initializer, in which case bring the system back up. If problem persists, contact the system administrator. Message: makestack: error finding DIRNAME>ENAME for STACKNAME. S: $term T: $init Process/ring initialization. A: Ignore unless it's the initializer, in which case bring the system back up. If problem persists, contact the system administrator. Message: makestack: error from initiate_search_rules. S: $term T: Process/ring initialization. Just prior to using new ring. M: The default search rules are missing from ahd (active hardcore data). These are usually loaded by the command set_system_search_rules. A: $contact_sa END MESSAGE DOCUMENTATION */ end makestack;  other_process_info.pl1 11/11/89 1132.4rew 11/11/89 0800.6 22509 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style4 */ /* other_process_info - find out things about another process, typically by snooping in its pds */ /* 83-05-09 coded E. N. Kittlitz */ /* 83-12-05 modified to lock AST while peeking at other guy's PDS */ other_process_info: proc; dcl a_code fixed bin (35); dcl a_processid bit (36) aligned; dcl a_privs bit (36) aligned; dcl abs_seg_ptr ptr; dcl pds_sdw bit (72) aligned; dcl pds_sdw_ptr ptr; dcl processid bit (36) aligned; dcl 1 process_auth aligned like aim_template; dcl error_table_$process_unknown fixed bin (35) ext static; dcl initializer_abs_seg$ fixed bin ext static; dcl sst$ fixed bin ext static; dcl 1 pds$access_authorization aligned like aim_template ext static; dcl get_ptrs_$given_astep entry (ptr) returns (bit (72) aligned); dcl lock$lock_ast entry; dcl lock$unlock_ast entry; dcl privileged_mode_ut$swap_sdw entry (ptr, ptr); dcl tc_util$get_aptep entry (bit (36) aligned, bit (1) aligned) returns (ptr); dcl (addr, null, ptr, rel) builtin; return; %page; get_privileges: entry (a_processid, a_privs, a_code); processid = a_processid; aptep = tc_util$get_aptep (processid, "1"b); if aptep = null then go to foo_process; abs_seg_ptr = addr (initializer_abs_seg$); pds_sdw_ptr = addr (pds_sdw); call lock$lock_ast; /* AST LOCKED */ pds_sdw = get_ptrs_$given_astep (ptr (addr (sst$), aptep -> apte.pds)); call privileged_mode_ut$swap_sdw (abs_seg_ptr, pds_sdw_ptr); process_auth = ptr (abs_seg_ptr, rel (addr (pds$access_authorization))) -> aim_template; call lock$unlock_ast; /* AST UNLOCKED */ pds_sdw = ""b; call privileged_mode_ut$swap_sdw (abs_seg_ptr, pds_sdw_ptr); if apte.processid ^= processid then /* something changed behind our backs */ go to foo_process; a_privs = unspec (addr (process_auth) -> aim_template.privileges); a_code = 0; return; foo_process: a_code = error_table_$process_unknown; a_privs = ""b; return; %page; %include aim_template; %page; %include apte; end other_process_info;  proc_info.pl1 11/11/89 1132.4rew 11/11/89 0800.6 18342 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Procedure to return certain per-process info previously in process_info */ /* Initially coded by R. J. Feiertag, Dec. 10,1969 */ /* Last modified by Kobziar July 74 to add authorization entry */ proc_info: proc(process_id,process_group_id,process_dir_name,lock_id_); declare process_id bit(36) aligned, process_group_id char(32) aligned, process_dir_name char(32) aligned, lock_id_ bit(36) aligned, ((pds$processid, pds$lock_id, tc_data$initializer_id) bit(36), (pds$process_group_id, pds$process_dir_name) char(32)) aligned ext; process_id = pds$processid; /* pick up process id */ lock_id_ = pds$lock_id; /* pick up lock id */ process_group_id = pds$process_group_id; process_dir_name = pds$process_dir_name; return; get_initial_ring: entry(iring); dcl (pds$initial_ring ext, iring) fixed bin; iring = pds$initial_ring; return; /* That was rather difficult! */ set_mask_ring: entry; /* hphcs_ entry */ if pds$processid = tc_data$initializer_id then pds$initial_ring = 4; /* Initializer now wants to be masked in lower rings */ return; authorization: entry(auth, max_auth); declare (auth, max_auth) bit(72) aligned, (pds$access_authorization, pds$max_access_authorization) ext static aligned bit(72); auth = pds$access_authorization; max_auth = pds$max_access_authorization; return; end proc_info;  quota.pl1 11/11/89 1132.4r w 11/11/89 0800.0 234657 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ quota: proc; /* QUOTA - directory control interface for managing quotas. Quotas live in the VTOC entry; or in the ASTE when the seg is active. There are two "quota cells" for each directory: one for pages of segments and one for directory pages. Each quota cell contains . quota . used . clock . time-page product . received count (quota + all inferior quotas) . inferior quota count The current program does not handle directory quota at all. Quota cell is protected by the directory lock. But used can only be satisfactorily protected by the PTL. So quotaw is called to look at or manipulate used, and he must be called with the AST locked since his inputs are asteps. vtoc_attributes is used to read and write quota cells in VTOC. It may be called with or without AST locked */ /* Last change: */ /* Modified May 1985 by EJ Sharpe to use dc_find$mdir_set_quota_uid and to enforce AIM restriction on removing quota from upgraded master dirs */ /* Modified January 1985 by Keith Loepere to set tup at append_mdir_set. */ /* Modified November 1984 by Keith Loepere for auditing info. */ /* Modified July 1984 by Keith Loepere to use the new dc_find. */ /* Modified BIM 84-05 for sst reformat. */ /* Modified BIM 83-12-06 to correctly check dir privilege and upgradedness, TR 16411 */ /* Modified BIM 3/82 to only hold read locks when appropriate */ /* Modified 05/05/82 by S. Krupp to change error code invalid_move_quota to invalid_move_qmax and return ai_not_restricted in case of no privilege */ /* Modified November 1979 by C. Hornig for privileged quota reading */ /* Modified 19 Feb 79 by D. Spector for 18-bit quota values */ /* Modified June 1, 1976 by R. Bratt to call find_$finished */ /* Modified March 1976 by Larry Johnson for master directory quota */ /* Extensive changes for NSS by TVV 6/75 */ /* Modified by Kobziar 10-21-74 to add qmove_mylock entry */ /* Modified by Kobziar July 74 to call new entry in access_mode and to check authorization */ /* Parameters */ dcl a_code fixed bin (35) parameter; dcl a_dp1 ptr parameter; dcl a_ename char (*) parameter; dcl a_ep ptr parameter; dcl a_ignore fixed bin (17) parameter; dcl a_ltrp fixed bin (71) parameter; dcl a_parent char (*) parameter; dcl a_qchange fixed bin (17) parameter; dcl a_quota fixed bin (18) parameter; dcl a_seg_or_dir bit (1) parameter; dcl a_segptr ptr parameter; dcl a_slvid bit (36) parameter; dcl a_taccsw fixed bin (1) parameter; dcl a_trp fixed bin (35) parameter; dcl a_trpc fixed bin (35) parameter; dcl a_tup bit (36) aligned parameter; dcl a_uchange fixed bin (17) parameter; dcl a_uidpath (0:15) bit (36) aligned parameter; dcl a_used fixed bin (17) parameter; /* Variables */ dcl CHECK_ONLY fixed bin (1) init (1) static options (constant); dcl LOTS fixed bin (71) static options (constant) init (11111111111111111111111111111111111b); /* 35 1-bits */ dcl ROOT_UID bit (36) static options (constant) init ((36)"1"b); dcl SEC_PER_TICK float bin static options (constant) init (.65536e-1); /* Convert fs time to seconds */ dcl called_find bit (1) aligned init ("0"b); dcl check_access bit (1); dcl code fixed bin (35); dcl curtime bit (36) aligned; dcl dep ptr; dcl dir_privilege bit (1); dcl dir_quota_sw bit (1) init ("0"b);/* TRUE only if doing dir quota */ dcl dt fixed bin (35); dcl ename char (32); dcl len fixed bin; dcl locked bit (1) aligned init ("0"b); dcl ltrp fixed bin (71); dcl moved_down fixed bin (35); dcl mylock_entry bit (1) aligned; dcl new_entry bit (1) aligned init ("0"b); dcl not_root bit (1) aligned init ("1"b); dcl now_terminal bit (1); dcl parent char (168); dcl parent_astep ptr; dcl parent_dp ptr; dcl parent_pvid bit (36) aligned; dcl 1 parent_qcell like quota_cell aligned; dcl parent_uid bit (36) aligned; dcl parent_vtocx fixed bin; dcl pathname char (168); dcl pvid bit (36) aligned; dcl 1 qcell like quota_cell aligned; dcl qchange fixed bin (18); dcl qt fixed bin (18) init (0); /* default assumption is segs (=0) */ dcl quota fixed bin (18); dcl read_lock bit (36) aligned init ("0"b); dcl segptr ptr; dcl setquota_entry bit (1) init ("0"b); dcl slvid bit (36); dcl sstp pointer; dcl taccsw bit (1) aligned; dcl trp fixed bin (35); dcl tup bit (36) aligned; dcl uchange fixed bin (18); dcl uid bit (36) aligned; dcl uidpath (0:15) bit (36) aligned; dcl unlock_son bit (1); dcl used fixed bin (18); dcl vtocx fixed bin; dcl was_terminal bit (1); dcl write_lock bit (36) aligned init ("1"b); /* External */ dcl error_table_$ai_restricted fixed bin (35) ext; dcl error_table_$argerr fixed bin (35) ext; dcl error_table_$bad_ring_brackets fixed bin (35) ext; dcl error_table_$invalid_move_qmax fixed bin (35) ext; dcl error_table_$master_dir fixed bin (35) ext; dcl error_table_$mdc_not_mdir fixed bin (35) ext; dcl error_table_$rqover fixed bin (35) ext; dcl pds$access_authorization bit (72) aligned ext static; dcl sst_seg$ external static; dcl sst$root_astep pointer external static; /* Entries */ dcl activate entry (ptr, fixed bin (35)) returns (ptr); dcl aim_check_$greater entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl level$get entry returns (fixed bin (17)); dcl lock$dir_unlock entry (ptr); dcl lock$unlock_ast entry; dcl quotaw$cu entry (ptr, fixed bin (18), bit (1), fixed bin (1), fixed bin (35)); dcl quotaw$mq entry (ptr, ptr, fixed bin (18), bit (1), fixed bin (35)); dcl quotaw$sq entry (ptr, fixed bin (18), bit (1), fixed bin (1)); dcl sum$getbranch entry (ptr, bit (36) aligned, ptr, fixed bin (35)); dcl sum$dirmod entry (ptr); dcl vtoc_attributes$get_quota entry (bit (36) aligned, bit (36) aligned, fixed bin (17), ptr, fixed bin (18), fixed bin (35)); dcl vtoc_attributes$set_quota entry (bit (36) aligned, bit (36) aligned, fixed bin (17), ptr, fixed bin (18), fixed bin (35)); /* Misc */ dcl (addr, bin, bit, clock, fixed, length, min, null, ptr, rtrim, substr, unspec) builtin; %page; /* ========================================================== */ /* qlong_reset, reset - entries which modify the trp of the directory only */ /* these are called by accounting to reduce the trp once a month. */ /* qreset is very probably obsolete */ dqlong_reset: entry (a_parent, a_ltrp, a_code); dir_quota_sw = "1"b; qt = 1; qlong_reset: entry (a_parent, a_ltrp, a_code); ltrp = a_ltrp; /* Copy arguments */ go to reset1; qreset: entry (a_parent, a_trpc, a_code); ltrp = a_trpc; /* .. old style */ reset1: parent = a_parent; code = 0; /* Clear return code */ call dc_find$dir_write_priv (parent, FS_OBJ_TRP_MOD, dp, code); /* get pointer to directory */ if code ^= 0 then go to errxit; called_find, locked = "1"b; call get_quota_cell; /* read VTOC */ qcell.trp = qcell.trp - ltrp; /* Perform subtraction */ call vtoc_attributes$set_quota (uid, pvid, vtocx, addr (qcell), qt, code); call sum$dirmod (dp); /* Make sure dir mod noted */ goto done; /* * * * * * * * * * * * * * * * * * * * * * */ /* qset, qset_mylock, qreload, qrestor - support for entries which set the quota cell */ /* all four are highly-privileged entrypoints */ dqset: entry (a_parent, a_quota, a_code); dir_quota_sw = "1"b; qt = 1; qset: entry (a_parent, a_quota, a_code); setquota_entry = "1"b; taccsw = "1"b; /* Default */ quota = a_quota; /* Copy arg */ parent = a_parent; /* copy into char(168) aligned */ code = 0; /* Clear return code */ call dc_find$dir_write_priv (parent, FS_OBJ_QUOTA_MOD, dp, code); /* get pointer to directory */ if code ^= 0 then go to errxit; called_find, locked = "1"b; call get_quota_cell; /* Read VTOCE */ go to common; dqrestor: entry (a_parent, a_quota, a_ltrp, a_tup, a_ignore, a_taccsw, a_code); dir_quota_sw = "1"b; qt = 1; qrestor: entry (a_parent, a_quota, a_ltrp, a_tup, a_ignore, a_taccsw, a_code); ltrp = a_ltrp; /* Privileged entry for SysAdmin */ go to qreload_common; /* .. and daemon */ qreload: entry (a_parent, a_quota, a_trp, a_tup, a_ignore, a_taccsw, a_code); ltrp = a_trp; qreload_common: tup = a_tup; /* Copy args */ taccsw = bit (a_taccsw, 1); quota = a_quota; parent = a_parent; /* copy into char(168) aligned */ code = 0; /* Clear return code */ call dc_find$dir_write_priv (parent, FS_OBJ_QUOTA_RELOAD, dp, code); /* get pointer to directory */ if code ^= 0 then go to errxit; called_find, locked = "1"b; call get_quota_cell; /* read in quota info */ qcell.trp = ltrp; qcell.tup = tup; common: sstp = addr (sst_seg$); /* Make segment active */ astep = make_seg_active (dp); if aste.tqsw (qt) = taccsw then /* if no change to terminal status */ aste.quota (qt) = quota; /* just change quota in AST entry */ else do; /* for non-term quota, used must be subtracted from parent */ call quotaw$sq (astep, quota, dir_quota_sw, fixed (taccsw, 1)); /* sets quota, adds or subs used from sup accts */ if setquota_entry then qcell.tup = bit (bin (clock (), 52), 52); /* on first qset set tup */ end; qcell.received = qcell.received + quota - qcell.quota; qcell.quota = quota; /* set quota in VTOC */ qcell.terminal_quota_sw = aste.tqsw (qt); if not_root then call lock$unlock_ast; call vtoc_attributes$set_quota (uid, pvid, vtocx, addr (qcell), qt, code); if not_root then do; /* Unlock parent dir */ parent_dp = ptr (dep, 0); call lock$dir_unlock (parent_dp); /* unlock sup dir */ end; call sum$dirmod (dp); /* Make sure dir mod noted */ goto done; /* * * * * * * * * * * * * * * * * * * * * * */ /* mdir_set: entry to set quota on a master directory */ mdir_set: entry (a_uidpath, a_quota, a_code); uidpath = a_uidpath; quota = a_quota; call dc_find$mdir_set_quota_uid (uidpath, parent, FS_OBJ_MDIR_QUOTA_MOD, ep, dp, code); /* finds directory */ if code ^= 0 then go to errxit; locked, called_find = "1"b; parent_dp = ptr (ep, 0); if ^entry.master_dir then do; code = error_table_$mdc_not_mdir; go to unlock2; end; if level$get () > fixed (entry.ex_ring_brackets (1), 3) then do; code = error_table_$bad_ring_brackets; go to unlock2; end; uid = dir.uid; /* setup to read vtoce */ pvid = dir.pvid; vtocx = dir.vtocx; call vtoc_attributes$get_quota (uid, pvid, vtocx, addr (qcell), 0, code); if code ^= 0 then go to unlock2; dir_privilege = addr (pds$access_authorization) -> aim_template.privileges.dir; qchange = quota - qcell.quota; if qchange < 0 then /* If reducing quota */ if aim_check_$greater (entry.access_class, parent_dp -> dir.access_class) then /* its an upgraded dir */ if ^dir_privilege then do; /* If not privileged, forget it. */ /* Could publish info if he did this */ code = error_table_$ai_restricted; go to unlock2; end; else if qcell.quota + qchange <= 0 then do; /* if would make it zero, forget it too. */ code = error_table_$invalid_move_qmax; go to unlock2; end; call lock$dir_unlock (parent_dp); /* done with parent */ astep = activate (ep, code); qcell.used = aste.used (0); /* aste is more up to date */ moved_down = qcell.received - qcell.quota; /* quota on lower directorys */ qcell.received = quota; qcell.quota = quota - moved_down; if qcell.received < qcell.used + moved_down then do; /* not enough */ code = error_table_$rqover; call lock$unlock_ast; go to unlock1; end; aste.quota (0) = quota; call lock$unlock_ast; call vtoc_attributes$set_quota (uid, pvid, vtocx, addr (qcell), 0, code); call sum$dirmod (dp); go to done; /* * * * * * * * * * * * * * * * * * * * * * */ /* append_mdir_set: special entry called by append to set initial master directory quota */ append_mdir_set: entry (a_ep, a_quota, a_code); ep = a_ep; quota = a_quota; uid = entry.uid; /* set up for vtoc_attributes call */ pvid = entry.pvid; vtocx = entry.vtocx; unspec (qcell) = "0"b; qcell.received, qcell.quota = quota; qcell.terminal_quota_sw = "1"b; curtime = bit (bin (clock (), 52), 52); qcell.tup = curtime; /* trp clock starts NOW */ astep = activate (ep, code); /* must also update aste */ aste.quota (0) = quota; aste.tqsw (0) = "1"b; call lock$unlock_ast; call vtoc_attributes$set_quota (uid, pvid, vtocx, addr (qcell), 0, code); a_code = code; return; /* * * * * * * * * * * * * * * * * * * * * * */ /* qread, qget - entries to read the quota information */ dqread: entry (a_parent, a_quota, a_ltrp, a_tup, a_slvid, a_taccsw, a_used, a_code); dir_quota_sw = "1"b; qt = 1; check_access = "1"b; new_entry = "1"b; goto get_common; qread: entry (a_parent, a_quota, a_ltrp, a_tup, a_slvid, a_taccsw, a_used, a_code); new_entry = "1"b; check_access = "1"b; goto get_common; qget: entry (a_parent, a_quota, a_trp, a_tup, a_slvid, a_taccsw, a_used, a_code); check_access = "1"b; goto get_common; priv_qread: entry (a_parent, a_quota, a_ltrp, a_tup, a_slvid, a_taccsw, a_used, a_code); new_entry = "1"b; check_access = "0"b; goto get_common; priv_dqread: entry (a_parent, a_quota, a_ltrp, a_tup, a_slvid, a_taccsw, a_used, a_code); new_entry = "1"b; dir_quota_sw = "1"b; qt = 1; check_access = "0"b; get_common: quota, trp, ltrp, used = 0; /* zero return variables */ tup = "0"b; taccsw = "0"b; parent = a_parent; /* copy into char(168) aligned */ code = 0; /* Clear return code */ if check_access then call dc_find$dir_read (parent, dp, code); /* get pointer to directory */ else call dc_find$dir_read_priv (parent, dp, code); if code ^= 0 then go to errxit; called_find, locked = "1"b; call get_quota_cell; /* get quota info */ slvid = dir.sons_lvid; /* Save sons LVID for later */ sstp = addr (sst_seg$); astep = make_seg_active (dp); /* To check used, must have active acct */ qcell.used = aste.used (qt); /* update from ast entry to temp */ if not_root then do; /* ok, now unlock */ parent_dp = ptr (dep, 0); call lock$unlock_ast; call lock$dir_unlock (parent_dp); /* unlock parent dir */ end; if qcell.terminal_quota_sw then do; /* this is a terminal account, do full update */ curtime = bit (bin (clock (), 52), 52); /* get time as bit string - high order bits */ /* calc and add to the time-page product which is in page-secs */ dt = fixed (curtime, 36) - fixed (qcell.tup, 36); /* time since last update */ qcell.trp = qcell.trp + fixed ((dt * qcell.used) * SEC_PER_TICK + .5e0, 71); qcell.tup = curtime; /* .. */ end; quota = qcell.quota; /* copy info from dir header */ ltrp = qcell.trp; /* .. into return args */ trp = min (ltrp, LOTS); /* return max value if overflow 35 bits */ tup = qcell.tup; used = qcell.used; taccsw = qcell.terminal_quota_sw; unlock: call dc_find$finished (dp, "1"b); /* Unlock directory */ a_quota = quota; /* .. and give args back to caller */ if new_entry then a_ltrp = ltrp; else a_trp = trp; a_tup = tup; a_slvid = slvid; a_taccsw = fixed (taccsw, 1); a_used = used; a_code = code; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* entry called by append to see if can move quota */ check: entry (a_ep, a_uchange, a_code); ep = a_ep; /* dir is not locked */ unlock_son = "0"b; go to join; check_file: entry (a_parent, a_ename, a_uchange, a_code); /* Called by fs_move */ parent = a_parent; ename = a_ename; code = 0; unlock_son = "1"b; /* will lock the dir */ call dc_find$obj_status_read (parent, ename, DC_FIND_CHASE, ep, code); dp = ptr (ep, 0); /* Get ptr to parent */ if code ^= 0 then go to errxit; /* see if find it */ called_find = "1"b; go to join; check_seg: entry (a_segptr, a_uchange, a_code); /* (not used currently) */ segptr = a_segptr; code = 0; unlock_son = "1"b; call dc_find$obj_status_read_ptr (segptr, ep, code); if code ^= 0 then go to errxit; dp = ptr (ep, 0); join: uchange = a_uchange; /* What's the change in quota */ dp = ptr (ep, 0); /* get pointer to base of directory */ sstp = addr (sst_seg$); astep = make_seg_active (dp); /* Force active so look at used */ call quotaw$cu (astep, uchange, dir_quota_sw, CHECK_ONLY, code); /* checks act acct with ptl set */ if not_root then do; parent_dp = ptr (dep, 0); call lock$unlock_ast; call lock$dir_unlock (parent_dp); /* unlock parent dir */ end; unlock3: if unlock_son then if called_find then call dc_find$finished (dp, "1"b); else call lock$dir_unlock (dp); a_code = code; return; /* * * * * * * * * * * * * * * * * * * * * * */ /* This entry moves quota between a dir and its parent */ dqmove: entry (a_parent, a_ename, a_qchange, a_code); dir_quota_sw = "1"b; qt = 1; qmove: entry (a_parent, a_ename, a_qchange, a_code); code = 0; qchange = a_qchange; /* Copy arg */ parent = a_parent; /* copy into char(168) aligned */ ename = a_ename; /* copy into char(32) aligned */ mylock_entry = "0"b; len = length (rtrim (parent)); /* Get dirname into pathname */ if ename ^= "" then do; if len + length (rtrim (ename)) + 1 > length (pathname) then do; /* too long */ bad_path: code = error_table_$argerr; goto errxit; end; if len = 1 then pathname = substr (parent, 1, 1) || ename; /* dir is then root */ else pathname = substr (parent, 1, len) || ">" || ename; end; else do; if len > length (pathname) then goto bad_path; if len = 1 then goto bad_path; /* don't bother with a single directory (root) */ pathname = parent; end; dir_privilege = addr (pds$access_authorization) -> aim_template.privileges.dir; /* this is going to be useful later... */ call dc_find$dir_move_quota (pathname, ep, dp, code); if code ^= 0 then goto errxit; called_find, locked = "1"b; parent_dp = ptr (ep, 0); /* Locate parent */ if level$get () > fixed (entry.ex_ring_brackets (1), 3) then do; code = error_table_$bad_ring_brackets; /* ringbrackets must be consistent with validation level */ go to unlock2; end; uid = dir.uid; pvid = dir.pvid; vtocx = dir.vtocx;/* Copy vars for son */ call vtoc_attributes$get_quota (uid, pvid, vtocx, /* .. and read VTOC */ addr (qcell), qt, code); if code ^= 0 then go to unlock2; parent_uid = parent_dp -> dir.uid; parent_pvid = parent_dp -> dir.pvid; parent_vtocx = parent_dp -> dir.vtocx; call vtoc_attributes$get_quota (parent_uid, parent_pvid, parent_vtocx, addr (parent_qcell), qt, code); if code ^= 0 then go to unlock2; if qcell.terminal_quota_sw then /* if inferior dir has terminal acct */ if qcell.received > qcell.quota then /* and it has inferior quotas */ if qcell.quota + qchange <= 0 then do; /* and the.change would make it non-terminal */ code = error_table_$invalid_move_qmax; /* don't allow change to be made */ go to unlock2; end; if qchange < 0 then /* If moving quota up */ if aim_check_$greater (entry.access_class, parent_dp -> dir.access_class) then /* its an upgraded dir */ if ^dir_privilege then do; /* If not privileged, forget it. */ /* Could publish info if he did this */ code = error_table_$ai_restricted; go to unlock2; end; else if qcell.quota + qchange <= 0 then do; /* if would make non-term, forget it too. */ code = error_table_$invalid_move_qmax; go to unlock2; end; go to skip_del_entry; /* This entry is called from inside append, when creating an upgraded directory. Parent and new dir are both locked at this point */ qmove_mylock: entry (a_ep, a_dp1, a_qchange, a_seg_or_dir, a_code); dir_quota_sw = a_seg_or_dir; /* Copy switch */ qt = fixed (dir_quota_sw, 1); mylock_entry = "1"b; ep = a_ep; parent_dp = ptr (ep, 0); dp = a_dp1; /* are already locked */ qchange = a_qchange; uid = dir.uid; pvid = dir.pvid; vtocx = dir.vtocx;/* Copy vars */ call vtoc_attributes$get_quota (uid, pvid, vtocx, addr (qcell), qt, code); if code ^= 0 then go to errxit; parent_uid = parent_dp -> dir.uid; parent_pvid = parent_dp -> dir.pvid; parent_vtocx = parent_dp -> dir.vtocx; call vtoc_attributes$get_quota (parent_uid, parent_pvid, parent_vtocx, addr (parent_qcell), qt, code); if code ^= 0 then go to errxit; if qchange = 0 then /* If quota change arg is zero, */ qchange = -qcell.quota; /* ..take the whole thing */ skip_del_entry: if ^dir_quota_sw & dir.master_dir then do; code = error_table_$master_dir; /* Apples an oranges */ if mylock_entry then go to errxit; go to unlock2; end; if qchange = 0 then do; /* If useless call */ code = 0; if mylock_entry then go to errxit; go to unlock2; end; if ^parent_qcell.terminal_quota_sw then do; /* None to move */ code = error_table_$invalid_move_qmax; if mylock_entry then go to errxit; go to unlock2; end; /* get pointers to AST entries for both directories */ sstp = addr (sst_seg$); /* Get SST */ astep = activate (ep, code); /* Activate son */ parent_astep = ptr (sstp, aste.par_astep); /* this is active because son is active */ /* update trp for both directories, since we may cause a sudden change to used */ qcell.used = aste.used (qt); /* Copy from AST */ parent_qcell.used = parent_astep -> aste.used (qt); curtime = bit (bin (clock (), 52), 52); /* same as above */ /* calc & add the time-page product which is in page-seconds */ dt = fixed (curtime, 36) - fixed (parent_qcell.tup, 36); /* time since trp was last updated */ parent_qcell.trp = parent_qcell.trp + fixed ((dt * parent_qcell.used) * SEC_PER_TICK + .5e0, 71); parent_qcell.tup = curtime; was_terminal = qcell.terminal_quota_sw; /* indicator if directory currently has terminal quota */ if was_terminal then do; /* only update son if it is terminal */ dt = fixed (curtime, 36) - fixed (qcell.tup, 36); /* time since trp was last updated */ qcell.trp = qcell.trp + fixed ((dt * qcell.used) * SEC_PER_TICK + .5e0, 71); qcell.tup = curtime; end; call quotaw$mq (parent_astep, astep, qchange, dir_quota_sw, code); /* change quotas and maybe used with ptl locked */ if code ^= 0 then do; /* one if the quotas didn't cover the used */ call lock$unlock_ast; if mylock_entry then go to errxit; /* don't unlock */ else go to unlock2; end; qcell.quota = aste.quota (qt); /* change quotas in the VTOCEs */ parent_qcell.quota = parent_astep -> aste.quota (qt); now_terminal, qcell.terminal_quota_sw = aste.tqsw (qt); /* terminal status of directory may have changed */ /* clean up trps in case terminal status of directory has changed */ if was_terminal ^= now_terminal then do; /* Did status of inferior change? */ if was_terminal then do; parent_qcell.trp = parent_qcell.trp + qcell.trp; /* carry total trp up to parent */ end; else do; qcell.tup = curtime; end; qcell.trp = 0; /* just so it doesn't get charged twice */ end; qcell.received = qcell.received + qchange; /* Adjust total quota at this node */ call lock$unlock_ast; /* Unlock AST */ call vtoc_attributes$set_quota (uid, pvid, vtocx, /* Write back */ addr (qcell), qt, code); call vtoc_attributes$set_quota (parent_uid, parent_pvid, parent_vtocx, addr (parent_qcell), qt, code); if ^mylock_entry then do; /* usually must unlock */ call sum$dirmod (dp); /* indicate directory and parent modified */ if called_find then call dc_find$finished (dp, "1"b); else call lock$dir_unlock (dp); call lock$dir_unlock (parent_dp); end; a_code = code; return; /* * * * * * * * * * * * * * * * * * * * * * */ /* Error handlers */ unlock2: if not_root then call lock$dir_unlock (parent_dp); done: unlock1: if called_find then call dc_find$finished (dp, locked); else call lock$dir_unlock (dp); errxit: a_code = code; /* set return error code */ return; /* * * * * * * * * * * * * * * * * * * * * * */ /* Internal procedure to get directory's quota cell */ get_quota_cell: proc; uid = dir.uid; pvid = dir.pvid; vtocx = dir.vtocx;/* Copy vars */ call vtoc_attributes$get_quota (uid, pvid, vtocx, addr (qcell), qt, code); if code ^= 0 then go to unlock1; end get_quota_cell; /* * * * * * * * * * * * * * * * * * * * * * */ /* Internal procedure to make segment be active */ make_seg_active: proc (dpt) returns (ptr); /* Returns astep */ dcl dpt ptr parameter; /* .. given entry ptr */ dcl ASTep ptr; if dpt -> dir.uid = ROOT_UID then do; /* root's active already */ not_root = "0"b; return (sst$root_astep); end; else do; /* no root */ call sum$getbranch (dpt, read_lock, dep, code); /* get branch (lock parent) */ if code ^= 0 then return (null); ASTep = activate (dep, code); /* Activate thing */ end; return (ASTep); end make_seg_active; %page; %include aim_template; %page; %include aste; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include dir_header; %page; %include fs_obj_access_codes; %page; %include quota_cell; end quota;  quota_util.pl1 11/11/89 1132.4rew 11/11/89 0800.6 16272 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ quota_util$suspend_quota: proc; /* Set switch for this process' PDS */ dcl switch_val fixed bin(17), pdsp ptr, (pds$quota_inhib ext, pdsval based(pdsp)) fixed bin(17); switch_val = 1; /* Suspend quota checking for this process */ go to this_process_common; restore_quota: entry; /* clear switch */ switch_val = 0; this_process_common: pds$quota_inhib = switch_val; return; /* Following code is commented out, may be completed and de-commented if it is ever desired to suspend the quota for any process other than one which may call hphcs_$(suspend/restore)_quota in its own right. suspend_proc_quota: entry(pid, code); dcl pid fixed bin(35), code fixed bin(17); switch_val = 1; go to find_pdir; restore_proc_quota: entry(pid, code); switch_val = 0; find_pdir: uc = unique_chars(addr(pid) -> bit36b); ... call initiate(pdir, "pds", "", 1, 0, pdsp, code); if pdsp = null then return; pdsp = ptr(pdsp, rel(addr(pds$quota_inhib)); code = 0; pdsp -> pdsval = switch_val; call terminate_noname(pdsp, ignore_code); End of commented code */ end quota_util$suspend_quota;  reclassify.pl1 11/11/89 1132.4r w 11/11/89 0800.0 180252 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Initial coding by Kobziar July 74 */ /* Modified 750523 by LJS to add protection auditing */ /* Modified June 1, 1976 by R. Bratt to call find_$finished */ /* Modified Nov 30 76 by B. Greenberg for setting dtem */ /* Modified September 1981 by J. Bongiovanni for better error codes */ /* Modified March 1983 by E. N. Kittlitz to not set dtem back */ /* Modified August 1983 by E. N. Kittlitz for setfaults$if_active pvid, vtocx args */ /* Modified 83-10-10 by E. N. Kittlitz to fix locking problems */ /* Modified 83-12-07 by E. N. Kittlitz to audit setting node oos */ /* Modified July 1984 by Keith Loepere to use the new dc_find. Also to flush PAM on dir reclassify. */ /* Modified November 1984 by Keith Loepere for access_audit_ and for PAM using uid's. */ /* Modified 84-12-05 by EJ Sharpe to actually use access_audit_ (also new sys_seg_priv entry) */ /* Modified 85-04-01 by Keith Loepere for access_audit_check_ep_. */ /* format: style4 */ reclassify: proc; /* Parameters */ dcl a_access_class bit (72) aligned; dcl a_code fixed bin (35); dcl a_dirname char (*); dcl a_ename char (*); /* Variables */ dcl access_class bit (72) aligned; dcl branch_name char (32); dcl branchp ptr; dcl code fixed bin (35); dcl dep ptr; dcl dep_locked bit (1) aligned; dcl dirname char (168); dcl dirpath char (168); dcl ename char (32); dcl ep_locked bit (1) aligned; dcl 1 event_flags aligned like audit_event_flags; dcl has_zero_quota bit (1); dcl 1 local_vtoce like vtoce aligned; dcl oosw_err bit (1) aligned; dcl parent_access_class bit (72) aligned; dcl pvtx fixed bin (17); dcl 1 qcell like quota_cell aligned; dcl quota_err bit (1) aligned; dcl relp bit (18); dcl set_soos bit (1) aligned; dcl targp ptr; dcl targp_locked bit (1) aligned; dcl whoami char (24) aligned; /* Entries */ dcl access_audit_check_ep_$self entry (bit (36) aligned, bit (36) aligned, ptr) returns (bit (1)); dcl access_audit_$log_entry_ptr entry options (variable); dcl access_audit_$log_obj_class entry options (variable); dcl aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl aim_check_$greater entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl change_dtem entry (ptr); dcl display_access_class_ entry (bit (72) aligned) returns (char (32) aligned); dcl get_pvtx entry (bit (36) unaligned, fixed bin (35)) returns (fixed bin (17)); dcl level$get entry () returns (fixed bin); dcl lock$dir_unlock entry (ptr); dcl lock$lock_ast entry; dcl lock$unlock_ast entry; dcl logical_volume_manager$lvtep entry (bit (36) aligned, ptr, fixed bin (35)); dcl pathname_am$flush entry (bit (36) aligned); dcl setfaults$if_active entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (1) aligned); dcl sum$dirmod entry (ptr); dcl sum$getbranch entry (ptr, bit (36) aligned, ptr, fixed bin (35)); dcl syserr$error_code entry options (variable); dcl vtoc_attributes$get_quota entry (bit (36) aligned, bit (36) aligned, fixed bin (17), ptr, fixed bin, fixed bin (35)); dcl vtoc_man$get_vtoce entry (bit (36) aligned, fixed bin (17), fixed bin (17), bit (3) aligned, ptr, fixed bin (35)); dcl vtoc_man$put_vtoce entry (bit (36) aligned, fixed bin (17), fixed bin (17), bit (3) aligned, ptr, fixed bin (35)); /* External */ dcl access_operations_$fs_obj_reclassify bit (36) aligned ext static; dcl access_operations_$fs_obj_set_soos bit (36) aligned ext static; dcl error_table_$action_not_performed fixed bin (35) ext static; dcl error_table_$ai_out_range fixed bin (35) ext static; dcl error_table_$ai_parent_greater fixed bin (35) ext static; dcl error_table_$ai_son_less fixed bin (35) ext static; dcl error_table_$argerr fixed bin (35) ext static; dcl error_table_$bad_ring_brackets fixed bin (35) ext static; dcl error_table_$dirseg fixed bin (35) ext static; dcl error_table_$no_terminal_quota fixed bin (35) ext static; dcl error_table_$nondirseg fixed bin (35) ext static; dcl error_table_$not_a_branch fixed bin (35) ext static; dcl error_table_$rqover fixed bin (35) ext static; dcl error_table_$soos_set fixed bin (35) ext static; dcl error_table_$vtoce_connection_fail fixed bin (35) ext static; dcl pds$processid bit (36) aligned ext; dcl sys_info$access_class_ceiling bit (72) aligned ext static; /* Misc */ dcl (addr, fixed, null, ptr, rtrim, string) builtin; %page; /* change branch's access_class to value of parent, called through system_privilege_ gate */ branch: entry (a_dirname, a_ename, a_access_class, a_code); whoami = "reclassify$branch"; call setup; /* process args and get ptrs */ if ep -> entry.dirsw then do; code = error_table_$dirseg; go to unlock_all; end; dir.modify = pds$processid; call set_access_class (ep, parent_access_class, dirname, ename); /* Set the access class */ if code = 0 then /* Force ring 1 multiclass bit off */ call set_r1mc (ep -> entry.multiple_class, "0"b, dirname, ename); go to finish_seg; %page; /* change seg to be multi class, called through system_privilege_ gate */ sys_seg_priv: entry (a_dirname, a_ename, a_access_class, a_code); whoami = "reclassify$sys_seg_priv"; goto sys_seg_join; /* change seg to be multi class, called through admin_gate_ from ring 1 */ sys_seg: entry (a_dirname, a_ename, a_access_class, a_code); whoami = "reclassify$sys_seg"; sys_seg_join: call setup; if ^aim_check_$greater (access_class, parent_access_class) then do; /* must be higher */ code = error_table_$action_not_performed; go to unlock_all; end; if ep -> entry.dirsw then do; code = error_table_$dirseg; go to unlock_all; end; if ep -> entry.ring_brackets (3) ^= "001"b then do; /* must be ring 1 */ code = error_table_$bad_ring_brackets; go to unlock_all; end; dir.modify = pds$processid; call set_access_class (ep, access_class, dirname, ename); /* Set the access class */ if code = 0 then /* Force ring 1 multiclass bit on */ call set_r1mc (ep -> entry.multiple_class, "1"b, dirname, ename); finish_seg: call setfaults$if_active ((ep -> entry.uid), /* be conservative, call even if code ^= 0 */ (ep -> entry.pvid), (ep -> entry.vtocx), "1"b); dir.modify = "0"b; if code = 0 then call sum$dirmod (dp); /* reflect modification up for backup to find */ /* note: we don't soos parent if this failed */ call dc_find$finished (dp, "1"b); /* unlock and unuse */ go to ret; %page; /* change access class of directory and contents */ node: entry (a_dirname, a_ename, a_access_class, a_code); whoami = "reclassify$node"; call setup; if ^ep -> entry.dirsw then do; code = error_table_$nondirseg; go to unlock_all; end; call vtoc_attributes$get_quota (ep -> entry.uid, (ep -> entry.pvid), (ep -> entry.vtocx), addr (qcell), 0, code); if code ^= 0 then go to unlock_all; has_zero_quota = ^qcell.terminal_quota_sw; call lock$dir_unlock (dp); /* all done with dp for now (will re-get via sum when done with node) */ /* see if dir will be upgraded */ ep_locked = "0"b; if aim_check_$greater (access_class, parent_access_class) then if has_zero_quota then do; /* refuse to do operation */ code = error_table_$no_terminal_quota; go to unlock_all; end; else ; /* ok upgraded dir */ else if ^aim_check_$equal (access_class, parent_access_class) then do; /* don't accept lower than parent */ code = error_table_$action_not_performed; go to unlock_all; end; %page; /* now reset access class and check multi class bit */ /* must go to completion in the following loop for a consistent directory */ targp -> dir.modify = pds$processid; relp = targp -> dir.entryfrp; do while (relp ^= "0"b); /* reset access_class if necessary */ branchp = ptr (targp, relp); branch_name = ptr (targp, branchp -> entry.name_frp) -> names.name; if ^branchp -> entry.dirsw then if branchp -> entry.bs then do; /* a segment */ if aim_check_$greater (branchp -> entry.access_class, access_class) then if branchp -> entry.multiple_class then go to fine; /* all other segments get access class reset (or corrected) */ call set_access_class (branchp, access_class, dirpath, branch_name); call set_r1mc (branchp -> entry.multiple_class, "0"b, dirpath, branch_name); call setfaults$if_active ((branchp -> entry.uid), (branchp -> entry.pvid), (branchp -> entry.vtocx), "1"b); end; /* now for directories */ if branchp -> entry.dirsw then if aim_check_$equal (branchp -> entry.access_class, access_class) then call set_r1mc (branchp -> entry.multiple_class, "0"b, dirpath, branch_name); else if aim_check_$greater (branchp -> entry.access_class, access_class) then call set_r1mc (branchp -> entry.multiple_class, "1"b, dirpath, branch_name); else do; /* this directory doesn't fit */ if ^branchp -> entry.security_oosw then do; if access_audit_check_ep_$self (string (event_flags), access_operations_$fs_obj_set_soos, branchp) then call access_audit_$log_entry_ptr (whoami, level$get (), string (event_flags), access_operations_$fs_obj_set_soos, branchp, error_table_$ai_parent_greater, null (), 0, "Parent class: ^a", display_access_class_ (access_class)); end; branchp -> entry.security_oosw = "1"b; oosw_err = "1"b; end; fine: relp = branchp -> entry.efrp; end; if set_soos then go to finish_node; targp -> dir.access_class = access_class; %page; /* now check all upgraded directories for quota */ /* this loop seperate from above since locking failure not critical */ relp = targp -> dir.entryfrp; do while (relp ^= "0"b); branchp = ptr (targp, relp); if branchp -> entry.dirsw then if aim_check_$greater (branchp -> entry.access_class, access_class) then do; call vtoc_attributes$get_quota (branchp -> entry.uid, (branchp -> entry.pvid), (branchp -> entry.vtocx), addr (qcell), 0, code); if code ^= 0 then go to q_err; if ^qcell.terminal_quota_sw then do; q_err: if ^branchp -> entry.security_oosw then if access_audit_check_ep_$self (string (event_flags), access_operations_$fs_obj_set_soos, branchp) then call access_audit_$log_entry_ptr (whoami, level$get (), string (event_flags), access_operations_$fs_obj_set_soos, branchp, error_table_$no_terminal_quota, null (), 0); branchp -> entry.security_oosw = "1"b; quota_err = "1"b; end; end; relp = branchp -> entry.efrp; end; %page; /* fix branch in parent */ finish_node: call sum$getbranch (targp, "1"b, ep, code); /* get ep again (could change via on-line salvage) */ if code ^= 0 then do; /* stop the world, I want to get off */ call syserr$error_code (CRASH, code, "reclassify: err locking parent"); go to unlock_all; /* just in case we come back... */ end; ep_locked = "1"b; dp = ptr (ep, 0); /* reaffirm dp */ dir.modify = pds$processid; if set_soos then do; if access_audit_check_ep_$self (string (event_flags), access_operations_$fs_obj_set_soos, ep) then call access_audit_$log_entry_ptr (whoami, level$get (), string (event_flags), access_operations_$fs_obj_set_soos, ep, error_table_$ai_son_less, null (), 0); entry.security_oosw = "1"b; /* zap main dir */ end; call set_access_class (ep, access_class, dirname, ename); if code = 0 then call set_r1mc (ep -> entry.multiple_class, aim_check_$greater (access_class, parent_access_class), dirname, ename); /* Set multi-class bit */ if code = 0 then if quota_err then code = error_table_$rqover; else if oosw_err | set_soos then code = error_table_$soos_set; /* signal oosw problem */ targp -> dir.modify = "0"b; call sum$dirmod (targp); call pathname_am$flush (ep -> entry.uid); dir.modify = "0"b; call sum$dirmod (dp); call lock$dir_unlock (dp); call dc_find$finished (targp, "1"b); /* unlock and unuse */ ret: a_code = code; return; unlock_all: /* we come here only if the operation is denied due to some aim restriction or improper operation */ event_flags.grant = "0"b; call access_audit_$log_obj_class (whoami, level$get (), string (event_flags), access_operations_$fs_obj_reclassify, access_class, target (dirname, ename), code, null (), 0); if targp_locked then do; /* dirs held by targp */ if dep_locked then call lock$dir_unlock (ptr (dep, 0)); if ep_locked then do; dp -> dir.modify = "0"b; call lock$dir_unlock (ptr (ep, 0)); end; targp -> dir.modify = "0"b; call dc_find$finished (targp, "1"b); end; else do; if dep_locked then call lock$dir_unlock (ptr (dep, 0)); dir.modify = "0"b; call dc_find$finished (dp, "1"b); /* unlock and unuse */ end; go to ret; %page; /* get entry and check access */ setup: proc; dcl lvid bit (36) aligned; string (event_flags) = ""b; event_flags.special_op = "1"b; event_flags.grant = "1"b; /* for now */ if whoami ^= "reclassify$sys_seg" /* this one's refed through admin_gate_ */ then event_flags.priv_op = "1"b; pvt_arrayp = addr (pvt$array); dep_locked, ep_locked, oosw_err, quota_err, set_soos, targp_locked = "0"b; access_class = a_access_class; /* copy args */ if aim_check_$greater_or_equal (sys_info$access_class_ceiling, access_class) then code = 0; else do; /* check arg */ code = error_table_$argerr; go to ret; end; dirname = a_dirname; ename = a_ename; /* the calls to dc_find below may generate an audit message thus, it's OK to simply return without additional auditing if either fails. */ if whoami = "reclassify$node" then do; if dirname = ">" then dirpath = ">" || ename;/* now check out the directory */ else dirpath = rtrim (dirname) || ">" || ename; call dc_find$dir_reclassify (dirpath, dep, ep, targp, code); if code ^= 0 then go to ret; targp_locked = "1"b; end; else do; call dc_find$obj_reclassify (dirname, ename, dep, ep, code); if code ^= 0 then go to ret; end; ep_locked = "1"b; dp = ptr (ep, 0); if dep ^= null then dep_locked = "1"b; if ^ep -> entry.bs then do; /* this is a link */ code = error_table_$not_a_branch; go to unlock_all; end; if whoami = "reclassify$node" then lvid = entry.sons_lvid; /* check AIM for volume */ else do; pvtx = get_pvtx (entry.pvid, code); if code ^= 0 then go to unlock_all; lvid = pvt_array (pvtx).lvid; end; call logical_volume_manager$lvtep (lvid, lvtep, code); /* check lv mounted, AIM range */ if code ^= 0 then go to unlock_all; /* oh well */ if ^aim_check_$greater_or_equal (access_class, lvte.access_class.min) | ^aim_check_$greater_or_equal (lvte.access_class.max, access_class) then do; code = error_table_$ai_out_range; go to unlock_all; end; if dep_locked then do; parent_access_class = dep -> entry.access_class; call lock$dir_unlock (ptr (dep, 0)); dep_locked = "0"b; /* remember not to do this again when finishing */ end; else parent_access_class = "0"b; end setup; %page; set_access_class: proc (set_ep, to_this, dirname, ename); dcl dirname char (168) parameter; dcl ename char (32) parameter; dcl set_ep ptr parameter; dcl to_this bit (72) aligned parameter; dcl pvid bit (36); dcl uid bit (36) aligned; dcl vtocx fixed bin (17); /* reclassify$(branch sys_seg sys_seg_priv) call this to set the new access class of the segment in its entry and vtoce. reclassify$node calls this once for each segment in the dir being reclassified, and finally once for the directory itself. "set_soos" is set if the operation failed so reclassify$node will set security-out-of-service on the containing dir that is being reclassified. */ if access_audit_check_ep_$self (string (event_flags), access_operations_$fs_obj_reclassify, set_ep) then call access_audit_$log_entry_ptr (whoami, level$get (), string (event_flags), access_operations_$fs_obj_reclassify, set_ep, 0, null (), 0, "New class: ^a", display_access_class_ (to_this)); pvid = set_ep -> entry.pvid; /* do vtoce first */ uid = set_ep -> entry.uid; vtocx = set_ep -> entry.vtocx; /* copy args before ASTlocking */ call lock$lock_ast; pvtx = get_pvtx (pvid, code); if code ^= 0 then go to bust; call vtoc_man$get_vtoce ((pvid), pvtx, vtocx, "101"b, addr (local_vtoce), code); /* read activation + part 3 */ if code ^= 0 then go to bust; if local_vtoce.uid ^= uid then do; code = error_table_$vtoce_connection_fail; go to bust; end; addr (local_vtoce) -> vtoce.access_class = to_this; call vtoc_man$put_vtoce ((pvid), pvtx, vtocx, "001"b, addr (local_vtoce), code); /* but only write part 3 */ bust: call lock$unlock_ast; if code = 0 then do; set_ep -> entry.access_class = to_this; call change_dtem (set_ep); /* Cause access recomputation */ end; else set_soos = "1"b; return; end set_access_class; %page; set_r1mc: proc (set_this, to_this, dirname, ename); dcl dirname char (168) parameter; dcl ename char (32) parameter; dcl set_this bit (1) parameter; dcl to_this bit (1) parameter; dcl type (0:1) char (12) aligned static options (constant) init ("single-class", "upgraded"); if set_this ^= to_this then do; /* we'll already have logged with entry data by reclassifying, so here we'll just log a text message, no binary */ call access_audit_$log_obj_class (whoami, level$get (), string (event_flags), access_operations_$fs_obj_reclassify, access_class, target (dirname, ename), 0, null (), 0, "Changed to ^a", type (fixed (to_this, 1))); end; set_this = to_this; return; end set_r1mc; %page; target: proc (dir, ent) returns (char (*)); dcl dir char (*) parameter; dcl ent char (*) parameter; if dir = ">" then return (">" || ent); else return (rtrim (dir) || ">" || ent); end target; /* format: off */ %page; %include access_audit_eventflags; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include dir_header; %page; %include dir_name; %page; %include lvt; %page; %include pvte; %page; %include quota_cell; %page; %include vtoce; %page; %include syserr_constants; %page; /* format: on */ /* BEGIN MESSAGE DOCUMENTATION Message: reclassify: err locking parent. ERROR_CODE S: $crash T: $run M: $err $crashes A: $recover Message: AUDIT (reclassify$ENTRY): GRANTED modification of security out-of-service ADDED_INFO S: $access_audit T: $run M: An AIM error was found in respect to the specified directory. There was a disagreement in access class between the directory and one of it's sons, or there was an upgraded directory with non-terminal quota. A: $ignore Message: AUDIT (reclassify$ENTRY): GRANTED|DENIED modification of fs_obj access class ADDED_INFO S: $access_audit T: $run M: Indicates whether an attempt to reclassify the specified file system object was granted or denied. In the case of reclassify$node, a message will be generated for each entry in the directory being reclassified. A: $ignore END MESSAGE DOCUMENTATION */ end reclassify;  ring0_init.pl1 11/11/89 1132.4rew 11/11/89 0800.6 21492 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ ring0_init: proc ; /* last modified by Kobziar 1/25/75 to call priv_init entries */ /* last modified by Greenberg 05/27/76 who changed it back again, and added terminate entries. */ /* last modified by Loepere 11/05/84 to rename terminate to terminate_. */ dcl (level$get, level$set) ext entry (fixed bin) ; dcl initiate ext entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)) ; dcl initiate$initiate_count ext entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)) ; dcl terminate_$noname entry (ptr, fixed bin (35)); dcl terminate_$teseg entry (ptr, fixed bin (1), fixed bin (35)); dcl (dirname, ename, rname) char (*) ; dcl tcode fixed bin (35); dcl tsptr ptr; dcl tsw fixed bin (1); dcl segsw fixed bin (1) ; dcl copysw fixed bin (2) ; dcl count fixed bin (24) ; dcl segptr ptr ; dcl code fixed bin (35) ; dcl save_level fixed bin ; dcl esw fixed bin ; initiate: entry (dirname, ename, rname, segsw, copysw, segptr, code) ; esw = 1 ; goto start ; initiate_count: entry (dirname, ename, rname, count, copysw, segptr, code) ; esw = 2 ; go to start; terminate_noname: entry (tsptr, tcode); esw = 3; go to start; terminate_seg: entry (tsptr, tsw, tcode); esw = 4; start: call level$get (save_level) ; call level$set (0) ; if esw = 1 then call initiate (dirname, ename, rname, segsw, copysw, segptr, code) ; else if esw = 2 then call initiate$initiate_count (dirname, ename, rname, count, copysw, segptr, code); else if esw = 3 then call terminate_$noname (tsptr, tcode); else if esw = 4 then call terminate_$teseg (tsptr, tsw, tcode); call level$set (save_level) ; return ; end ;  ring_0_peek.pl1 11/11/89 1132.4r w 11/11/89 0800.6 45432 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ /* RING-0-PEEK --- Procedure to return to a user in arbitrary ring the contents of arbitrary supervisor segments. Converted from EPL to PL/I by C Garman, December 1970 VTOCE dumping by BSG 4/20/76 New PVTE include file by J. Bongiovanni, March 1982 Support 256K segments, E. N. Kittlitz, March 1983 Removed access check (let hardware do it), Keith Loepere, October 1984. */ ring_0_peek: proc (a_from_ptr, a_to_ptr, a_num_words); /* Parameters */ dcl a_code fixed bin (35) parameter; dcl a_from_ptr ptr parameter; dcl a_message char (*) parameter; dcl a_num_words fixed bin (19) parameter; dcl a_pvtx fixed bin parameter; dcl a_to_ptr ptr parameter; dcl a_vtocx fixed bin parameter; dcl a_vtocep ptr parameter; /* Variables */ dcl code fixed bin (35); dcl from_ptr ptr; dcl i fixed bin (18); dcl 1 local_vtoce like vtoce aligned; dcl num_words fixed bin (19); dcl patch_mem bit (1) aligned; dcl pvid bit (36) aligned; dcl pvtx fixed bin; dcl rel_from_ptr fixed bin (18); dcl rel_to_ptr fixed bin (18); dcl vtocx fixed bin; dcl to_ptr ptr; /* Entries */ dcl pmut$cam entry; dcl syserr entry options (variable); dcl vtoc_man$get_vtoce entry (bit (36) aligned, fixed bin, fixed bin, bit (3) aligned, ptr, fixed bin (35)); /* External */ dcl error_table_$invalid_pvtx fixed bin (35) ext; dcl pds$process_group_id char (32) aligned ext; dcl pvt$n_entries fixed bin ext; dcl sys_info$seg_size_256K fixed bin (19) ext static; /* Based */ dcl move_array (num_words) fixed bin (35) based; /* Misc */ dcl (addr, fixed, max, rel, size) builtin; %page; patch_mem = "0"b; go to common; patch: entry (a_from_ptr, a_to_ptr, a_num_words); /* Explicit patch, inhibit mode checking */ patch_mem = "1"b; common: from_ptr = a_from_ptr; /* Copy arguments */ to_ptr = a_to_ptr; if patch_mem then addr (to_ptr) -> its.ringno = ""b; else addr (from_ptr) -> its.ringno = ""b; /* force ringno of from ptr to 0 */ num_words = a_num_words; if num_words <= 0 then return; /* A few gullibility tests */ rel_from_ptr = fixed (rel (from_ptr), 18); rel_to_ptr = fixed (rel (to_ptr), 18); if (max (rel_to_ptr, rel_from_ptr) + num_words) > sys_info$seg_size_256K then return; /* Protect the guy from himself */ if patch_mem then do; call syserr (0, "^a: ^d words @ ^p", pds$process_group_id, num_words, to_ptr); /* Print header on console */ do i = 1 to num_words; call syserr (0, "^6o^14w to ^w", i - 1, (to_ptr -> move_array (i)), (from_ptr -> move_array (i))); /* Print before & after, take fault here if no access */ end; call pmut$cam; /* clear caches */ end; to_ptr -> move_array (*) = from_ptr -> move_array (*); /* Use PL/I array copy */ return; /* All paths use this return */ %page; message: entry (a_message); /* Print message from user */ call syserr (3, "^a: ^a", pds$process_group_id, (a_message)); /* Print message, turning on bleeper */ return; /* Return to caller */ %page; vtoce_peek: entry (a_pvtx, a_vtocx, a_vtocep, a_code); num_words = size (vtoce); vtocep = a_vtocep; /* Set up for copy */ pvtx = a_pvtx; vtocx = a_vtocx; if pvtx <= 0 | pvtx > pvt$n_entries then go to bad_pvtx; pvt_arrayp = addr (pvt$array); pvtep = addr (pvt_array (pvtx)); if ^pvte.storage_system | ^pvte.used then do; bad_pvtx: a_code = error_table_$invalid_pvtx; return; end; pvid = pvte.pvid; call vtoc_man$get_vtoce (pvid, pvtx, vtocx, "111"b, addr (local_vtoce), code); /* vtoc_man will validate vtocx */ if code = 0 then vtocep -> move_array = addr (local_vtoce) -> move_array; a_code = code; return; %page; %include disk_pack; %page; %include its; %page; %include pvte; %page; %include vtoce; %page; /* BEGIN MESSAGE DOCUMENTATION Message: PERSON.PROJ.T: NN words @ SSS|XXX .br XXX WWWWWWWWWWWW to YYYYYYYYYYYY .br XXX WWWWWWWWWWWW to YYYYYYYYYYYY S: $beep T: $run M: A privileged user has patched the hardcore supervisor. A: $ignore Message: PERSON.PROJ.T: MESSAGE S: $beep T: $run M: A privileged user has sent a message to be printed on the SYSERR console. A: Read the message and take appropriate action. END MESSAGE DOCUMENTATION */ end ring_0_peek;  ringbr_.pl1 11/11/89 1132.4r w 11/11/89 0800.6 92592 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ ringbr_: proc; /* list or set ring brackets */ /* Modified by E. Swenson 02/21/85 to add get_ring_brackets_seg entry */ /* Modified by Keith Loepere 10/22/84 to audit operation as an access change. */ /* Modified by Keith Loepere 6/12/84 to call the new dc_find. */ /* Modified by Lindsey Spratt 2/22/84 to change DM ringno check from the read bracket to the write bracket */ /* Modified by E. N. Kittlitz 8/8/83 for setfaults$if_active pvid, vtocx args */ /* Modified by Jay Pattin 6/9/83 to not require status permission if you have non-null on the branch for get_ring_brackets */ /* Modified by J. Bongiovanni, September 1982, for Data Management */ /* Modified by C. D. Tavares on 16 March 1979 to correct error codes */ /* Modified by R. Bratt on 06/01/76 to call find_$finished */ /* Modified by BSG, 4/28/75 */ /* Modified by E. Stone 06/74 to convert to version 2 */ /* The entries to this routine are: name ringbr_$get $set $get_dir $set_dir arguments: 1) a_dirname char(*) a directory pathname (Input) 2) a_ename char(*) an entry name (Input) 3) a_rb(3) fixed bin(3) are seg ring brackets (Input for set, Output for get) 3) a_drb(2) fixed bin(3) are dir ringbrackets ( Input for dir_set, Output for dir_get) 4) a_code fixed bin(35) a standard error code (Output) */ dcl a_code fixed bin (35) parameter; dcl a_dirname char (*) parameter; dcl a_drb (2) fixed bin (3) parameter; dcl a_ename char (*) parameter; dcl a_rb (3) fixed bin (3) parameter; dcl a_segptr ptr parameter; dcl directory fixed bin static options (constant) init (2); dcl get fixed bin static options (constant) init (1); dcl segment fixed bin static options (constant) init (1); dcl set fixed bin static options (constant) init (2); dcl code fixed bin (35); dcl d_s bit (1) aligned; dcl drbr (2) fixed bin (3); dcl dirname char (168); dcl entryname char (32); dcl function fixed bin; dcl i fixed bin; dcl lev fixed bin; dcl 1 local_sc_info aligned like sc_info; dcl pathname_supplied bit (1) aligned; dcl pvid bit (36) aligned; dcl rbr (3) fixed bin (3); dcl segptr ptr; dcl type fixed bin; dcl uid bit (36) aligned; dcl username char (32) aligned; dcl vtocx fixed bin; dcl change_dtem ext entry (ptr); dcl check_gate_acl_ ext entry (ptr, bit (1) aligned, fixed bin, char (32) aligned, fixed bin (35)); dcl level$get ext entry (fixed bin); dcl lock$dir_unlock ext entry (ptr); dcl setfaults$if_active ext entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (1) aligned); dcl sum$dirmod ext entry (ptr); dcl vtoc_attributes$get_info ext entry (bit (36) aligned, bit (36) aligned, fixed bin, ptr, fixed bin (35)); dcl error_table_$ai_restricted ext fixed bin (35); dcl error_table_$dirseg ext fixed bin (35); dcl error_table_$invalid_ring_brackets ext fixed bin (35); dcl error_table_$lower_ring ext fixed bin (35); dcl error_table_$not_dm_ring ext fixed bin (35); dcl error_table_$notadir ext fixed bin (35); dcl error_table_$null_info_ptr ext fixed bin (35); dcl pds$processid bit (36) aligned ext; dcl sys_info$data_management_ringno fixed bin ext; dcl (addr, bit, fixed, null, ptr) builtin; %page; /* * * * * * * * * * * * * * */ get: entry (a_dirname, a_ename, a_rb, a_code); /* return segment ring brackets */ function = get; type = segment; pathname_supplied = "1"b; go to start_proc; get_ring_brackets_seg: entry (a_segptr, a_rb, a_code); function = get; type = segment; pathname_supplied = "0"b; go to start_proc; get_dir: entry (a_dirname, a_ename, a_drb, a_code); /* return directory ring brackets */ function = get; type = directory; pathname_supplied = "1"b; go to start_proc; set: entry (a_dirname, a_ename, a_rb, a_code); /* set segment ring brackets */ function = set; type = segment; pathname_supplied = "1"b; go to start_proc; set_dir: entry (a_dirname, a_ename, a_drb, a_code); /* set directory ring brackets */ function = set; type = directory; pathname_supplied = "1"b; go to start_proc; /* * * * * * * * * * * * * * */ start_proc: /* initialization and argument copying */ dp, ep = null (); if pathname_supplied then do; dirname = a_dirname; entryname = a_ename; end; else do; segptr = a_segptr; if segptr = null then go to segptr_null_err; end; code = 0; call level$get (lev); if function = set then do; /* copy input rb & perform consistency checks on them */ if type = segment then do; rbr = a_rb; do i = 1 to 3; if rbr (i) < lev then go to low_ring_err; if rbr (i) > 7 then go to brack_err; end; if rbr (1) > rbr (2) then go to brack_err; if rbr (2) > rbr (3) then go to brack_err; end; else do; drbr = a_drb; do i = 1 to 2; if drbr (i) < lev then go to low_ring_err; if drbr (i) > 7 then go to brack_err; end; if drbr (1) > drbr (2) then go to brack_err; end; end; if pathname_supplied then do; if function = set then call dc_find$obj_access_write (dirname, entryname, 1, FS_OBJ_RING_MOD, ep, code); else call dc_find$obj_attributes_read (dirname, entryname, 1, ep, code); /* chase */ end; /**** Note that we do not handle set_ring_brackets_ptr-type entrypoints in the following code. It is assumed that if these entrypoints are ever added, that the appropriate changes will be made below. There is currently no dc_find$obj_access_write_ptr entrypoint, which, of course, would be necessary if a ringbr_$set_ring_brackets_ptr entry were added. */ else /* can only get here if the entry is get_ring_brackets_ptr */ call dc_find$obj_attributes_read_ptr (segptr, ep, code); if code ^= 0 then go to error_return; dp = ptr (ep, 0); /* get pointer to directory */ d_s = ep -> entry.dirsw; /* pick up directory switch from branch */ if type = directory then /* make sure correct entry (seg or dir) called */ if ^d_s then do; code = error_table_$notadir; /* already checked access, ok to return this code */ go to error_return; end; if type = segment then if d_s then do; code = error_table_$dirseg; /* already checked access, ok to return this code */ go to error_return; end; if function = get then do; /* copy rb from branch into stack array */ if type = segment then rbr = fixed (ep -> entry.ring_brackets, 3); else do; drbr (1) = fixed (ep -> entry.ex_ring_brackets (1), 3); drbr (2) = fixed (ep -> entry.ex_ring_brackets (2), 3); end; end; else do; /* setting rb */ if type = segment then do; /* check level with write bracket */ if lev > fixed (ep -> entry.ring_brackets (1), 3) then go to low_ring_err; if (rbr (2) ^= rbr (3)) /* if turning this into a gate check projects on acl */ & lev > 1 & ep -> entry.acl_frp ^= "0"b then do; call check_gate_acl_ (addr (ep -> entry.acl_frp), "1"b, (ep -> entry.acle_count), username, code); if code ^= 0 then go to error_return; end; if ep -> entry.multiple_class /* see if multiclass AIM seg */ & rbr (3) > 1 then go to aim_err; if (fixed (ep -> entry.ring_brackets (1), 3) <= sys_info$data_management_ringno) & (rbr (1) > sys_info$data_management_ringno) then do; uid = ep -> entry.uid; pvid = ep -> entry.pvid; vtocx = ep -> entry.vtocx; call vtoc_attributes$get_info (uid, pvid, vtocx, addr (local_sc_info), code); if code ^= 0 then goto error_return; if local_sc_info.flags.synchronized then goto dm_ring_error; end; end; /* for dir rb's, check level with modify bracket of directory */ else if lev > fixed (ep -> entry.ex_ring_brackets (1), 3) then go to low_ring_err; dir.modify = pds$processid; /* About to mod directory */ call change_dtem (ep); /* set segment rb */ if type = segment then ep -> entry.ring_brackets = bit (rbr, 3); else do; ep -> entry.ex_ring_brackets (1) = bit (drbr (1), 3); ep -> entry.ex_ring_brackets (2) = bit (drbr (2), 3); end; call setfaults$if_active ((ep -> entry.uid), (ep -> entry.pvid), (ep -> entry.vtocx), "1"b); /* set the dates for backup */ dir.modify = "0"b; call sum$dirmod (dp); end; /* all done setting rb */ if pathname_supplied then call dc_find$finished (dp, DC_FIND_UNLOCK_DIR); /* unlock and unuse directory */ else call lock$dir_unlock (dp); /* unlock directory */ if function = get then do; /* copy rb into caller's space after unlocking dir */ if type = segment then a_rb = rbr; else a_drb = drbr; end; a_code = code; /* copy status code to caller */ return; %page; brack_err: /* input ring brackets were in error */ code = error_table_$invalid_ring_brackets; go to error_common; low_ring_err: code = error_table_$lower_ring; go to error_common; aim_err: code = error_table_$ai_restricted; goto error_common; dm_ring_error: code = error_table_$not_dm_ring; goto error_common; segptr_null_err: code = error_table_$null_info_ptr; goto error_common; error_return: error_common: if dp ^= null then do; if function = set then dir.modify = "0"b; call lock$dir_unlock (dp); if pathname_supplied then call dc_find$finished (dp, "0"b); end; a_code = code; return; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include dir_header; %page; %include fs_obj_access_codes; %page; %include quota_cell; %page; %include sc_info; end;  set.pl1 11/11/89 1132.4rew 11/11/89 0800.0 287253 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-07-01,CLJones), approve(86-08-05,MCR7458), audit(86-06-30,EJSharpe), install(86-08-19,MR12.0-1120): Made damaged and dnzp switch setting respect ring brackets. 2) change(88-03-14,Lippard), approve(88-05-02,MCR7881), audit(88-06-09,Fawcett), install(88-08-02,MR12.2-1074): Added audit_flag_path, for setting entry audit switch (to cause generation of audit messages for all accesses to the object. END HISTORY COMMENTS */ /* format: style4 */ set: proc; /* Modified October 1984, Keith Loepere, for auditing info; also to not allow the setting of bc for upgraded dirs. */ /* Modified June 1984, Keith Loepere, to use the new dc_find. */ /* Modified February 1984, Lindsey Spratt, changed the dm_gino check to be against the write bracket instead of the read bracket. */ /* Modified August 1983, E. N. Kittlitz, setfaults$if_active pvid, vtocx args */ /* Modified March 1983, E. N. Kittlitz, never set dtem back, delete tpd */ /* Modified February 1983, E. N. Kittlitz, 256K max length. */ /* Modified 30 July, 1981, W. Olin Sibert, to change the rules for damaged switch setting */ /* Modified 800409 by PG to add change_bc entries for WOS */ /* Modified 800314 by PG to add entries to set dnzp switch */ /* Modified 07/18/79 by Steve Webber to disallow setting bit count on directories given a pointer */ /* Modified by D.Vinograd 6/76 to add entry to set volume dump control switches */ /* Modified 05/31/76 by R. Bratt to call find_$finished when done */ /* Modified 04/20/76 by R. Bratt to check mountedness of LV */ /* Modified by R. Bratt for setting branch tpd */ /* Modified for NSS 4/75 by THVV: remove actind, use vtoc/aste */ /* Modified by Kobziar 9/74 to call appropriate entry in access_mode */ /* Modified by E. Stone to add entries to change the entry point bound - Aug 1974 */ /* Modified on 12-4-73 by Kobziar to not check for append perm. to set bc */ /* parameters */ dcl a_audit_flag bit (1) aligned parameter; dcl a_auth char (*) parameter; dcl a_bitct fixed bin (24) parameter; dcl 1 a_btimes aligned like based_btimes; dcl a_chasesw fixed bin (1) parameter; dcl a_code fixed bin (35) parameter; dcl a_copy fixed bin (1) parameter; dcl a_damaged_sw bit (1) parameter; dcl a_date bit (36) parameter; dcl a_datep ptr parameter; dcl a_delta_bc fixed bin (24) parameter; dcl a_dirname char (*) parameter; dcl a_dtime fixed bin (52) parameter; /* time dumped */ dcl a_ename char (*) parameter; dcl a_entry_bound fixed bin (14) parameter; dcl a_max_length fixed bin (19) parameter; dcl a_new_bc fixed bin (24) parameter; dcl a_ncd fixed bin parameter; dcl a_nid fixed bin parameter; dcl a_old_bc fixed bin (24) parameter; dcl a_safety_sw bit (1) parameter; dcl a_segptr ptr parameter; dcl a_setp ptr parameter; dcl a_synchronized_sw bit (1) aligned parameter; /* based */ dcl 1 a_reload_set_info aligned based like reload_set_info; dcl 1 based_time based aligned, 2 dtem bit (36), 2 dtd bit (36), 2 dtu bit (36), 2 dtm bit (36); dcl 1 based_btimes based aligned, /* times from backup */ 2 dtem fixed bin (52), 2 dtd fixed bin (52), 2 dtu fixed bin (52), 2 dtm fixed bin (52); /* automatic */ dcl 1 access_name aligned, /* 3 part access name - used for author and bc_author */ 2 person char (32), 2 project char (32), 2 tag char (1); dcl audit_flag bit (1) aligned; dcl auth char (32) aligned; dcl authp ptr; dcl bitct fixed bin (24); dcl bs bit (1) aligned; dcl 1 btimes aligned like based_btimes; dcl chasesw fixed bin (1); dcl check_rb bit (1) aligned; dcl code fixed bin (35); dcl copy fixed bin (1); dcl damaged_sw bit (1) aligned; dcl date bit (36); dcl delta_bc fixed bin (24); dcl detailed_operation fixed bin (18) uns; dcl dirname char (168); dcl dirsw bit (1) aligned; dcl dtm bit (36) aligned; dcl dtu bit (36) aligned; dcl ename char (32); dcl entry_bound fixed bin (14); dcl entry_type fixed bin; dcl find_was_called bit (1) aligned; dcl max_length fixed bin (19); dcl mxl fixed bin (9); dcl ncd fixed bin; dcl new_bc fixed bin (24); dcl nid fixed bin; dcl old_bc fixed bin (24); dcl 1 pc_msk like vtoce_pc_sws aligned; dcl 1 pc_val like vtoce_pc_sws aligned; dcl priv_ml bit (1) aligned init ("0"b); dcl pvid bit (36) aligned; dcl safety_sw bit (1) aligned; dcl segptr ptr; dcl setp ptr; dcl setting_for_reloader fixed bin init (0); dcl synchronized_sw bit (1) aligned; dcl 1 time aligned like based_time; dcl uid bit (36) aligned; dcl val fixed bin (17); dcl vtocx fixed bin; /* constants */ dcl Normal_entry fixed bin init (1) static options (constant); dcl Set_bc_entry fixed bin init (2) static options (constant); dcl Change_bc_entry fixed bin init (3) static options (constant); dcl Dsw_entry fixed bin init (4) static options (constant); dcl Set_bc_entry_priv fixed bin init (5) static options (constant); dcl Normal_priv_entry fixed bin init (6) static options (constant); /* external static */ dcl error_table_$ai_restricted external fixed bin (35); dcl error_table_$argerr external fixed bin (35); dcl error_table_$bad_ring_brackets external fixed bin (35); dcl error_table_$dirseg external fixed bin (35); dcl error_table_$link external fixed bin (35); dcl error_table_$not_a_branch external fixed bin (35); dcl error_table_$not_dm_ring external fixed bin (35); dcl pds$access_name fixed bin (35) external; dcl 1 pds$transparent ext aligned, 2 m bit (1) unaligned, 2 u bit (1) unaligned; dcl sys_info$data_management_ringno fixed bin external; dcl sys_info$seg_size_256K fixed bin (19) external; /* entries */ dcl acc_name_$delete entry (ptr); dcl acc_name_$elements entry (ptr, ptr, fixed bin (35)); dcl acc_name_$encode entry (ptr, ptr, fixed bin (35)); dcl change_dtem entry (ptr); dcl level$get returns (fixed bin (17)); dcl lock$dir_unlock entry (pointer); dcl mountedp entry (bit (36) aligned) returns (fixed bin (35)); dcl setfaults$if_active entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (1) aligned); dcl sum$dirmod entry (pointer); dcl vtoc_attributes$reloading entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (9), fixed bin (35)); dcl vtoc_attributes$set_dates entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl vtoc_attributes$set_dump_switches entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin, fixed bin, fixed bin (35)); dcl vtoc_attributes$set_max_lth entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin (9), bit (1) aligned, fixed bin (35)); dcl vtoc_attributes$set_pc_switches entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (35)); /* builtins */ dcl (addr, binary, bit, clock, fixed, divide, length, ptr, string, substr, unspec) builtin; %page; /* SET$COPYSW changes the setting of the copy switch in the branch effectively pointed to by "entry" in the directory with path name "dirname" to "copy" if caller has write permit in the directory. */ copysw: entry (a_dirname, a_ename, a_copy, a_code); detailed_operation = FS_OBJ_COPY_SW_MOD; copy = a_copy; /* must copy input arguments into stack before locking */ chasesw = 1; check_rb = "1"b; entry_type = Normal_entry; call find_entry; entry.copysw = bit (copy, 1); go to finish; %page; /* SET$AUTH changes the auth variable in the entry "ename" in the directory pointed to by the pathname "dirname" . The entry is "chased" if the chase switch is on. The caller must have write permit on the directory. */ auth: entry (a_dirname, a_ename, a_chasesw, a_auth, a_code); detailed_operation = FS_OBJ_AUTHOR_MOD; chasesw = a_chasesw; auth = a_auth; check_rb = "0"b; entry_type = Normal_entry; call find_entry; authp = addr (entry.author); /* Get pointer to author. */ set_auth: call acc_name_$elements (addr (auth), addr (access_name), code); if code ^= 0 then go to unlock; /* Break up author into 3 part access name. */ call acc_name_$delete (authp); /* Delete previous author if any */ call acc_name_$encode (authp, addr (access_name), code); go to unlock; %page; /* SET$BC changes the setting of the bit count item in the branch effectively pointed to by "entry" in the directory with path name "dirname" to "bitct" if caller has execute permit in the directory and write or append permit in the branch. */ /* SET$BC_SEG is the same as set$bc except that it takes a pointer to a segment rather than "dirname" and "entry" as input arguments. */ bc_seg_priv: entry (a_segptr, a_bitct, a_code); /* privileged bitcount setting - no access check */ entry_type = Set_bc_entry_priv; go to bc_set_ptr_join; bc_seg: entry (a_segptr, a_bitct, a_code); entry_type = Set_bc_entry; bc_set_ptr_join: detailed_operation = FS_OBJ_BC_MOD; bitct = a_bitct; /* copy input args */ check_rb = "0"b; call get_entry_ptr; if dirsw then /* disallow setting bc on directory given pointer */ goto dirseg; go to set_bc; /* Join common code. */ bc: entry (a_dirname, a_ename, a_bitct, a_code); detailed_operation = FS_OBJ_BC_MOD; bitct = a_bitct; /* must copy input arguments into stack before locking */ chasesw = 1; check_rb = "0"b; entry_type = Set_bc_entry; call find_entry; set_bc: if entry.dirsw then if binary (entry.ring_brackets (1), 3) > 1 then if entry.multiple_class then /* implies upgraded */ go to ai_error; entry.bc = bitct; /* actually set the bit count in the entry */ call acc_name_$delete (addr (entry.bc_author)); /* set the bc author */ call acc_name_$encode (addr (entry.bc_author), addr (pds$access_name), code); go to finish; %page; /* SET$CHANGE_BC_PATH adds a specified amount to the bitcount, and returns the old and new bitcount to the caller. It can be used by multiple processes to synchronize their writing to an unstructured segment without any other locking protocol. */ change_bc_path: entry (a_dirname, a_ename, a_delta_bc, a_old_bc, a_new_bc, a_code); detailed_operation = FS_OBJ_BC_MOD; delta_bc = a_delta_bc; chasesw = 1; check_rb = "0"b; entry_type = Change_bc_entry; call find_entry; go to change_bc; /* SET$CHANGE_BC_PTR is the same as set$change_bc_path except that it takes a pointer to a segment. */ change_bc_ptr: entry (a_segptr, a_delta_bc, a_old_bc, a_new_bc, a_code); detailed_operation = FS_OBJ_BC_MOD; delta_bc = a_delta_bc; check_rb = "0"b; entry_type = Change_bc_entry; call get_entry_ptr; if dirsw then go to dirseg; change_bc: old_bc = entry.bc; new_bc, bitct = old_bc + delta_bc; go to set_bc; %page; /* SET$DTD changes the setting of the date time dumped item in the branch effectively pointed to by "entry" in the directory with path name "dirname" to "date" if caller has write permit in the directory . */ /* SET$BACKUP_DUMP_TIME is the same as set$dtd except that it takes a fixed bin (52) time instead of a bit (36) file system time. */ dtd: entry (a_dirname, a_ename, a_date, a_code); date = a_date; /* must copy input argument into stack before locking */ entry_type = Normal_entry; go to set_dtd; /* Join common code. */ backup_dump_time: entry (a_dirname, a_ename, a_dtime, a_code); date = substr (bit (a_dtime, 52), 1, length (date)); /* copy and convert input argument */ entry_type = Normal_priv_entry; set_dtd: detailed_operation = FS_OBJ_DT_DUMPED_MOD; chasesw = 0; check_rb = "0"b; call find_entry; if bs then entry.dtd = date; else link.dtd = date; go to unlock; %page; /* SET$DATES changes the setting of the date time used, date time modified and date time entry modified items in the branch effectively pointed to by "entry" in the directory with path name "dirname" to "date" if caller has write permit in the directory. */ dates: entry (a_dirname, a_ename, a_datep, a_code); detailed_operation = FS_OBJ_DATES_MOD; time = a_datep -> based_time; /* must copy input into stack before locking */ chasesw = 0; check_rb = "0"b; entry_type = Normal_entry; call find_entry; if bs then do; uid = entry.uid; /* Extract unique ID */ pvid = entry.pvid; vtocx = entry.vtocx; dtu = time.dtu; dtm = time.dtm; if dirsw then code = 0; /* assume RLV is always mounted */ else code = mountedp (dir.sons_lvid); /* only if mounted! */ if code = 0 then call vtoc_attributes$set_dates (uid, pvid, vtocx, dtu, dtm, code); if code ^= 0 then go to unlock; entry.dtem = time.dtem; entry.dtd = time.dtd; end; else do; link.dtem = time.dtem; link.dtd = time.dtd; end; go to unlock; %page; /* SET$DUMP_SWITCHES is used to set/reset the dump control switches in the vtoce of a branch. The two switches, no_complete_dump and no incremental dump are set on if the input is positive, off if negative and not set if zero. */ volume_dump_switches: entry (a_dirname, a_ename, a_nid, a_ncd, a_code); detailed_operation = FS_OBJ_VOL_DUMP_SW_MOD; chasesw = 1; check_rb = "1"b; ncd = a_ncd; nid = a_nid; entry_type = Normal_entry; call find_entry; if bs then do; uid = entry.uid; pvid = entry.pvid; vtocx = entry.vtocx; if dirsw then code = error_table_$dirseg; else code = mountedp (dir.sons_lvid); if code = 0 then call vtoc_attributes$set_dump_switches (uid, pvid, vtocx, nid, ncd, code); end; else code = error_table_$link; goto unlock; %page; /* SET$BACKUP_TIMES is used by the reloading process to set the following items in a directory branch: date-time entry modified, date-time dumped, date-time used, date-time modified. */ backup_times: entry (a_dirname, a_ename, a_btimes, a_code); detailed_operation = FS_OBJ_BACKUP_TIMES_MOD; btimes = a_btimes; /* copy structure argument */ chasesw = 0; check_rb = "0"b; entry_type = Normal_entry; call find_entry; if bs then do; uid = entry.uid; /* Extract unique ID */ pvid = entry.pvid; vtocx = entry.vtocx; dtu = substr (bit (btimes.dtu, 52), 1, length (dtu)); dtm = substr (bit (btimes.dtm, 52), 1, length (dtm)); if dirsw then code = 0; /* assume RLV always mounted */ else code = mountedp (dir.sons_lvid); /* only if mounted! */ if code = 0 then call vtoc_attributes$set_dates (uid, pvid, vtocx, dtu, dtm, code); if code ^= 0 then go to unlock; entry.dtem = substr (bit (btimes.dtem, 52), 1, length (entry.dtem)); entry.dtd = substr (bit (btimes.dtd, 52), 1, length (entry.dtd)); end; else do; link.dtem = substr (bit (btimes.dtem, 52), 1, length (link.dtem)); link.dtd = substr (bit (btimes.dtd, 36), 1, length (link.dtd)); end; go to unlock; %page; /* SET$SAFETY_SWITCH_PTR changes the safety switch in the directory entry corresponding to the pointer "segptr". */ /* SET$_SAFETY_SWITCH_PATH is identical to set$safety_switch pointer except that the "ename" and "dirname" are specified instead of a segment pointer. */ safety_sw_ptr: entry (a_segptr, a_safety_sw, a_code); detailed_operation = FS_OBJ_SAFETY_SW_MOD; safety_sw = a_safety_sw; check_rb = "1"b; entry_type = Normal_entry; call get_entry_ptr; go to set_safety; /* Join common code. */ safety_sw_path: entry (a_dirname, a_ename, a_safety_sw, a_code); detailed_operation = FS_OBJ_SAFETY_SW_MOD; safety_sw = a_safety_sw; chasesw = 1; check_rb = "1"b; entry_type = Normal_entry; call find_entry; set_safety: entry.safety_sw = safety_sw; go to finish; %page; /* SET$AUDIT_FLAG_PATH changes the audit switch in the directory entry for the specified path. */ audit_flag_path: entry (a_dirname, a_ename, a_audit_flag, a_code); detailed_operation = FS_OBJ_AUDIT_FLAG_MOD; audit_flag = a_audit_flag; chasesw = 1; check_rb = "1"b; entry_type = Normal_entry; call find_entry; set_audit_flag: entry.audit_flag = audit_flag; go to finish; %page; /* SET$DAMAGED_SW_PTR changes the damaged switch in the directory entry corresponding to the pointer "segptr". */ /* SET$DAMAGED_SW_PATH is identical to set$damaged_sw_ptr except that the "ename" and "dirname" are specified instead of a segment pointer. */ damaged_sw_ptr: entry (a_segptr, a_damaged_sw, a_code); detailed_operation = FS_OBJ_DAMAGED_SW_MOD; damaged_sw = a_damaged_sw; check_rb = "1"b; entry_type = Dsw_entry; call get_entry_ptr; go to set_damaged; /* Join common code. */ damaged_sw_path: entry (a_dirname, a_ename, a_damaged_sw, a_code); detailed_operation = FS_OBJ_DAMAGED_SW_MOD; damaged_sw = a_damaged_sw; chasesw = 1; check_rb = "1"b; entry_type = Dsw_entry; call find_entry; set_damaged: unspec (pc_val) = ""b; unspec (pc_msk) = ""b; pc_val.damaged = damaged_sw; pc_msk.damaged = "1"b; uid = entry.uid; pvid = entry.pvid; vtocx = entry.vtocx; if dirsw then code = 0; else code = mountedp (dir.sons_lvid); if code = 0 then call vtoc_attributes$set_pc_switches (uid, pvid, vtocx, string (pc_val), string (pc_msk), code); if code ^= 0 then go to unlock; go to finish; %page; /* SET$DNZP_SW_PTR changes the dnzp switch in the directory entry corresponding to the pointer "segptr". */ /* SET$DNZP_SW_PATH is identical to set$dnzp_sw_ptr except that the "ename" and "dirname" are specified instead of a segment pointer. */ /* parameters */ declare a_dnzp_sw bit (1) aligned parameter; /* automatic */ declare dnzp_sw bit (1) aligned; /* program */ dnzp_sw_ptr: entry (a_segptr, a_dnzp_sw, a_code); detailed_operation = FS_OBJ_DNZP_MOD; dnzp_sw = a_dnzp_sw; check_rb = "1"b; entry_type = Normal_entry; call get_entry_ptr; go to set_dnzp; /* Join common code. */ dnzp_sw_path: entry (a_dirname, a_ename, a_dnzp_sw, a_code); detailed_operation = FS_OBJ_DNZP_MOD; dnzp_sw = a_dnzp_sw; chasesw = 1; check_rb = "1"b; entry_type = Normal_entry; call find_entry; set_dnzp: if dirsw then go to dirseg; /* Oh no you don't */ unspec (pc_val) = ""b; unspec (pc_msk) = ""b; pc_val.dnzp = dnzp_sw; pc_msk.dnzp = "1"b; uid = entry.uid; pvid = entry.pvid; vtocx = entry.vtocx; if dirsw then code = 0; else code = mountedp (dir.sons_lvid); if code = 0 then call vtoc_attributes$set_pc_switches (uid, pvid, vtocx, string (pc_val), string (pc_msk), code); if code ^= 0 then go to unlock; go to finish; %page; /* SET$SYNCHRONIZED_SW changes the synchronized switch in the VTOCE corresponding to the path supplied. This is used by Data Management to order writes done by Page Control. */ synchronized_sw: entry (a_dirname, a_ename, a_synchronized_sw, a_code); detailed_operation = FS_OBJ_SYNC_SW_MOD; synchronized_sw = a_synchronized_sw; chasesw = 0; check_rb = "1"b; entry_type = Normal_entry; call find_entry; if dirsw then goto dirseg; if fixed (entry.ring_brackets (1), 3) > sys_info$data_management_ringno then do; code = error_table_$not_dm_ring; goto unlock; end; unspec (pc_val) = ""b; unspec (pc_msk) = ""b; pc_val.synchronized = synchronized_sw; pc_msk.synchronized = "1"b; uid = entry.uid; pvid = entry.pvid; vtocx = entry.vtocx; code = mountedp (dir.sons_lvid); if code = 0 then call vtoc_attributes$set_pc_switches (uid, pvid, vtocx, string (pc_val), string (pc_msk), code); if code ^= 0 then goto unlock; goto finish; %page; /* SET$MAX_LENGTH_PTR resets the maximum length of the segment pointed to by "segptr" to the "max_length" specified in words. */ /* SET$MAX_LENGTH_PATH is identical to set$max_length_ptr except that the "ename" and "dirname" of the segment are sepcified instead of the "segptr". */ max_length_ptr: entry (a_segptr, a_max_length, a_code); detailed_operation = FS_OBJ_MAX_LEN_MOD; max_length = a_max_length; check_rb = "1"b; entry_type = Normal_entry; call get_entry_ptr; go to set_max_length; max_length_priv: entry (a_dirname, a_ename, a_max_length, a_code); priv_ml = "1"b; check_rb = "0"b; goto cp_ml_args; max_length_path: entry (a_dirname, a_ename, a_max_length, a_code); check_rb = "1"b; cp_ml_args: detailed_operation = FS_OBJ_MAX_LEN_MOD; max_length = a_max_length; chasesw = 1; entry_type = Normal_entry; call find_entry; set_max_length: if dirsw then go to dirseg; if max_length < 0 then go to argerr; if max_length > sys_info$seg_size_256K then go to argerr; uid = entry.uid; /* Extract unique ID */ pvid = entry.pvid; vtocx = entry.vtocx; mxl = divide (max_length + 1023, 1024, 9, 0); /* Correct units */ code = mountedp (dir.sons_lvid); if code = 0 then call vtoc_attributes$set_max_lth (uid, pvid, vtocx, mxl, priv_ml, code); if code ^= 0 then go to unlock; go to finish; %page; /* SET$BC_AUTH_PATH is used by the reloader to set the bitcount author of the directory entry corresponding to the segment indicated by "ename" and "dirname". */ bc_auth_path: entry (a_dirname, a_ename, a_auth, a_code); detailed_operation = FS_OBJ_BC_AUTHOR_MOD; auth = a_auth; chasesw = 1; check_rb = "0"b; entry_type = Normal_entry; call find_entry; /* no AIM check since privileged entry */ authp = addr (entry.bc_author); /* Get pointer to bit count author. */ go to set_auth; /* Join common author-setting code. */ %page; /* SET$ENTRY_BOUND_PTR sets the entry point bound switch and changes the entry point bound of the segment pointed to by "segptr" to the "entry_bound" specified in words if "entry_bound" is greater than 0. If "entry_bound" equals 0, then the entry point bound switch is reset and the entry point bound is changed to 0. */ /* SET$ENTRY_BOUND_PATH is identical to set$entry_point_ptr except that then "dirname" and "ename" of the segment are specified instead of the "segptr". */ entry_bound_ptr: entry (a_segptr, a_entry_bound, a_code); detailed_operation = FS_OBJ_ENTRY_BOUND_MOD; entry_bound = a_entry_bound; check_rb = "1"b; entry_type = Normal_entry; call get_entry_ptr; go to set_call_limiter; entry_bound_path: entry (a_dirname, a_ename, a_entry_bound, a_code); detailed_operation = FS_OBJ_ENTRY_BOUND_MOD; entry_bound = a_entry_bound; chasesw = 1; check_rb = "1"b; entry_type = Normal_entry; call find_entry; set_call_limiter: if dirsw then go to dirseg; if entry_bound < 0 then go to argerr; /* Limited to 14 bits in sdw */ if entry_bound > 16383 then go to argerr; uid = entry.uid; pvid = entry.pvid; vtocx = entry.vtocx; call setfaults$if_active (uid, pvid, vtocx, "0"b); if entry_bound = 0 then do; entry.entrypt_sw = "0"b; entry.entrypt_bound = "0"b; end; else do; entry.entrypt_sw = "1"b; entry.entrypt_bound = bit (entry_bound, 14); end; go to finish; %page; /* SET$SET_FOR_RELOADER changes a number of variables in the entry "ename" in the directory pointed to by the pathname "dirname". It also makes one call to set appropriate items in the VTOC. The entry is not chased. The caller must have write permit on the directory. It is intended that that this entry in set provide the sum of the functionality of a number of other entries: that is the usual checks are made and status codes are returned. Because this entry can only be reached through a priviliged gate, the max_length is not checked against the current length --- this is not only consistent with the privileged set_max_length entry, but also with the fact that the dumper will never write more meaningfull data than "max_length" to tape */ set_for_reloader: entry (a_dirname, a_ename, a_setp, a_code); detailed_operation = FS_OBJ_FOR_RELOADER_MOD; setp = a_setp; reload_set_info = setp -> a_reload_set_info; /* copy input before locking */ if reload_set_info.version ^= reload_set_version_2 then do; /* called with bad structure */ a_code = error_table_$argerr; return; end; setting_for_reloader = 1; /* remember to return info */ chasesw = 0; check_rb = "0"b; entry_type = Normal_priv_entry; call find_entry; uid = entry.uid; /* Extract unique ID */ pvid = entry.pvid; vtocx = entry.vtocx; if ^bs then do; code = error_table_$not_a_branch; go to unlock; end; if reload_set_info.should_set.safety_sw then /* set the safety_sw? */ entry.safety_sw = reload_set_info.safety_sw; if reload_set_info.should_set.audit_flag then /* set the audit_flag? */ entry.audit_flag = reload_set_info.audit_flag; if reload_set_info.should_set.author then do; /* author? */ authp = addr (entry.author); call acc_name_$elements (addr (reload_set_info.author), addr (access_name), reload_set_info.author_code); if reload_set_info.author_code = 0 then do; /* if no errs proceed */ call acc_name_$delete (authp); call acc_name_$encode (authp, addr (access_name), reload_set_info.author_code); end; end; if reload_set_info.should_set.bc_author then do; /* no AIM check since privileged entry */ authp = addr (entry.bc_author); call acc_name_$elements (addr (reload_set_info.bc_author), addr (access_name), reload_set_info.bc_author_code); if reload_set_info.bc_author_code = 0 then do; call acc_name_$delete (authp); call acc_name_$encode (authp, addr (access_name), reload_set_info.bc_author_code); end; end; /* Now for the tricky part */ /* go to vtoc to set dtm,dtu,mxl */ /* if go to vtoc for mxl, need not do setfaults here */ /* even if setting entry_bound */ if reload_set_info.should_set.dtu then dtu = reload_set_info.dtu; /* dtu = 0 means va$ wont set */ else dtu = "0"b; if reload_set_info.should_set.dtm then dtm = reload_set_info.dtm; /* dtm = 0 means va$ wont set */ else dtm = "0"b; mxl = -1; /* mxl = -1 means va$ wont set, dont setfaults */ if reload_set_info.should_set.max_length then do; if dirsw then reload_set_info.max_length_code = error_table_$dirseg; /* make some checks */ else if reload_set_info.max_length < 0 then reload_set_info.max_length_code = error_table_$argerr; else mxl = divide (reload_set_info.max_length + 1023, 1024, 9, 0); end; if dtm | dtu | mxl >= 0 then do; /* something to set in vtoc */ if dirsw then code = 0; /* RLV always mounted */ else code = mountedp (dir.sons_lvid); /* check mountedness */ if code = 0 then call vtoc_attributes$reloading (uid, pvid, vtocx, dtu, dtm, mxl, code); /* NOTE: for now we are punting the no mounted case */ end; /* vtoc_attr has done setfaults if mxl >= 0 */ if reload_set_info.should_set.entry_bound then do;/* see about epb */ if dirsw then reload_set_info.entry_bound_code = error_table_$dirseg; else if reload_set_info.entry_bound < 0 then reload_set_info.entry_bound_code = error_table_$argerr; else if reload_set_info.entry_bound > 16383 then reload_set_info.entry_bound_code = error_table_$argerr; else do; /* we are willing to set it */ if mxl < 0 | code ^= 0 then /* do setfault now, if not already done */ call setfaults$if_active (uid, pvid, vtocx, "0"b); if reload_set_info.entry_bound = 0 then do; /* clear relevant fields */ entry.entrypt_sw = "0"b; entry.entrypt_bound = "0"b; end; else do; entry.entrypt_sw = "1"b; entry.entrypt_bound = bit (reload_set_info.entry_bound, 14); end; end; end; if reload_set_info.should_set.dtem then /* date time entry modified? */ entry.dtem = reload_set_info.dtem; if reload_set_info.should_set.dtd then /* date time dumped? */ entry.dtd = reload_set_info.dtd; go to finish; %page; /* Update dtem, unlock entry, notify segment control that directory containing entry has been modified and return */ finish: if pds$transparent.m = "0"b then if entry.dtem ^= bit (binary (clock (), 52), 36) then call change_dtem (ep); unlock: call sum$dirmod (dp); if find_was_called then call dc_find$finished (dp, "1"b); else call lock$dir_unlock (dp); if setting_for_reloader ^= 0 then setp -> a_reload_set_info = reload_set_info; else if entry_type = Change_bc_entry then do; a_old_bc = old_bc; a_new_bc = new_bc; end; finale: a_code = code; return; /* Error Handling */ ai_error: code = error_table_$ai_restricted; go to unlock; argerr: code = error_table_$argerr; go to unlock; dirseg: code = error_table_$dirseg; go to unlock; bracket_error: code = error_table_$bad_ring_brackets; goto unlock; %page; /* internal procedures */ find_entry: proc; /* get a pointer to the entry and lock the directory */ code = 0; dirname = a_dirname; ename = a_ename; if entry_type = Normal_entry then call dc_find$obj_status_write (dirname, ename, chasesw, detailed_operation, ep, code); else if entry_type = Set_bc_entry then call dc_find$obj_bc_write (dirname, ename, bitct, ep, code); else if entry_type = Change_bc_entry then call dc_find$obj_bc_delta_write (dirname, ename, delta_bc, ep, code); else if entry_type = Dsw_entry then /* allow no m on parent */ call dc_find$obj_attributes_write (dirname, ename, chasesw, detailed_operation, ep, code); else if entry_type = Set_bc_entry_priv | entry_type = Normal_priv_entry then call dc_find$obj_status_write_priv (dirname, ename, chasesw, detailed_operation, ep, code); dp = ptr (ep, 0); if code ^= 0 then go to finale; find_was_called = "1"b; go to check; get_entry_ptr: entry; /* get a pointer to the entry and lock the directory */ code = 0; segptr = a_segptr; find_was_called = "0"b; if entry_type = Normal_entry then call dc_find$obj_status_write_ptr (segptr, detailed_operation, ep, code); else if entry_type = Set_bc_entry then call dc_find$obj_bc_write_ptr (segptr, bitct, ep, code); else if entry_type = Change_bc_entry then call dc_find$obj_bc_delta_write_ptr (segptr, delta_bc, ep, code); else if entry_type = Dsw_entry then /* allow no m on parent */ call dc_find$obj_attributes_write_ptr (segptr, detailed_operation, ep, code); else if entry_type = Set_bc_entry_priv | entry_type = Normal_priv_entry then call dc_find$obj_status_write_priv_ptr (segptr, detailed_operation, ep, code); dp = ptr (ep, 0); if code ^= 0 then go to finale; check: bs = entry.bs; dirsw = entry.dirsw; if check_rb then do; /* also need to check ring brackets */ val = level$get (); if dirsw then do; if val > fixed (entry.ex_ring_brackets (1), 3) then go to bracket_error; end; else do; if val > fixed (entry.ring_brackets (1), 3) then go to bracket_error; end; end; end find_entry; %page; /* include files */ %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include dir_header; %page; %include dir_link; %page; %include fs_obj_access_codes; %page; %include reload_set_info; %page; %include vtoce_pc_sws; end set;  set_disk_table_loc.pl1 11/11/89 1132.4r w 11/11/89 0800.6 21249 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ set_disk_table_loc: proc (a_segptr, a_code); /* set_disk_table_loc: this procedure is called by system startup to assert the VTOC index of the disk table on the root physical volume. Bernard Greenberg, Oct. 18, 1975. Modified February, 1982, J. Bongiovanni to eliminate FSDCT Modified October 1984, Keith Loepere to use dc_find. */ /* Entries */ dcl fsout_vol external entry (fixed bin); dcl lock$dir_unlock entry (ptr); /* External */ dcl error_table_$action_not_performed fixed bin (35) external; dcl pvt$disk_table_uid bit (36) aligned external; dcl pvt$disk_table_vtocx fixed bin external; dcl pvt$root_pvtx fixed bin external; /* Misc */ dcl (addr, ptr) builtin; /* Parameters */ dcl a_code fixed bin (35); dcl a_segptr ptr; /* pointer to supposed disk table */ /* Variables */ dcl code fixed bin (35); dcl segptr ptr; %page; segptr = a_segptr; /* copy param, we are a gate. */ pvt_arrayp = addr (pvt$array); call dc_find$obj_status_read_priv_ptr (segptr, ep, code); if code ^= 0 then do; a_code = code; return; end; if entry.pvid ^= pvt_array (pvt$root_pvtx).pvid then do; call lock$dir_unlock (ptr (ep, 0)); /* unlock the dir */ a_code = error_table_$action_not_performed; /* Must be on rpv */ return; end; pvt$disk_table_uid = entry.uid; /* Set the info */ pvt$disk_table_vtocx = entry.vtocx; call lock$dir_unlock (ptr (ep, 0)); call fsout_vol (pvt$root_pvtx); /* fsout the RPV */ a_code = 0; return; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include pvte; end;  set_kst_attributes.pl1 11/11/89 1132.4r w 11/11/89 0800.6 22572 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ set_kst_attributes: proc (a_segno, a_kstap, a_code); priv = "0"b; highly_privileged: entry (a_segno, a_kstap, a_code); /* Written 03/26/76 by R. Bratt This procedure allows a sufficiently privileged user to change the segment use attributes stored in his kst. Privileged users may set: allow_write, explicit_deact_ok, tpd, and audit. Highly privileged users may also set: tms, and tus. */ dcl a_segno fixed bin (17), a_kstap ptr, a_code fixed bin (35); dcl segno fixed bin (17), code fixed bin (35), 1 ksta aligned like kst_attributes, priv bit (1) aligned init ("1"b); dcl dseg$ ext, error_table_$action_not_performed ext fixed bin (35); dcl get_kstep entry (fixed bin (17), ptr, fixed bin (35)), setfaults$disconnect entry (fixed bin (17)); segno = a_segno; unspec (ksta) = unspec (a_kstap -> kst_attributes); call get_kstep (segno, kstep, code); if code ^= 0 then do; a_code = code; return; end; if ^priv & (ksta.set.tms | ksta.set.tus) then do; a_code = error_table_$action_not_performed; return; end; if ksta.set.allow_write then do; kste.allow_write = ksta.value.allow_write; sdwp = addr (addr (dseg$) -> sdwa (segno)); /* Get ptr to SDW */ string (sdw.access) = kste.access & ("11"b || kste.allow_write); call setfaults$disconnect (segno); end; if ksta.set.tms then kste.tms = ksta.value.tms; if ksta.set.tus then kste.tus = ksta.value.tus; if ksta.set.tpd then kste.tpd = ksta.value.tpd; if ksta.set.audit then kste.audit = ksta.value.audit; if ksta.set.explicit_deactivate_ok then kste.explicit_deact_ok = ksta.value.explicit_deactivate_ok; a_code = 0; return; /* */ % include kst; /* */ %include kst_attributes; /* */ %include sdw; end set_kst_attributes;  set_privileges.pl1 11/11/89 1132.4r 11/11/89 0800.6 133740 /****^ ****************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright (c) 1987 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ****************************************************** */ /* format: style2,indcomtxt */ set_privileges: procedure; /* Modified 1985-03-04, EJ Sharpe: remove special_op event flags and auditing for ring-1 TCB calls */ /* Modified 1985-01-21, BIM: ring 1 (admin) privilege manipulation. */ /* Modified 84-12-05 by EJ Sharpe to use access_audit_ instead of protection_audit_ */ /* Modified 84-11 BIM, changed to set all privs in apte */ /* Modified May 1983 by E. N. Kittlitz to add communication privilege */ /* Modified 760309 by L.Scheffler to fix excessive auditing calls */ /* Modified by E. Stone on Sept 1975 to change kst when setting directory privileges */ /* Coded 16 Oct. 1974 by D. H. Hunt */ /* This ring 0 procedure is expected to be invoked only by the */ /* system security administrator and by certain SysDaemon processes */ /* which need to bypass the access isolation mechanism (AIM) checks */ /* A process grants itself a particular privilege to bypass AIM checks */ /* by calling one of the "---priv_on" entry points. This sets the */ /* corresponding privilege bit on (="1"b) */ /* A process rescinds a particular privilege for bypassing AIM checks */ /* by calling one of the "---priv_off" entry points. This sets the */ /* corresponding privilege bit off (="0"b) */ declare access_audit_$log_general entry external options (variable); declare access_operations_$system_privilege_modify bit (36) aligned external; declare 1 pds$access_authorization aligned like aim_template external; declare pds$admin_privileges bit (36) aligned external; declare pds$apt_ptr pointer external; declare 1 event_flags aligned like audit_event_flags; declare level$get entry returns (fixed bin (3)); declare ring_alarm$reset entry; declare setfaults$disconnect entry (fixed bin); declare ME char (14) aligned internal static initial ("set_privileges") options (constant); declare P_code fixed bin (35) parameter; declare P_set_privs bit (36) aligned parameter; declare P_old_privs bit (36) aligned parameter; declare changed bit (1) aligned; declare set_privs bit (36) aligned; declare old_privs bit (36) aligned; declare (addr, bit, bool, hbound, length, null, rtrim, string, substr) builtin; %page; admin_set: entry (P_set_privs, P_old_privs); set_privs = P_set_privs; call set_admin_privileges (set_privs, old_privs); /* fixes the KST */ P_old_privs = old_privs; return; admin_reset: entry (P_set_privs); set_privs = P_set_privs; call reset_admin_privileges (set_privs); /* fixes the KST */ P_set_privs = set_privs; return; admin_ring_alarm: /* Called on a ring alarm to get rid of these */ entry; set_privs = bit (string (pds$access_authorization.privileges), 36) & ^pds$admin_privileges; /* construct appropriate priv set */ substr (set_privs, 36, 1) = "1"b; /* Give it something to do */ call reset_admin_privileges (set_privs); pds$admin_privileges = ""b; /* double sure */ return; %page; /* In managing its log buffers, syserr may send a wakeup to the initializer */ /* process. Everything will work OK, since if the wakeup is sent from the */ /* initializer to itself, the wakeup will be allowed regardless of the state */ /* of the IPC privilege bits. If another process sends the wakeup to the */ /* initializer, it will be allowed since the initializer will have IPC privilege */ /* on before other processes are allowed to log in. */ ipc_priv_on: /* disables the AIM check for interprocess communication */ entry (P_code); call set_one_privilege (IPC_PRIVILEGE_X, IPC_PRIVILEGE, changed); if changed then P_code = 0; else P_code = 1; return; ipc_priv_off: /* enables the AIM check for interprocess communication */ entry (P_code); call clear_one_privilege (IPC_PRIVILEGE_X, ^IPC_PRIVILEGE, changed); if changed then P_code = 0; else P_code = 1; return; dir_priv_on: /* disables the AIM checks for directories */ entry (P_code); call set_one_privilege (DIR_PRIVILEGE_X, DIR_PRIVILEGE, changed); if changed then do; call fix_kst; /* cause access to directories to be recalculated */ P_code = 0; end; else P_code = 1; return; dir_priv_off: /* enables the AIM checks for directories */ entry (P_code); call clear_one_privilege (DIR_PRIVILEGE_X, ^DIR_PRIVILEGE, changed); if changed then do; call fix_kst; /* cause access to directories to be recalculated */ P_code = 0; end; else P_code = 1; return; seg_priv_on: /* disables the AIM checks for segments */ entry (P_code); call set_one_privilege (SEG_PRIVILEGE_X, SEG_PRIVILEGE, changed); if changed then do; P_code = 0; call fix_kst_seg; end; else P_code = 1; return; seg_priv_off: /* enables the AIM checks for segments */ entry (P_code); call clear_one_privilege (SEG_PRIVILEGE_X, ^SEG_PRIVILEGE, changed); if changed then do; P_code = 0; call fix_kst_seg; end; else P_code = 1; return; soos_priv_on: /* prevents access to directories which have the */ entry (P_code); /* security out of service attribute turned on */ call set_one_privilege (SOOS_PRIVILEGE_X, SOOS_PRIVILEGE, changed); if changed then P_code = 0; else P_code = 1; return; soos_priv_off: /* allows access to directories which have the */ entry (P_code); /* security out of service attribute turned on */ call clear_one_privilege (SOOS_PRIVILEGE_X, ^SOOS_PRIVILEGE, changed); if changed then P_code = 0; else P_code = 1; return; ring1_priv_on: /* disables the interpretive AIM */ entry (P_code); /* checks in ring one */ call set_one_privilege (RING1_PRIVILEGE_X, RING1_PRIVILEGE, changed); if changed then P_code = 0; else P_code = 1; return; ring1_priv_off: /* enables the interpretive AIM */ entry (P_code); /* checks in ring one */ call clear_one_privilege (RING1_PRIVILEGE_X, ^RING1_PRIVILEGE, changed); if changed then P_code = 0; else P_code = 1; return; rcp_priv_on: /* disables the interpretive AIM */ entry (P_code); /* checks in RCP */ call set_one_privilege (RCP_PRIVILEGE_X, RCP_PRIVILEGE, changed); if changed then P_code = 0; else P_code = 1; return; rcp_priv_off: /* enables the interpretive AIM */ entry (P_code); /* checks in RCP */ call clear_one_privilege (RCP_PRIVILEGE_X, ^RCP_PRIVILEGE, changed); if changed then P_code = 0; else P_code = 1; return; comm_priv_on: /* disables the interpretive AIM */ entry (P_code); /* checks in TCP and dial_ctl_ */ call set_one_privilege (COMM_PRIVILEGE_X, COMM_PRIVILEGE, changed); if changed then P_code = 0; else P_code = 1; return; comm_priv_off: /* enables the interpretive AIM */ entry (P_code); /* checks in comm */ call clear_one_privilege (COMM_PRIVILEGE_X, ^COMM_PRIVILEGE, changed); if changed then P_code = 0; else P_code = 1; return; %page; fix_kst: procedure; dcl segno fixed bin; dcl seg_flag bit (1) aligned; dcl faulted_one bit (1) aligned; seg_flag = "0"b; go to COMMON; fix_kst_seg: entry; seg_flag = "1"b; COMMON: kstp = pds$kstp; /* get pointer to kst */ faulted_one = "0"b; do segno = kstp -> kst.lowseg to kstp -> kst.highest_used_segno; /* whip thru kst looking for dirs */ kstep = addr (kstp -> kst.kst_entry (segno)); if kste.uid ^= ""b then if (kste.dirsw & ^seg_flag) | (^kste.dirsw & ^kste.priv_init & seg_flag) then do; kstep -> kste.dtbm = (36)"1"b;/* set dtbm so that access will be recalculated as needed */ if seg_flag then call setfaults$disconnect (segno); end; end; end fix_kst; %page; set_one_privilege: procedure (privilege_index, privilege_mask, changed); declare changed bit (1) aligned; declare privilege_index fixed bin; declare privilege_mask bit (36) aligned; declare new_privs bit (18) aligned; declare old_privs bit (18) aligned; declare apte_auth_ptr pointer; declare 1 apte_auth aligned like aim_template based (apte_auth_ptr); declare turn_on bit (1) aligned; turn_on = "1"b; go to COMMON; clear_one_privilege: entry (privilege_index, privilege_mask, changed); turn_on = "0"b; COMMON: changed = "0"b; old_privs = string (pds$access_authorization.privileges); /* starts same as old */ if turn_on then new_privs = old_privs | privilege_mask; else new_privs = old_privs & privilege_mask; /* caller ^'s to get ^'ed form in as text constant */ if new_privs = old_privs then return; /* with changed = "0"b */ changed = "1"b; apte_auth_ptr = addr (pds$apt_ptr -> apte.access_authorization); string (apte_auth.privileges), string (pds$access_authorization.privileges) = new_privs; string (event_flags) = ""b; event_flags.grant = "1"b; event_flags.priv_op = "1"b; call access_audit_$log_general (ME, level$get (), string (event_flags), access_operations_$system_privilege_modify, "", 0, null (), 0, "^a turned ^[on^;off^]", system_privilege_names (privilege_index).long, turn_on); return; end set_one_privilege; set_admin_privileges: procedure (new_privileges, old_privileges); declare (new_privileges, old_privileges) bit (36) aligned; declare apte_auth_ptr pointer; declare 1 apte_auth aligned like aim_template based (apte_auth_ptr); declare priv_value bit (18); declare name_string char (100) varying; declare x fixed bin; declare privs_before_set bit (18) aligned; declare different_privs_mask bit (18) aligned; old_privileges = string (pds$access_authorization.privileges); substr (old_privileges, 36, 1) = "1"b; /* Mark the setting */ priv_value = substr (old_privileges, 1, 18) | substr (new_privileges, 1, 18); /* Turn on the new ones */ name_string = ""; do x = 1 to hbound (system_privilege_names, 1); if substr (new_privileges, x, 1) then do; if length (name_string) > 0 then name_string = name_string || ","; name_string = name_string || rtrim (system_privilege_names.short (x)); end; end; apte_auth_ptr = addr (pds$apt_ptr -> apte.access_authorization); privs_before_set = string (pds$access_authorization.privileges); different_privs_mask = bool (privs_before_set, new_privileges, "0110"b); /* XOR */ pds$admin_privileges = pds$admin_privileges | (new_privileges & different_privs_mask); /* mark */ call ring_alarm$reset; string (apte_auth.privileges), string (pds$access_authorization.privileges) = priv_value; if ((priv_value & DIR_PRIVILEGE) ^= ""b) /* We only turn ON here */ & ((privs_before_set & DIR_PRIVILEGE) = ""b) then call fix_kst; if ((priv_value & SEG_PRIVILEGE) ^= ""b) & ((privs_before_set & SEG_PRIVILEGE) = ""b) then call fix_kst_seg; /**** The following code would usually audit the event. However, setting /**** privileges temporarily is a normal function of the ring-1 TCB. /**** Therefore, we elect to avoid many unnecessary audit messages. /**** Besides, there's no associated object or event flag on which to decide /**** upon auditing. /**** string (event_flags) = ""b; /**** event_flags.grant = "1"b; /**** event_flags.WHAT? = "1"b; HAVE to have an event flag here - admin_op is NOT the correct one /**** call access_audit_$log_general (ME, level$get (), string (event_flags), /**** access_operations_$system_privilege_modify, "", 0, null (), 0, "^a turned on", name_string); / ****/ return; reset_admin_privileges: entry (old_privileges); if ^substr (old_privileges, 36, 1) then return; /* Not anything to reset. */ substr (old_privileges, 36, 1) = "0"b; privs_before_set = string (pds$access_authorization.privileges); priv_value = substr (old_privileges, 1, 18); apte_auth_ptr = addr (pds$apt_ptr -> apte.access_authorization); different_privs_mask = bool (privs_before_set, old_privileges, "0110"b); /* XOR */ pds$admin_privileges = pds$admin_privileges & ^(^old_privileges & different_privs_mask); /* Zero out privs zero'd out by the reset */ string (apte_auth.privileges), string (pds$access_authorization.privileges) = priv_value; call ring_alarm$reset; if (priv_value & DIR_PRIVILEGE) ^= (privs_before_set & DIR_PRIVILEGE) then call fix_kst; if (priv_value & SEG_PRIVILEGE) ^= (privs_before_set & SEG_PRIVILEGE) then call fix_kst_seg; name_string = ""; do x = 1 to hbound (system_privilege_names, 1); if substr (privs_before_set, x, 1) ^= substr (priv_value, x, 1) then do; if length (name_string) > 0 then name_string = name_string || ","; name_string = name_string || rtrim (system_privilege_names (x).short); if substr (priv_value, x, 1) then name_string = name_string || "(set)"; else name_string = name_string || "(reset)"; end; end; /**** The following code would usually audit the event. However, setting /**** privileges temporarily is a normal function of the ring-1 TCB. /**** Therefore, we elect to avoid many unnecessary audit messages. /**** Besides, there's no associated object or event flag on which to decide /**** upon auditing. /**** string (event_flags) = ""b; /**** event_flags.grant = "1"b; /**** event_flags.WHAT? = "1"b; HAVE to have an event flag here - admin_op is NOT the correct one /**** call access_audit_$log_general (ME, level$get (), string (event_flags), /**** access_operations_$system_privilege_modify, "", 0, null (), 0, "change: ^a", name_string); / ****/ return; end set_admin_privileges; /* format: off */ %page; %include aim_privileges; %page; %include aim_template; %page; %include apte; %page; %include kst; %page; %include system_privileges; %page; %include access_audit_eventflags; /* format: on */ %page; /* BEGIN MESSAGE DOCUMENTATION Message: AUDIT (set_privileges): GRANTED modification of system AIM privilege ADDED_INFO S: $access_audit T: $run M: The specified user made a privileged call for modifying the process AIM privileges A: $ignore END MESSAGE DOCUMENTATION */ end set_privileges;  set_sons_lvid.pl1 11/11/89 1132.4r w 11/11/89 0800.6 58203 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ set_sons_lvid: proc (a_dirname, a_ename, a_sons_lvid, a_code); /* Last modified: 06/03/76 by R. Bratt to call find_$finished 02/28/82 by J. Bongiovanni to eliminate use of FSDCT 08/06/83 by E. N. Kittlitz for search_ast$check 831219 by E. N. Kittlitz for set_pdir_sons_lvid 07/03/84 by Keith Loepere to use the new dc_find. 10/15/84 by Keith Loepere for auditing info; also explicit activate of dir. 12/17/84 by E. Swenson to not violate the locking protocol. */ /* Parameters */ dcl a_code fixed bin (35) parameter; dcl a_dirname char (*) parameter; dcl a_ename char (*) parameter; dcl a_sons_lvid bit (36) parameter; /* Variables */ dcl code fixed bin (35); dcl dir_locked bit (1) aligned; /* indicates we have the directory locked */ dcl dirname char (168); dcl ename char (32); dcl ignore fixed bin (35); dcl 1 my_makeknown_info aligned like makeknown_info; dcl pdir bit (1) aligned; dcl ring fixed bin; dcl seg_pvid bit (36) aligned; dcl seg_uid bit (36) aligned; dcl seg_vtocx fixed bin; dcl segnum fixed bin (17); dcl segptr ptr; dcl set_lvid bit (1); dcl sons_lvid bit (36); dcl target_locked bit (1) aligned; /* indicates we have the target directory locked */ dcl write_lock bit (36) aligned init ("1"b); /* External */ dcl error_table_$argerr fixed bin (35) ext; dcl error_table_$bad_ring_brackets fixed bin (35) ext; dcl error_table_$fulldir fixed bin (35) ext; dcl error_table_$notadir fixed bin (35) ext; dcl error_table_$segknown fixed bin (35) ext; dcl pvt$root_lvid bit (36) aligned ext; /* Entries */ dcl level$get entry returns (fixed bin); dcl lock$dir_lock_write entry (ptr, fixed bin (35)); dcl lock$dir_unlock entry (ptr); dcl lock$lock_ast entry; dcl lock$unlock_ast entry; dcl makeknown_ entry (ptr, fixed bin (17), fixed bin, fixed bin (35)); dcl makeunknown_ entry (fixed bin, bit (36) aligned, bit (1) aligned, fixed bin (35)); dcl search_ast$check entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin (35)) returns (ptr); dcl sum$dirmod entry (ptr); /* Misc */ dcl (addr, baseptr, fixed, ptr, null, unspec) builtin; %page; sons_lvid = a_sons_lvid; /* Copy arg */ set_lvid = "1"b; pdir = "0"b; go to join; set_pdir_sons_lvid: entry (a_dirname, a_ename, a_sons_lvid, a_code); sons_lvid = a_sons_lvid; set_lvid = "1"b; pdir = "1"b; go to join; set_rpv: entry (a_dirname, a_ename, a_code); /* Force segs to be created on rpv */ pdir = "0"b; set_lvid = "0"b; join: dirname = a_dirname; /* copy arguments */ ename = a_ename; ring = level$get (); /* get validation level */ target_locked = "0"b; dir_locked = "0"b; segptr = null; call dc_find$obj_status_write (dirname, ename, DC_FIND_NO_CHASE, FS_OBJ_SONS_LVID_MOD, ep, code); /* get ptr to entry + lock dir for writing */ if code ^= 0 then go to finale; dp = ptr (ep, 0); dir_locked = "1"b; if ^ep -> entry.dirsw then do; code = error_table_$notadir; go to finale; end; if ring > fixed (ep -> entry.ex_ring_brackets (1), 3) then do; code = error_table_$bad_ring_brackets; /* ringbrackets must be consistent with validation level */ go to finale; end; seg_uid = entry.uid; makeknown_infop = addr (my_makeknown_info); /* activate target dir */ unspec (makeknown_info) = "0"b; makeknown_info.activate, makeknown_info.dirsw, makeknown_info.allow_write = "1"b; makeknown_info.uid = seg_uid; makeknown_info.entryp = ep; call makeknown_ (makeknown_infop, segnum, (0), code); if code ^= 0 then if code ^= error_table_$segknown then go to finale; segptr = baseptr (segnum); call dc_find$finished (dp, "1"b); /* unlock so we can lock child */ dir_locked = "0"b; call lock$dir_lock_write (segptr, code); /* Lock the dir to be modified */ if code ^= 0 then go to finale; target_locked = "1"b; call dc_find$obj_status_write (dirname, ename, DC_FIND_NO_CHASE, FS_OBJ_SONS_LVID_MOD, ep, code); /* refind and relock parent */ if code ^= 0 then go to finale; dp = ptr (ep, 0); /* just in case it changed */ dir_locked = "1"b; /* remember to unlock it */ if set_lvid then do; if segptr -> dir.sons_lvid ^= sons_lvid then do; /* If this is really a change */ if segptr -> dir.seg_count ^= 0 & ^pdir then do; code = error_table_$fulldir; go to finale; end; if ^pdir then do; segptr -> dir.master_dir = "1"b; segptr -> dir.master_dir_uid = seg_uid; entry.master_dir = "1"b; end; segptr -> dir.sons_lvid = sons_lvid; /* Tudo bem. Set the directory header */ entry.sons_lvid = sons_lvid; /* Set into branch for the dir too. */ seg_pvid = entry.pvid; /* no page fault with dir & ast locked */ seg_vtocx = entry.vtocx; /* ... */ if ^pdir then do; call lock$lock_ast; /* turn on ast bit */ astep = search_ast$check (seg_uid, seg_pvid, seg_vtocx, (0)); /* ignore double-uid error */ if astep ^= null () then astep -> aste.master_dir = "1"b; call lock$unlock_ast; end; end; end; else do; /* Setting RPV */ if segptr -> dir.sons_lvid ^= pvt$root_lvid then do; code = error_table_$argerr; go to finale; end; segptr -> dir.force_rpv = "1"b; end; call sum$dirmod (dp); /* Indicate parent dir modified */ finale: if segptr ^= null then do; if target_locked then call lock$dir_unlock (segptr); call makeunknown_ (segnum, "0"b, ("0"b), ignore); end; if dir_locked then call dc_find$finished (dp, "1"b); a_code = code; return; /* format: off */ %page; %include aste; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include dir_header; %page; %include dir_name; %page; %include fs_obj_access_codes; %page; %include makeknown_info; end set_sons_lvid;  set_stack_ptr.alm 11/11/89 1132.4rew 11/11/89 0800.6 9675 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " routine to set the value of pds$stacks(cur_val_level) to the specified value " required for tasking with separate linkage for each stack entry set_stack_ptr set_stack_ptr: eppbp ap|2,* bp<-->new_stack_pointer epbpbp bp|0,* bp<-->base of new stack lda |[validation_level] a<-current validation level als 1 a<-2*cur_val_level (two words for each pointer) spribp |[stacks],al place new value into appropriate slot short_return end  shutdown.pl1 11/11/89 1132.4rew 11/11/89 0800.6 63144 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,delnl,insnl,indattr,ifthen,dclind10 */ shutdown: procedure (); /* Procedure to stop the system in preparation for File System Shutdown. This can be called only from the Initializer. After setting CPU required to the bootload CPU, it stops all CPUs and disables traffic control. It calls shutdown_file_system, switching stacks along the way to inzr_stk0. This is called only during normal shutdown. During emergency shutdown, shutdown_file_system is called directly. For the new Storage System, Bernard Greenberg, 10/20/75 For demountable volumes, BSG 03/26/76 For new flags in flagbox, 9/30/76 by Noel I. Morris For shutdown with downed drives, BSG 02/26/77 For shutdown which doesn't give up, W. Olin Sibert, 05/18/81 For set_procs_required, J. Bongiovanni, October 1981 To remove Page Multilevel, C. Hornig, December 1981. To remove File System shutdown, J. Bongiovanni, March 1982 To shutdown scavenger, J. Bongiovanni, September 1982 To call stop_cpu$shutdown instead of stop_cpu, Chris Jones, April 1984 */ /****^ HISTORY COMMENTS: 1) change(86-09-23,Beattie), approve(86-08-11,MCR7517), audit(86-10-23,Fawcett), install(86-11-03,MR12.0-1206): No BOS support for MR12. END HISTORY COMMENTS */ dcl pds$processid bit (36) aligned external; dcl condition_ entry (char (*), entry); dcl disk_emergency$test_all_drives entry; dcl scavenger$shutdown entry; dcl set_procs_required entry (bit (8) aligned, fixed bin (35)); dcl stop_cpu$shutdown ext entry (fixed bin (2), fixed bin (35)); dcl switch_shutdown_file_system entry; dcl syserr entry options (variable); dcl syserr$error_code entry options (variable); dcl tc_shutdown ext entry; dcl tc_data$initializer_id bit (36) aligned external; dcl code fixed bin (35); dcl i fixed bin (2); dcl cpu_mask bit (8) aligned; dcl LETTERS char (8) internal static options (constant) init ("ABCDEFGH"); dcl my_name char (8) internal static options (constant) init ("shutdown"); dcl (null, stackbaseptr, substr) builtin; /* */ if pds$processid ^= tc_data$initializer_id then return; /* Only initializer can perform shutdown (trad.) */ stackbaseptr () -> stack_header.stack_begin_ptr -> stack_frame.prev_sp = null (); /* Guarantee that we shall never leave ring zero again */ call condition_ ("any_other", shutdown_failed); /* Don't let anything untoward happen, either */ /* Now stop all CPU's other than the bootload one we are returning to */ cpu_mask = "0"b; substr (cpu_mask, scs$bos_processor_tag + 1, 1) = "1"b; call set_procs_required (cpu_mask, code); if code ^= 0 then /* Couldn't run on bootload CPU */ call syserr$error_code (CRASH, code, "^a: Cannot run on CPU ^a (bootload CPU). Dump and try ESD.", my_name, substr (LETTERS, scs$bos_processor_tag + 1, 1)); do i = 0 to 7; if i ^= scs$bos_processor_tag then do; if scs$processor_data (i).online then do; call stop_cpu$shutdown (i, code); if code ^= 0 then call syserr (ANNOUNCE, "^a: Could not stop CPU ^a.", my_name, substr (LETTERS, i + 1, 1)); end; end; end; /* Determine downed drives. Done in wired_shutdown in ESD case */ call disk_emergency$test_all_drives; /* Now stop other processes */ call tc_shutdown; /* After traffic control is shut down, reset any scavenges in progress */ call scavenger$shutdown; /* Switch stacks to inzr_stk0 and shutdown File System */ call switch_shutdown_file_system; /* */ shutdown_failed: proc (a_mcptr, a_condition, a_coptr, a_infoptr, a_continue) options (non_quick); dcl a_mcptr pointer parameter; dcl a_condition char (*) parameter; dcl a_coptr pointer parameter; dcl a_infoptr pointer parameter; dcl a_continue bit (1) aligned parameter; /* This procedure is called if any signallable faults occur in shutdown, and simply crashes the system, in the hope that an ESD will be more successful. */ do while ("1"b); call syserr (CRASH, "^a: Condition ^a signalled during shutdown. Normal shutdown failed. Get a dump, and try an ESD.", my_name, a_condition); end; end shutdown_failed; %page; %include scs; %page; %include stack_frame; %page; %include stack_header; %page; %include syserr_constants; /* */ /* BEGIN MESSAGE DOCUMENTATION Message: shutdown: Could not stop CPU TAG. S: $info T: System shutdown. M: Shutdown stops all but the bootload processor. The CPU whose tag is TAG could not be stopped. A: $note If shutdown fails, put all CPU's other than the bootload processor in step, return to BCE manually, and attempt an ESD. Message: shutdown: Condition CCCC signalled during shutdown. Normal shutdown failed. Get a dump, and try an ESD. S: $crash T: System shutdown M: During the attempt to shut down the system, an unexpected condition has been signalled. This may result from hardware problems, or a logic error in the supervisor. The system crashes and returns to BCE, whereupon an ESD should be attempted in order to finish flushing Multics information from main memory. Because of the difference in implementation between normal shutdown and ESD, it is possible that ESD will not encounter the same problem, and instead be successful. Message: shutdown: Cannot run on CPU X (bootload CPU). Dump and try ESD. ERRORMESSAGE S: $crash T: System shutdown M: During an attempt to shut down the system, the system could not run on the bootload CPU. This problem may be due to hardware or software problems. The system will attempt to crash, which it may not complete. A: If the system does not complete its attempt to crash, it should be crashed manually. It may be necessary to change the bootload CPU manually. This can be done by putting all CPUs into STEP mode, manually assigning an interrupt mask to the new bootload CPU from the bootload SCU maintenance panel, taking only the new bootload CPU out of STEP mode, and doing an EXECUTE SWITCHES on that CPU. Once the system has crashed successfully, an ESD should be attempted. This will most likely succeed. END MESSAGE DOCUMENTATION */ end;  stack_oob_handler.pl1 11/11/89 1132.4r 11/11/89 0800.6 51012 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ stack_oob_handler: procedure (mcptr); /* This procedure is called by the fim when an out_of_bounds fault has occurred on the stack. It either extends the stack by 48K and returns to the fim to signal storage or it terminates the process. */ /* coded by M. Weaver 5/29/74 */ /* re-coded by Mike Grady 8/79 to improve algorithim */ /* re-re-coded by Benson I. Margulies 1/82 to further improve algorithm */ /* Automatic */ dcl mcptr ptr; dcl max_lng fixed bin (19); dcl ca fixed bin (19); dcl code fixed bin (35); dcl e_code fixed bin (35); dcl extend bit (1) aligned; dcl extend_to fixed bin (19); dcl signal_storage bit (1) aligned; dcl signal_oob bit (1) aligned; /* Constants */ dcl INCREMENT fixed bin int static init (49152) options (constant); /* 48K */ /* Externals */ dcl sys_info$max_seg_size ext fixed bin (19); dcl error_table_$stack_overflow fixed bin (35) ext; dcl error_table_$oob_stack fixed bin (35) ext; dcl error_table_$oob_stack_ref fixed bin (35) ext; /* Builtins */ dcl (addr, binary, bit, min, pointer, rel) builtin; /* Entries */ dcl status_$get_max_length_ptr entry (ptr, fixed bin (19), fixed bin (35)); dcl set$max_length_ptr entry (ptr, fixed bin (19), fixed bin (35)); dcl terminate_proc entry (fixed bin (35)); dcl boundfault entry (ptr); %page; %include stack_header; %page; %include mc; %page; %include static_handlers; mcp = mcptr; sb = pointer (mc.prs (6), 0); /* get ptr to stack at time of fault */ call status_$get_max_length_ptr (sb, max_lng, code); /* get current max length of stack */ if code ^= 0 then /* can't imagine this would ever happen */ call term_proc; e_code = 0; /* code will be reset if signalling proves appropriate */ scup = addr (mc.scu (0)); /* get addr of SCU data */ ca = bin (scu.ca, 18); /* pull out computed address */ signal_storage = "0"b; signal_oob = "0"b; extend = "0"b; /* If the reference is beyond the end of the pl1 stack, then */ /* extending is unneccessary. If, by coincidence, the end_ptr */ /* is also beyond the end, we will take another fault when the error */ /* handlers push, and then entend. The 64 words is slop for programs */ /* that authentically stash data off of the end. */ if ca < max_lng then do; call boundfault (mcptr); /* ordinary aste problem */ e_code = mcptr -> mc.errcode; /* preserve any code from boundfault */ if e_code ^= 0 then signal_oob = "1"b; end; else if ca > (binrel (stack_header.stack_end_ptr) + 64) /* past the end */ then do; signal_oob = "1"b; /* no need to extend */ e_code = error_table_$oob_stack_ref; end; else if ca > (240 * 1024) /* leave space for pl1 snap and all that */ then do; signal_storage = "1"b; extend = "1"b; e_code = error_table_$stack_overflow; extend_to = sys_info$max_seg_size; /* go for it */ end; else do; /* extend silently, the max length is just < stack_end, and there is plenty of space */ /** code stays zero */ extend = "1"b; extend_to = binrel (stack_header.stack_end_ptr) + 64; end; /* Now do the extension if it was mandated. */ if extend & (extend_to > (max_lng - 1)) /* needed */ then do; if max_lng = sys_info$max_seg_size /* see if we have extended all the way already */ then call term_proc; /* noplace to go */ extend_to = min (extend_to, sys_info$max_seg_size); do while (max_lng <= extend_to); /* move upto desired size */ max_lng = max_lng + INCREMENT; end; if max_lng > (240 * 1024) then do; /* equivalent to storage condition case */ signal_storage = "1"b; e_code = error_table_$stack_overflow; max_lng = sys_info$max_seg_size; end; call set$max_length_ptr (sb, max_lng, code); /* extend the stack */ if code ^= 0 then call term_proc; /* If we extended the stack, then we may need a bigger aste. So we might */ /* as well call boundfault to do that, instead of taking another fault. */ call boundfault (mcptr); if mcptr -> mc.errcode ^= 0 then do; signal_oob = "1"b; e_code = mcptr -> mc.errcode; end; end; /* if mc.errcode is zero, the fim will restart the fault. So for the */ /* silent extension, it will be zero. */ mc.errcode = e_code; if signal_oob then do; mc.fim_temp.resignal = "1"b; mc.fim_temp.fcode = bit (out_of_bounds_sct_index, 17); end; else if signal_storage then do; mc.fim_temp.resignal = "1"b; mc.fim_temp.fcode = bit (storage_sct_index, 17); end; return; term_proc: procedure; call terminate_proc (error_table_$oob_stack); /* terminate the process */ end term_proc; binrel: procedure (ptr_to_rel) returns (fixed bin (18) unsigned); dcl ptr_to_rel pointer; return (binary (rel (ptr_to_rel), 18)); end binrel; end stack_oob_handler;  star_.pl1 11/11/89 1132.4rew 11/11/89 0800.0 196290 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Modified June 1984 by Keith Loepere to use the new dc_find. */ /* Modified by C. Hornig to no longer use system_free_seg */ /* Modified May 1981 by C. Hornig to compress link pathnames */ /* Modified Jul 79 by Greenberg for another oversize stack problem. */ /* Modified Oct 1978 by B. Greenberg to fix oversize stack problem. */ /* Modified May 1978 by T. Casey to fix bug in list_dir entry point when returning link authors */ /* Modified 04/78 by G. Palter to fix bug when asking for links only */ /* Modified 07/77 by THVV for bad_dir_ check */ /* modified 06/77 by THVV to combine star and dc_pack */ /* modified 04/77 by THVV to use system_free_seg better */ /* modified 05/31/76 by R. Bratt to call find_$finished */ /* modified 04/20/76 by R. Bratt to return partial info if not mounted */ /* modified Dec 75 by REM and TAC to add dir_list_ entry for NSS performance */ /* Modified 4/75 for NSS by THVV */ /* modified by Kobziar on 11-12-73 to drop setting of append bit on segs */ /* modified by Ackerman-Lewis on 12-03-74 to return correct count of names matching star name */ /* modified by Kobziar on 741203 to call new entry in access_mode */ /* Modified 750117 by PG to eliminate $no_acc_ck entry & clean up program */ /****^ HISTORY COMMENTS: 1) change(86-08-18,JSLove), approve(86-08-18,MCR7518), audit(86-09-29,Parisek), install(86-10-02,MR12.0-1174): Changed to call check_star_name_ with control mask CHECK_STAR_IGNORE_ALL rather than check_star_name_$entry. This bypasses syntactic checks which ring zero is not responsible for enforcing. Also changed to use named constants defined in check_star_name.incl.pl1. 2) change(87-06-01,GDixon), approve(87-07-13,MCR7740), audit(87-07-24,Hartogs), install(87-08-04,MR12.1-1055): A) Modified to properly declare check_star_name_. END HISTORY COMMENTS */ /* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */ star_: procedure (a_dirname, a_star_name, a_pbl, a_areap, a_ecount, a_eptr, a_nptr, a_code); dcl a_areap ptr parameter; dcl a_bcount fixed bin parameter; dcl a_bptr ptr parameter; /* for dc_pack */ dcl a_code fixed bin (35) parameter; dcl a_dirname char (*) parameter; dcl a_ecount fixed bin parameter; dcl a_eptr ptr parameter; dcl a_lcount fixed bin parameter; dcl a_lptr ptr parameter; /* for dc_pack */ dcl a_nptr ptr parameter; dcl a_pbl fixed bin (3) parameter; dcl a_star_name char (*) parameter; dcl dcpack_area area parameter; dcl branch_count fixed bin; dcl call_find_finish bit (1) aligned; dcl code fixed bin (35); dcl dc_pack bit (1) aligned; dcl dirname char (168); dcl eptr ptr; dcl fast_listing bit (1) aligned; dcl just_return_totals bit (1) aligned; dcl locked bit (1) aligned; dcl n_branches_match fixed bin; dcl n_links_match fixed bin; dcl need_vtoc bit (1) aligned; dcl nptr ptr; dcl number_of_entries fixed bin; dcl pbl fixed bin (3); dcl priv bit (1) aligned; dcl return_link_path bit (1) aligned; dcl saved_dir_change_pclock fixed bin (35); dcl star_list_entry bit (1) aligned; dcl star_name char (32); dcl starname_type fixed bin (2); dcl u_areap ptr; dcl want_branches bit (1) aligned; dcl want_links bit (1) aligned; dcl vtoc_available bit (1) aligned; dcl error_table_$argerr fixed bin (35) external; dcl error_table_$nomatch fixed bin (35) external; dcl error_table_$notalloc fixed bin (35) external; dcl acc_name_$get entry (ptr, ptr); dcl access_mode$effective entry (pointer, bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl alloc_ external entry (fixed bin, pointer, pointer); dcl check_star_name_ entry (char(*), bit(36), fixed bin(2), fixed bin(35)); dcl freen_ entry (pointer); dcl hash$search entry (ptr, ptr, ptr, fixed bin (35)); dcl lock$dir_lock_read entry (ptr, fixed bin (35)); dcl lock$dir_unlock entry (ptr); dcl match_star_name_ entry (char(*) aligned, char(*), fixed bin(35)); dcl mountedp entry (bit (36) aligned) returns (fixed bin (35)); dcl vtoc_attributes$get_info entry (bit (36) aligned, bit (36), fixed bin, ptr, fixed bin (35)); dcl (addr, addrel, binary, bit, divide, max, mod, null, rel, size, substr, unspec) builtin; dcl (area, bad_dir_, seg_fault_error) condition; %page; /* star_: procedure (a_dirname, a_star_name, a_pbl, a_areap, a_ecount, a_eptr, a_nptr, a_code); */ dc_pack, priv, fast_listing, star_list_entry = "0"b; go to common; star_priv: entry (a_dirname, a_star_name, a_pbl, a_areap, a_ecount, a_eptr, a_nptr, a_code); dc_pack, fast_listing, star_list_entry = "0"b; priv = "1"b; go to common; list_dir: entry (a_dirname, dcpack_area, a_bptr, a_bcount, a_lptr, a_lcount, a_code); priv, fast_listing, star_list_entry = "0"b; dc_pack = "1"b; go to common; list_dir_fast: entry (a_dirname, dcpack_area, a_bptr, a_bcount, a_lptr, a_lcount, a_code); priv, star_list_entry = "0"b; dc_pack, fast_listing = "1"b; go to common; dir_list_: entry (a_dirname, a_star_name, a_pbl, a_areap, a_bcount, a_lcount, a_eptr, a_nptr, a_code); dc_pack, priv = "0"b; fast_listing, star_list_entry = "1"b; go to common; list_: entry (a_dirname, a_star_name, a_pbl, a_areap, a_bcount, a_lcount, a_eptr, a_nptr, a_code); dc_pack, priv, fast_listing = "0"b; star_list_entry = "1"b; go to common; list_priv: entry (a_dirname, a_star_name, a_pbl, a_areap, a_bcount, a_lcount, a_eptr, a_nptr, a_code); dc_pack, fast_listing = "0"b; priv, star_list_entry = "1"b; go to common; %page; common: code = 0; want_branches, want_links, return_link_path, need_vtoc = "0"b; call_find_finish, locked = "0"b; dirname = a_dirname; /* Make sure we always return consistent values. */ n_branches_match, n_links_match = 0; dc_branch_arrayp, dc_link_arrayp, eptr, nptr = null (); code = 0; /* Analyze starname type */ if dc_pack then do; starname_type = STAR_TYPE_MATCHES_EVERYTHING; want_branches, want_links = "1"b; u_areap = addr (dcpack_area); end; else do; star_name = a_star_name; u_areap = a_areap; pbl = a_pbl; if pbl > 3 then do; /* pathname desired */ return_link_path = "1"b; pbl = mod (pbl, 4); /* trim the pathname option */ end; if /* case */ pbl = 1 then want_links = "1"b; else if pbl = 2 then want_branches = "1"b; else if pbl = 3 then want_branches, want_links = "1"b; else do; code = error_table_$argerr; go to finish; end; call check_star_name_ (star_name, CHECK_STAR_IGNORE_ALL, starname_type, code); if code ^= 0 then go to finish; end; RESCAN_DIR: eptr, nptr, dc_branch_arrayp, dc_link_arrayp = null (); call_find_finish, locked = "0"b; if priv then call dc_find$dir_read_priv (dirname, dp, code); else call dc_find$dir_read (dirname, dp, code); if code ^= 0 then go to finish; call_find_finish, locked = "1"b; if starname_type = STAR_TYPE_USE_PL1_COMPARE /* Special case names with no * or ? */ then branch_count, number_of_entries = 1; /* .. since at most one item can match */ else do; branch_count = dir.seg_count + dir.dir_count; number_of_entries = branch_count + dir.lcount; end; if u_areap = null () then do; /* Just wants totals */ if starname_type = STAR_TYPE_MATCHES_EVERYTHING then do; if want_branches then n_branches_match = branch_count; if want_links then n_links_match = dir.lcount; go to finish; end; else just_return_totals = "1"b; /* No vtoc needed, but must scan thru dir */ end; else just_return_totals = "0"b; if ^fast_listing then /* Never need VTOC for fast list */ if dc_pack | (want_branches & star_list_entry & ^just_return_totals) then do; need_vtoc = "1"b; /* See if need any info from VTOC */ code = mountedp (dir.sons_lvid); /* volume may not be mounted */ vtoc_available = (code = 0); /* sorry, force fast list, N.B. code must stay set */ end; call SCAN_DIR; /* Internal proc does the two scans */ %page; finish: if call_find_finish then call dc_find$finished (dp, locked); if star_list_entry | dc_pack then do; /* Copy values back to caller args */ a_bcount = n_branches_match; a_lcount = n_links_match; end; else do; a_ecount = n_branches_match + n_links_match; end; if dc_pack then do; a_bptr = dc_branch_arrayp; a_lptr = dc_link_arrayp; end; else do; a_eptr = eptr; a_nptr = nptr; end; a_code = code; return; %page; SCAN_DIR: procedure; dcl alloc_size fixed bin; dcl ec fixed bin (35); dcl entry_list (number_of_entries) uns fixed bin (18); dcl entry_rel bit (18); dcl link_path_blocks fixed bin; dcl n_entries_in_list fixed bin; dcl n_names_match fixed bin; dcl name_rel bit (18); dcl total_names_seen fixed bin; dcl u_narray (n_names_match + link_path_blocks) char (32) aligned based (nptr); dcl user_area area based (u_areap); n_branches_match, n_links_match, total_names_seen = 0; n_entries_in_list, n_names_match, link_path_blocks = 0; call MAKE_ENTRY_LIST; if n_links_match + n_branches_match = 0 then do; if ^dc_pack then code = error_table_$nomatch; go to done; end; if just_return_totals then go to done; /* If all we want is counts, we got them */ /* Allocate room in user area for copying it out */ /* We have to unlock the dir first */ saved_dir_change_pclock = dir.change_pclock; call lock$dir_unlock (dp); locked = "0"b; on area go to set_no_alloc; if dc_pack then do; dc_n_branches = max (branch_count, 1); allocate dcpack_branch_array in (user_area); dc_n_links = max (n_links_match, 1); allocate dcpack_link_array in (user_area); allocate dcpack_grand_link_pathname_array in (user_area); dc_grand_n_names = max (total_names_seen, 1); allocate dcpack_grand_name_array in (user_area); end; else do; if n_names_match + link_path_blocks > 0 then allocate u_narray in (user_area) set (nptr); else nptr = null; if star_list_entry then alloc_size = size (star_list_link) * n_links_match + size (star_list_branch) * n_branches_match; else alloc_size = n_links_match + n_branches_match; /* size (entries) = 1 */ if alloc_size = 0 then eptr = null; else do; on area go to free_nptr; call alloc_ (alloc_size, u_areap, eptr);/* entries */ if eptr = null then go to free_nptr; end; end; /* Now relock the dir */ on seg_fault_error signal bad_dir_; call lock$dir_lock_read (dp, code); if code ^= 0 then go to finish; locked = "1"b; revert seg_fault_error; if dir.change_pclock ^= saved_dir_change_pclock then do; if dc_pack then do; free dcpack_branch_array; free dcpack_link_array; free dcpack_grand_name_array; free dcpack_grand_link_pathname_array; end; else do; free u_narray; if eptr ^= null () then call freen_ (eptr); end; call dc_find$finished (dp, locked); go to RESCAN_DIR; end; call SORT_ENTRY_LIST; call RETURN_INFO; goto done; free_nptr: free u_narray in (user_area); set_no_alloc: code = error_table_$notalloc; done: return; /* normal exit from SCAN_DIR */ %page; MAKE_ENTRY_LIST: procedure; dcl dir_nwords fixed bin (18); dcl entry_names_match_star fixed bin; dcl n_entries_seen fixed bin; dcl n_names_seen fixed bin; dir_nwords = addrel (dp, dir.arearp) -> area.lu; if starname_type ^= STAR_TYPE_USE_PL1_COMPARE then do; n_entries_seen = 0; /* if there may be several entries */ do entry_rel = dir.entryfrp repeat (entry.efrp) while (entry_rel ^= ""b); ep = addrel (dp, entry_rel); n_entries_seen = n_entries_seen + 1; if (n_entries_seen > number_of_entries) | (binary (entry_rel, 18) > dir_nwords) then signal bad_dir_; /* check for loop */ call CHECK_VALID_ENTRY; if (entry.bs & want_branches) | (^entry.bs & want_links) then do; /* Type is correct */ entry_names_match_star = 0; /* Does a name match? */ n_names_seen = 0; do name_rel = entry.name_frp repeat (np -> names.fp) while (name_rel ^= ""b); np = addrel (dp, name_rel); n_names_seen = n_names_seen + 1; if (n_names_seen > entry.nnames) /* check for loop */ | (binary (name_rel, 18) > dir_nwords) | (np -> names.owner ^= entry.uid) | (np -> names.type ^= NAME_TYPE) | (np -> names.entry_rp ^= entry_rel) then signal bad_dir_; if NAME_MATCHES () then do; entry_names_match_star = entry_names_match_star + 1; /* This name will be listed */ n_names_match = n_names_match + 1; end; end; if entry_names_match_star > 0 then call TAKE_ENTRY; end; end; /* end of loop on ep */ end; else do; /* STAR_TYPE_USE_PL1_COMPARE: Return one or none */ call hash$search (dp, addr (star_name), ep, ec); if ec = 0 then do; /* Special case for efficiency. use hash table */ call CHECK_VALID_ENTRY; /* Found the entry */ n_names_match = 1; /* Found desired name */ call TAKE_ENTRY; end; end; return; /* ---------------------------------------- */ TAKE_ENTRY: procedure; n_entries_in_list = n_entries_in_list + 1; entry_list (n_entries_in_list) = binary (rel (ep), 18); total_names_seen = total_names_seen + n_names_seen; if ^entry.bs then do; /* link */ n_links_match = n_links_match + 1; if return_link_path then link_path_blocks = link_path_blocks + divide (link.pathname_size + 31, 32, 17, 0); end; else n_branches_match = n_branches_match + 1; return; end TAKE_ENTRY; /* ----------------------------------------------------- */ CHECK_VALID_ENTRY: procedure; if entry.bs then if (entry.owner ^= dir.uid) | ((entry.type ^= SEG_TYPE) & (entry.type ^= DIR_TYPE)) then signal bad_dir_; else ; else if (link.owner ^= dir.uid) | (link.type ^= LINK_TYPE) then signal bad_dir_; return; end CHECK_VALID_ENTRY; %page; %include dir_allocation_area; end MAKE_ENTRY_LIST; %page; SORT_ENTRY_LIST: procedure (); /* Someday, this should sort the entry list by rel(ep). */ return; end SORT_ENTRY_LIST; %page; RETURN_INFO: procedure; dcl code fixed bin (35); dcl earrayx fixed bin; dcl exmode bit (36) aligned; dcl grand_larrayx fixed bin; dcl grand_narrayx fixed bin; dcl larrayx fixed bin; dcl link_author char (32) aligned; dcl mode bit (36) aligned; dcl narrayx fixed bin; dcl ret_mode bit (5) aligned; dcl 1 sci aligned like based_sc_info; dcl tx fixed bin; dcl vtoc_code fixed bin (35); narrayx, larrayx, earrayx = 1; grand_narrayx, grand_larrayx = 1; do tx = 1 to n_entries_in_list; ep = addrel (dp, entry_list (tx)); if entry.bs then do; call access_mode$effective (ep, mode, exmode, code); if entry.dirsw then ret_mode = "0"b || substr (exmode, 1, 1) || "1"b || substr (exmode, 2, 2); else ret_mode = "0"b || substr (mode, 1, 4); if need_vtoc then do; unspec (sci) = ""b; /* clear out old junk */ vtoc_code = code; if vtoc_available then do; call vtoc_attributes$get_info (entry.uid, entry.pvid, (entry.vtocx), addr (sci), vtoc_code); if ^dc_pack & (vtoc_code ^= 0) & (code = 0) then code = vtoc_code; end; end; end; else call acc_name_$get (addr (link.author), addr (link_author)); if dc_pack then call RETURN_DCPACK_INFO; else call RETURN_STAR_INFO; end; return; %page; RETURN_DCPACK_INFO: procedure; declare first_name_relp bit (18); /* in this program earrayx goes up by 1 for each branch. larrayx goes up by 1 for each link, and narrayx by 1 for each name on an entry (resets each time) */ if entry.bs then do; dc_branchp = addr (dcpack_branch_array (earrayx)); earrayx = earrayx + 1; unspec (dcpack_branch) = ""b; dcpack_branch.vtoc_error = (vtoc_code ^= 0); dcpack_branch.uid = entry.uid; dcpack_branch.dtu = sci.dtu; dcpack_branch.dtm = sci.dtm; dcpack_branch.dtd = entry.dtd; dcpack_branch.dtem = entry.dtem; dcpack_branch.dirsw = entry.dirsw; dcpack_branch.optsw = entry.copysw; dcpack_branch.bc = bit (entry.bc, 24); dcpack_branch.cl = bit (divide (sci.csl, 1024, 9, 0), 9); dcpack_branch.ml = bit (divide (sci.msl, 1024, 9, 0), 9); dcpack_branch.nnames = entry.nnames; dcpack_branch.mode = ret_mode; if entry.dirsw then do; dcpack_branch.rb1 = (3)"0"b || entry.ex_ring_brackets (1); dcpack_branch.rb2 = (3)"0"b || entry.ex_ring_brackets (2); dcpack_branch.rb3 = dcpack_branch.rb2; end; else do; dcpack_branch.rb1 = (3)"0"b || entry.ring_brackets (1); dcpack_branch.rb2 = (3)"0"b || entry.ring_brackets (2); dcpack_branch.rb3 = (3)"0"b || entry.ring_brackets (3); end; end; else do; /* link */ dc_linkp = addr (dcpack_link_array (larrayx)); larrayx = larrayx + 1; unspec (dcpack_link) = ""b; dcpack_link.uid = link.uid; dcpack_link.dtu = ""b; dcpack_link.dtem = link.dtem; dcpack_link.dtd = link.dtd; dcpack_link.nnames = link.nnames; dc_pnp = null (); if grand_larrayx > dc_n_links then signal bad_dir_; dc_pnp = addr (dcpack_grand_link_pathname_array (grand_larrayx)); grand_larrayx = grand_larrayx + 1; dcpack_path.size = link.pathname_size; dcpack_path.name = link.pathname; dcpack_path.author = link_author; dcpack_link.pathnamerp = rel (dc_pnp); end; /* links */ first_name_relp = rel (addr (dcpack_grand_name_array (grand_narrayx))); do name_rel = entry.name_frp repeat (np -> names.fp) while (name_rel ^= ""b); if grand_narrayx > dc_grand_n_names then signal bad_dir_; dc_namep = addr (dcpack_grand_name_array (grand_narrayx)); grand_narrayx = grand_narrayx + 1; np = addrel (dp, name_rel); dcpack_ename.name = np -> names.name; dcpack_ename.size = 32; end; if entry.bs then dcpack_branch.namerp = first_name_relp; else dcpack_link.namerp = first_name_relp; return; end RETURN_DCPACK_INFO; %page; RETURN_STAR_INFO: procedure; dcl full_pathname char (168) aligned based; /* In this program, earrayx is in WORDS not entries. It goes up a different amount depending on whether(a) star_ was called, (b) star_list_ was called and it's a branch, (c) star_list_ was called and it's a link. Also, narrayx goes up by 1 for each name and 6 for each link path. */ esp = addrel (eptr, earrayx - 1); star_entry.nindex = narrayx; star_entry.nnames = 0; if entry.bs then if entry.dirsw then star_entry.type = "10"b; /* dir */ else star_entry.type = "01"b; /* seg */ else star_entry.type = "00"b; /* link */ do name_rel = entry.name_frp repeat (np -> names.fp) while (name_rel ^= ""b); np = addrel (dp, name_rel); if NAME_MATCHES () then do; u_narray (narrayx) = np -> names.name; narrayx = narrayx + 1; star_entry.nnames = star_entry.nnames + 1; end; end; if ^star_list_entry then earrayx = earrayx + size (star_entry); else do; if entry.bs then do; /* branch */ earrayx = earrayx + size (star_list_branch); if entry.dirsw then star_list_branch.master_dir = entry.master_dir; star_list_branch.mode = ret_mode; if need_vtoc then do; star_list_branch.dtm_or_dtem = sci.dtm; star_list_branch.dtu = sci.dtu; star_list_branch.rec_or_bc = sci.records; end; else do; /* didn't access vtoce */ star_list_branch.dtu = ""b; star_list_branch.dtm_or_dtem = entry.dtem; star_list_branch.rec_or_bc = entry.bc; end; end; else do; /* link */ earrayx = earrayx + size (star_list_link); if return_link_path then do; /* copy path name */ star_list_link.pln = link.pathname_size; substr (addr (u_narray (narrayx)) -> full_pathname, 1, link.pathname_size) = link.pathname; star_list_link.pindex = narrayx; narrayx = narrayx + divide (link.pathname_size + 31, 32, 17, 0); end; else do; star_list_link.pln = 0; star_list_link.pindex = 0; end; star_list_link.dtm = link.dtem; star_list_link.dtd = link.dtd; end; end; end RETURN_STAR_INFO; end RETURN_INFO; %page; NAME_MATCHES: procedure returns (bit (1) aligned); dcl code fixed bin (35); if starname_type = STAR_TYPE_MATCHES_EVERYTHING then return ("1"b); call match_star_name_ (np -> names.name, star_name, code); return (code = 0); end NAME_MATCHES; end SCAN_DIR; %page; %include check_star_name; %page; %include dc_find_dcls; %page; %include dcpack_info; %page; %include dir_entry; %page; %include dir_header; %page; %include dir_link; %page; %include dir_name; %page; %include fs_types; %page; %include quota_cell; %page; %include sc_info; %page; %include star_info; end star_;  status_.pl1 11/11/89 1132.4rew 11/11/89 0800.0 379908 /****^ ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1983 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ************************************************************** */ /* format: style2 */ status_: proc (a_dir_name, a_entryname, a_chase, a_return_struc_ptr, a_return_area_ptr, a_code); /* STATUS returns the contents of a specified entry in a directory. dir_name = path name of directory (input) entry = name of the entry to be listed (input) chase = a switch when =1 means list the branch pointed to by "entry" (input) type = indicates whether "entry" (output) is a non-dir branch (=1), dir branch (=2), or a link (=0) return_struc_ptr = the pointer to the structure in which items from "entry" will be returned status_area_ptr = pointer to an area in which the names will be returned if it is null, no names will be returned. */ /* ************************************************************************** */ /* ************************************************************************** */ /* ************************************************************************** */ /* * * NN NN OOOOOO TTTTTTTT EEEEEEEE * NNN NN OO OO TT EE * NN N NN OO OO TT EE * NN NN NN OO OO TT EEEEEEE * NN N NN OO OO TT EE * NN NNNN OO OO TT EE * NN NNN OO OO TT EE * NN NN OOOOOO TT EEEEEEEE * * The variable status_call MUST be set in any entry to this program * before any calls to fatal_error, or the establishment of any * cleanup handler. It should be set to zero for attributes, and * other values for status info. Only status_ and status_long_ * should set values other than 0 and 3. * /**************************************************************************** */ /* *************************************************************************** */ /* *************************************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-10-31,Lippard), approve(86-06-02,MCR7427), audit(86-06-17,Farley), install(86-06-17,MR12.0-1077): Modified to zero out status_branch structures before calling dc_find so that status_link.pathname_length is zeroed when user doesn't have status permission on the containing directory. 2) change(86-05-20,Lippard), approve(86-06-02,MCR7427), audit(86-06-17,Farley), install(86-06-17,MR12.0-1077): Modified to not set status_branch.nnames if user doesn't have status permission, change status_for_backup to not return bogus information. 3) change(86-07-03,Farley), approve(86-07-03,MCR7427), audit(86-07-03,Fawcett), install(86-07-07,MR12.0-1086): This change is a PBF to installation 1077. The effective mode was being returned one bit position off. END HISTORY COMMENTS */ /* Modified 1985-05-08, EJ Sharpe: added get_mdir_status_priv, made get_mdir_status non-privileged, changed get_mdir_status_uid to get_mdir_status_uid_priv */ /* Modified 1985-04-19, BIM: include parent access class in entry_access_info */ /* Modified 04/08/85 by Keith Loepere to use fs_modes when possible (gets priv init right). */ /* Modified 03/25/85 by M. Pandolf to add get_access_(info info_seg) entries */ /* Modified 02/21/85 by E. Swenson to add get_user_access_modes_seg entry */ /* Modified 10/19/84 by Keith Loepere to properly copy status_for_backup. */ /* Modified 9/25/84 by EJ Sharpe for new entry get_user_raw_mode */ /* Modified 6/14/84 Keith Loepere to use the new dc_find */ /* Modified 1/84 BIM for 18 bit quota values */ /* Modified 6/9/83 Jay Pattin to not require status permission in get_author, get_bc_author, and status_for_backup */ /* Modified 830427 BIM to set dp in the root case. */ /* Modified 2/26/83 Jay Pattin to add get_uid_file */ /* Modified 1/3/83 Jay Pattin to add get_user_access_modes */ /* Modified 2/83, BIM, to stop zeroing the version in status_for_backup and fix Harcore 519. */ /* Modified September 1982, J. Bongiovanni, for synchronized switch, init bug */ /* Modified 3/82, BIM: (1) stop using sfs, (2) get_user_exmode, (3) overall cleanup, (4) general branch entrypoint. /* Modified 06/08/81, WOS: (1) Accept default of -1 for ring number in get_user_effmode, (2): Return documented directory mode values in get_user_effmode (turn off "e" bit) (3): Return access without regard to dir_name access if requested username is that of calling process, in get_user_effmode. */ /* Modified 11/26/80 W. Olin Sibert to fail when returning names in wrong component of extensible area */ /* Modified 10/79 by Mike Grady to set ptrs and counts before getting space in system free seg for names and such. Bug found by GDixon. */ /* Modified 9 Feb 79 by D. Spector to allow call to access_mode$user return an error code (status_$get_user_effmode) */ /* Modified 11/15/78 by C. D. Tavares to use status_structures.incl.pl1 */ /* Modified July 1977 by THVV for Bratt's MCR 2364 to return all but names in no_s_permission case */ /* Modified 07/77 by THVV for bad_dir_ check */ /* Modified July 1976 by R. Bratt to return uid in partial info case */ /* Modified June 1976 by R. Bratt to call find_$finished */ /* Modified April 1976 by R. Bratt to check mountedness and return partial info */ /* Modified March 1976 by Larry Johnson for master_dir status entries */ /* Modified March 1976 by R. Bratt for tpd */ /* 11/17/75 RE Mullen: status_for_backup to ret UID's and master_dir */ /* 9/25/75 RE Mullen: remove obsolete seg_activity and backup_branch_info entrypoints */ /* 9/25/75 RE Mullen: status_for_backup to not go to vtoc for maxlength */ /* Modified for NSS 4/75 by THVV */ dcl a_access_class bit (72) aligned parameter; dcl a_auth char (*) parameter; dcl a_bkptr ptr parameter; dcl a_bitcnt fixed bin (24) parameter; dcl a_chase fixed bin (1) parameter; dcl a_code fixed bin (35) parameter; dcl a_dates (*) bit (36) parameter; dcl a_dir_name char (*) parameter; dcl a_entryname char (*) parameter; dcl a_ex_modes bit (36) aligned parameter; dcl a_max_length fixed bin (19) parameter; dcl a_mode fixed bin (5) parameter; dcl a_modes bit (36) aligned parameter; /* note difference in dcl */ dcl a_ncd fixed bin parameter; dcl a_nid fixed bin parameter; dcl a_quota fixed bin (18) parameter; dcl a_return_area_ptr ptr parameter; dcl a_return_struc_ptr ptr parameter; dcl a_ring fixed bin parameter; dcl a_safety_sw bit (1) parameter; dcl a_seg_usage fixed bin (35) parameter; dcl a_segptr ptr parameter; dcl a_type fixed bin (2) parameter; dcl a_uidpath (0:15) bit (36) aligned parameter; dcl a_user char (*) parameter; dcl a_voluid bit (36) aligned parameter; /* VARIABLES */ dcl access_class bit (72) aligned; dcl auth char (32) aligned; dcl bitcnt fixed bin (24); dcl bkptr ptr; dcl 1 bks aligned like status_for_backup; dcl called_find bit (1) aligned init ("0"b); dcl chase fixed bin (1); dcl code fixed bin (35); dcl cur_length fixed bin (35); dcl dates (5) bit (36); dcl dir_name char (168); dcl dummy fixed bin (35); dcl entryname char (32); dcl 1 local_entry_access_info like entry_access_info; dcl ex_mode_entry bit (1) aligned; dcl exmode bit (36) aligned; dcl have_s_permission bit (1) aligned init ("1"b); dcl i fixed bin; dcl locked bit (1) aligned init ("0"b); dcl max_length fixed bin (19); dcl mode bit (36) aligned; dcl n_names_to_allocate fixed bin; dcl name_rp bit (18) aligned; dcl names_seen fixed bin; dcl ncd fixed bin; dcl nid fixed bin; dcl nnp ptr; dcl pathname_length_to_allocate fixed bin; dcl pathname_supplied bit (1) aligned; dcl pathname_varying char (168) varying; dcl pvid bit (36) aligned; dcl 1 qcell like quota_cell aligned automatic; dcl r (3) fixed bin (3); dcl raw_mode_entry bit (1) aligned; dcl rec_used fixed bin (9); dcl return_area_ptr pointer; dcl return_names_or_pathname bit (1) aligned; dcl return_names_ptr pointer init (null ()); dcl return_pathname_ptr pointer init (null ()); dcl return_pathname_sw bit (1); dcl return_struc_ptr ptr; dcl rexmode bit (36) aligned; dcl ring fixed bin; dcl rmode bit (36) aligned; dcl root_lvid bit (36) aligned; /* logical volume ID of the root */ dcl safety_sw bit (1) aligned; dcl saved_dir_change_pclock fixed bin (35); dcl seg_usage fixed bin (35); dcl segptr pointer; dcl status_call fixed bin (3); dcl tcode fixed bin (35); dcl type fixed bin; dcl uid bit (36) aligned; dcl uidpath (0:15) bit (36) aligned; dcl user char (32) aligned; dcl vol_dtd bit (36); dcl volid (3) bit (36); dcl vtocx fixed bin; /* * * * * TEXT SECTION REFERENCES * * * * * * * */ dcl ENTRY_status_ initial (1) fixed binary (3) internal static options (constant); /* note that there is code in this program which */ dcl ENTRY_status_long initial (2) fixed binary (3) internal static options (constant); /* assumes this ordering of these indicators */ dcl ENTRY_status_min initial (3) fixed binary (3) internal static options (constant); /* section of the procedure */ /* BASED */ dcl return_area area based (return_area_ptr); dcl return_names (n_names_to_allocate) character (32) unaligned based (return_names_ptr); dcl return_pathname aligned based (return_pathname_ptr) char (pathname_length_to_allocate); dcl 1 status_branch_short aligned based (status_ptr) like status_branch.short; /* EXTERNAL */ dcl error_table_$bad_arg fixed bin (35) external; dcl error_table_$dirseg fixed bin (35) external; dcl error_table_$link fixed bin (35) external; dcl error_table_$mdc_not_mdir fixed bin (35) external; dcl error_table_$no_s_permission fixed bin (35) external; dcl error_table_$noalloc fixed bin (35) external; dcl error_table_$notalloc fixed bin (35) external; dcl error_table_$null_info_ptr fixed bin (35) external; dcl error_table_$root fixed bin (35) external; dcl error_table_$unimplemented_version fixed bin (35) static external; dcl pds$process_group_id char (32) aligned external static; dcl pvt$root_lvid bit (36) aligned external; dcl pvt$root_pvid bit (36) aligned external; dcl pvt$root_vtocx fixed bin external; /* ENTRIES */ dcl acc_name_$get entry (ptr, ptr); dcl access_mode$effective entry (ptr, bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl access_mode$raw entry (ptr, bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl access_mode$user entry (ptr, char (32) aligned, bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl fs_modes$locked entry (ptr, bit (36) aligned, bit (36) aligned, (3) fixed bin (3), fixed bin (35)); dcl get_pathname_ entry (fixed bin (17), char (*) varying, fixed bin (35)); dcl level$get entry () returns (fixed bin (3)); dcl lock$dir_lock_read entry (ptr, fixed bin (35)); dcl lock$dir_unlock entry (ptr); dcl mountedp entry (bit (36) aligned) returns (fixed bin (35)); dcl uid_path_util$get entry (ptr, dim (0:15) bit (36) aligned, fixed bin (35)); dcl vtoc_attributes$get_dump_info entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (36), (3) bit (36), fixed bin (35)); dcl vtoc_attributes$get_dump_switches entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin, fixed bin, fixed bin (35)); dcl vtoc_attributes$get_info entry (bit (36) aligned, bit (36) aligned, fixed bin, ptr, fixed bin (35)); dcl vtoc_attributes$get_quota entry (bit (36) aligned, bit (36) aligned, fixed bin, ptr, fixed bin, fixed bin (35)); /* MISC */ dcl (addr, baseno, bin, divide, fixed, hbound, ptr, null, rel, segno, substr, unspec) builtin; dcl area condition; dcl bad_dir_ condition; dcl cleanup condition; dcl seg_fault_error condition; dcl stringsize condition; %page; /* status: proc (a_dir_name, a_entryname, a_chase, a_return_struc_ptr, a_return_area_ptr, a_code); */ status_call = ENTRY_status_; go to status_join; /* Join common code. */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ long: entry (a_dir_name, a_entryname, a_chase, a_return_struc_ptr, a_return_area_ptr, a_code); status_call = ENTRY_status_long; /* status_ and status_long join here. status_min* does not come in here */ status_join: return_struc_ptr = a_return_struc_ptr; return_area_ptr = a_return_area_ptr; call copy_and_check_pathname_arg; chase = a_chase; code = 0; tcode = 0; status_ptr = return_struc_ptr; n_names_to_allocate = 0; pathname_length_to_allocate = 0; if status_call = ENTRY_status_ then unspec (status_branch_short) = ""b; /* clear it out */ else unspec (status_branch) = ""b; on cleanup call clean_up_status_; /* Now set some bit flags to determine what work will be needed */ return_names_or_pathname = (return_area_ptr ^= null); RETRY_STATUS: call dc_find$obj_status_attributes_read (dir_name, entryname, chase, ep, code); if code = error_table_$no_s_permission then have_s_permission = "0"b; else if code ^= 0 then call fatal_error (code); locked, called_find = "1"b; dp = ptr (ep, 0); call get_type; /* Get segment type, bit count, and ring brackets. */ /* See how much stuff to allocate */ /* the qualifier of entry is set already */ /* assume we need entry.nnames, and only discover bad_dir_ later */ if ^return_names_or_pathname then do; n_names_to_allocate = 0; pathname_length_to_allocate = 0; end; else do; n_names_to_allocate = entry.nnames; if type = Link then pathname_length_to_allocate = link.pathname_size; /* Now unlock, allocate, and relock */ saved_dir_change_pclock = dir.change_pclock; call lock$dir_unlock (dp); /* unlock, i say */ locked = "0"b; /* for cleanup benefit */ on area call fatal_error (error_table_$noalloc); if n_names_to_allocate > 0 then do; if have_s_permission then allocate return_names in (return_area) set (return_names_ptr); else n_names_to_allocate = 0; /* if no status, we have no name structure to copy */ end; if pathname_length_to_allocate > 0 then allocate return_pathname in (return_area) set (return_pathname_ptr); if return_names_ptr ^= null | return_pathname_ptr ^= null then do; if (return_names_ptr ^= null & baseno (return_names_ptr) ^= baseno (return_area_ptr)) | (return_pathname_ptr ^= null & baseno (return_pathname_ptr) ^= baseno (return_area_ptr)) then call fatal_error (error_table_$notalloc); /* note that we could retry the allocation to try to get it into the */ /* segment, but there is a better entrypoint on the way anyway */ /* now relock and check for races */ /* if the dir has been deleted, we could seg-fault here */ on seg_fault_error signal bad_dir_; call lock$dir_lock_read (dp, code); if code ^= 0 then call fatal_error (code); locked = "1"b; revert seg_fault_error; if dir.change_pclock ^= saved_dir_change_pclock then do; call unlock_dir; call clean_up_status_; /* free storage */ go to RETRY_STATUS; end; end; end; /* Okay, now the dir is locked, and any allocated storage needed */ /* to return the data has been allocated */ /* go ahead and fill things in */ if type ^= Link then do; /* if a branch */ if type = Directory then tcode = 0; /* RLV always mounted */ else tcode = mountedp (dir.sons_lvid); /* check mountedness */ if tcode = 0 then call get_vtoc; /* okay its mounted */ else unspec (sc_info) = "0"b; /* DAMN, give him partial info, N.B. tcode must get out */ rec_used = sc_info.records; cur_length = sc_info.csl; end; else tcode = 0; uid = entry.uid; /* can always know uid */ status_branch.type = type; /* set fixed information */ /* status_branch.nnames is set to 0 when no names are allocated, regardless of whether or not the caller has status permission. As per specs in documentation. */ status_branch.nnames = 0; if n_names_to_allocate > 0 /* we have allocated them */ then do; status_branch.names_relp = rel (return_names_ptr); status_branch.nnames = entry.nnames; names_seen = 0; do name_rp = entry.name_frp repeat ptr (dp, name_rp) -> names.fp while (name_rp ^= ""b); nnp = ptr (dp, name_rp); if nnp -> names.type ^= NAME_TYPE | nnp -> names.owner ^= entry.uid | nnp -> names.entry_rp ^= rel (ep) then signal bad_dir_; names_seen = names_seen + 1; if names_seen > n_names_to_allocate then signal bad_dir_; return_names (names_seen) = nnp -> names.name; end; if names_seen < n_names_to_allocate then signal bad_dir_; end; if type = Link then do; if return_pathname_ptr ^= null then do; status_link.pathname_relp = rel (return_pathname_ptr); on stringsize signal bad_dir_; (stringsize): return_pathname = link.pathname; revert stringsize; end; status_link.dtem = entry.dtem; status_link.dtd = entry.dtd; status_link.pathname_length = link.pathname_size; end; else do; /* branch only items */ status_branch.dtu = sc_info.dtu; status_branch.dtcm = sc_info.dtm; call access_mode$effective (ep, mode, exmode, dummy); if type = Segment then status_branch.mode = "0"b || substr (mode, 1, 3); else status_branch.mode = "0"b || substr (exmode, 1, 1) || "1"b || substr (exmode, 2, 2); status_branch.records_used = rec_used; call access_mode$raw (ep, rmode, rexmode, dummy); /* get raw bits for pad field */ if type = Segment then mode = "0"b || substr (rmode, 1, 3); else mode = "0"b || substr (rexmode, 1, 1) || "1"b || substr (rexmode, 2, 2); status_branch.raw_mode = substr (mode, 1, 5); if status_call ^= ENTRY_status_long then goto GOOD_RETURN; status_branch.long.dtd = entry.dtd; status_branch.long.dtem = entry.dtem; if type = Directory then status_branch.long.lvid = entry.sons_lvid; else status_branch.long.lvid = ptr (ep, 0) -> dir.sons_lvid; status_branch.long.current_length = divide (cur_length, 1024, 11, 0); status_branch.long.bit_count = bitcnt; status_branch.long.copy_switch = entry.copysw; status_branch.long.tpd_switch = entry.tpd; status_branch.long.mdir_switch = entry.master_dir; status_branch.long.damaged_switch = sc_info.damaged; status_branch.long.synchronized_switch = sc_info.synchronized; status_branch.long.ring_brackets (*) = r (*); status_branch.long.uid = entry.uid; end; GOOD_RETURN: if tcode = 0 & ^have_s_permission then tcode = error_table_$no_s_permission; call unlock_dir; a_code = tcode; /* remember LV problems */ /* or no_s_permission */ return; %page; mins: entry (a_segptr, a_type, a_bitcnt, a_code); status_call = ENTRY_status_min; call copy_and_check_segptr_arg; call dc_find$obj_attributes_read_ptr (segptr, ep, code); if code ^= 0 then call fatal_error (code); locked = "1"b; go to min_join; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ minf: entry (a_dir_name, a_entryname, a_chase, a_type, a_bitcnt, a_code); status_call = ENTRY_status_min; call copy_and_check_pathname_arg; chase = a_chase; call dc_find$obj_attributes_read (dir_name, entryname, chase, ep, code); if code ^= 0 then call fatal_error (code); locked, called_find = "1"b; min_join: dp = ptr (ep, 0); call get_type; /* Get type and bit count. */ call unlock_dir; /* Unlock_dir the directory now. */ a_type = type; /* Return the segment type. */ a_bitcnt = bitcnt; /* Return the bit count. */ go to RETURN; %page; get_author: entry (a_dir_name, a_entryname, a_chase, a_auth, a_code); status_call = ENTRY_status_min; call copy_and_check_pathname_arg; chase = a_chase; call dc_find$obj_attributes_read (dir_name, entryname, chase, ep, code); if code ^= 0 then call fatal_error (code); locked, called_find = "1"b; dp = ptr (ep, 0); call acc_name_$get (addr (entry.author), addr (auth)); /* decode the name */ call unlock_dir; /* Unlock directory before returning info. */ a_auth = auth; go to RETURN; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_bc_author: entry (a_dir_name, a_entryname, a_auth, a_code); status_call = ENTRY_status_min; call copy_and_check_pathname_arg; call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code); if code ^= 0 then call fatal_error (code); locked, called_find = "1"b; dp = ptr (ep, 0); call acc_name_$get (addr (entry.bc_author), addr (auth)); call unlock_dir; a_auth = auth; go to RETURN; %page; get_uid_file: entry (a_dir_name, a_entryname, a_uid, a_code); declare a_uid bit (36) aligned parameter; status_call = ENTRY_status_min; call copy_and_check_pathname_arg (); call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code); if code ^= 0 then call fatal_error (code); locked, called_find = "1"b; dp = ptr (ep, 0); uid = entry.uid; call unlock_dir (); a_uid = uid; go to RETURN; %page; get_user_access_modes: entry (a_dir_name, a_entryname, a_user, a_ring, a_modes, a_ex_modes, a_code); /* modes returned as bit strings (36) */ ex_mode_entry = "1"b; raw_mode_entry = "0"b; pathname_supplied = "1"b; ring = a_ring; goto GET_MODE_JOIN; get_user_access_modes_seg: entry (a_segptr, a_user, a_ring, a_modes, a_ex_modes, a_code); ex_mode_entry = "1"b; raw_mode_entry = "0"b; pathname_supplied = "0"b; ring = a_ring; goto GET_MODE_JOIN; get_user_effmode: entry (a_dir_name, a_entryname, a_user, a_ring, a_mode, a_code); /* mode returned as fixed bin (5) */ ex_mode_entry = "0"b; raw_mode_entry = "0"b; pathname_supplied = "1"b; ring = a_ring; goto GET_MODE_JOIN; get_user_raw_mode: entry (a_dir_name, a_entryname, a_user, a_modes, a_code); /* mode returned as bit string (36) */ ex_mode_entry = "0"b; raw_mode_entry = "1"b; pathname_supplied = "1"b; GET_MODE_JOIN: user = a_user; /* copy arg */ if user = pds$process_group_id then user = ""; /* Make the default work (and not require s) */ if (user = "") then /* Don't require dir_name access for this */ status_call = ENTRY_status_min; else status_call = 0; /* Otherwise, not a status entry */ if pathname_supplied then call copy_and_check_pathname_arg (); else call copy_and_check_segptr_arg (); /* must be segptr entry */ if ring < 0 then ring = level$get (); /* Default to validation level */ else if ring > 7 then ring = 7; /* And make it "valid" */ if pathname_supplied then do; if status_call = ENTRY_status_min then call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code); /* allow no s but non-null on object */ else call dc_find$obj_status_read (dir_name, entryname, 1, ep, code); end; else do; if status_call = ENTRY_status_min then call dc_find$obj_attributes_read_ptr (segptr, ep, code); else call dc_find$obj_status_read_ptr (segptr, ep, code); end; if code ^= 0 then call fatal_error (code); locked = "1"b; if pathname_supplied then called_find = "1"b; dp = ptr (ep, 0); if (user ^= "") then /* Someone other than ourselves */ call access_mode$user (ep, user, mode, exmode, code); else call access_mode$raw (ep, mode, exmode, code); /* Otherwise, determine our own mode */ if code ^= 0 then call fatal_error (code); call get_type; /* Get segment type, ring brackets and bitcount. */ call unlock_dir; /* Unlock the directory now. */ if raw_mode_entry then do; /* don't need to factor in ring brackets */ if type = Directory then a_modes = exmode; /* "111"b = sma */ else a_modes = mode; /* "111"b = rew */ goto RETURN; end; if type = Directory then do; /* for directories */ mode = exmode; exmode = ""b; if ring <= r (1) then ; /* all access allowed */ else if ring <= r (2) then mode = (mode & "100"b); /* status only */ else mode = "0"b; if ^ex_mode_entry then mode = substr (mode, 1, 1) || "0"b || substr (mode, 2, 2); /* map "sma" into "rwa" */ end; else do; /* a real segment */ if ring < r (1) then mode = (mode & "101"b); else if ring = r (1) then ; else if ring <= r (2) then mode = (mode & "110"b); else if ring <= r (3) then mode = (mode & "010"b); else mode = "0"b; end; if ex_mode_entry then do; a_modes = mode; a_ex_modes = exmode; end; else a_mode = fixed (substr (mode, 1, 4), 5); /* Return the effective mode. */ /* the forth bit of the bit string */ /* mode alignes with the lsb of the fixed bin number a_mode */ go to RETURN; %page; status_for_backup: entry (a_dir_name, a_entryname, a_bkptr, a_code); status_call = ENTRY_status_min; call copy_and_check_pathname_arg; bkptr = a_bkptr; if bkptr = null then call fatal_error (error_table_$bad_arg); if bkptr -> status_for_backup.version ^= status_for_backup_version_2 then call fatal_error (error_table_$unimplemented_version); call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code); if code ^= 0 then call fatal_error (code); locked, called_find = "1"b; dp = ptr (ep, 0); unspec (bks) = "0"b; bks.version = status_for_backup_version_2; bks.switches.safety = entry.safety_sw; bks.switches.tpd = entry.tpd; bks.switches.security_oosw = entry.security_oosw; bks.switches.audit_flag = entry.audit_flag; bks.switches.multiple_class = entry.multiple_class; bks.switches.entrypt = entry.entrypt_sw; bks.entrypt_bound = entry.entrypt_bound; bks.access_class = entry.access_class; if entry.dirsw then do; bks.lvid = entry.sons_lvid; bks.switches.master_dir = entry.master_dir; end; else bks.lvid = dp -> dir.sons_lvid; bks.pvid = entry.pvid; call acc_name_$get (addr (entry.author), addr (bks.author)); call acc_name_$get (addr (entry.bc_author), addr (bks.bc_author)); call unlock_dir; bkptr -> status_for_backup = bks; /* return data to user */ go to RETURN; %page; get_safety_sw_ptr: entry (a_segptr, a_safety_sw, a_code); status_call = ENTRY_status_min; call copy_and_check_segptr_arg; call dc_find$obj_attributes_read_ptr (segptr, ep, code); if code ^= 0 then call fatal_error (code); locked = "1"b; go to safety_sw_join; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_safety_sw: entry (a_dir_name, a_entryname, a_safety_sw, a_code); status_call = ENTRY_status_min; call copy_and_check_pathname_arg; call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code); if code ^= 0 then call fatal_error (code); locked, called_find = "1"b; safety_sw_join: dp = ptr (ep, 0); safety_sw = entry.safety_sw; call unlock_dir; a_safety_sw = safety_sw; go to RETURN; %page; get_seg_usage_ptr: entry (a_segptr, a_seg_usage, a_code); status_call = ENTRY_status_min; call copy_and_check_segptr_arg; call dc_find$obj_attributes_read_ptr (segptr, ep, code); if code ^= 0 then call fatal_error (code); locked = "1"b; go to seg_usage_join; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_seg_usage: entry (a_dir_name, a_entryname, a_seg_usage, a_code); status_call = ENTRY_status_min; call copy_and_check_pathname_arg; call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code); if code ^= 0 then call fatal_error (code); locked, called_find = "1"b; seg_usage_join: dp = ptr (ep, 0); if type = Directory then tcode = error_table_$dirseg; /* Dirs have quota instead */ else tcode = mountedp (dir.sons_lvid); /* Make sure seg is mounted by user */ if tcode ^= 0 then call fatal_error (tcode); call get_vtoc; /* Read AST or VTOCE */ seg_usage = sc_info.pf_count; call unlock_dir; a_seg_usage = seg_usage; go to RETURN; %page; get_dates_ptr: entry (a_segptr, a_dates, a_code); status_call = ENTRY_status_min; call copy_and_check_segptr_arg; call dc_find$obj_attributes_read_ptr (segptr, ep, code); if code ^= 0 then call fatal_error (code); locked = "1"b; go to dates_join; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_dates: entry (a_dir_name, a_entryname, a_dates, a_code); status_call = ENTRY_status_min; call copy_and_check_pathname_arg; call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code); if code ^= 0 then call fatal_error (code); locked, called_find = "1"b; dates_join: dp = ptr (ep, 0); call get_vtoc_dates; dates (1) = sc_info.dtu; dates (2) = sc_info.dtm; dates (3) = entry.dtem; dates (4) = entry.dtd; dates (5) = vol_dtd; call unlock_dir; do i = 1 to hbound (a_dates, 1); a_dates (i) = dates (i); end; go to RETURN; %page; get_volume_dump_switches_ptr: entry (a_segptr, a_nid, a_ncd, a_code); status_call = ENTRY_status_min; call copy_and_check_segptr_arg; call dc_find$obj_attributes_read_ptr (segptr, ep, code); if code ^= 0 then call fatal_error (code); locked = "1"b; go to volume_dump_switches_join; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_volume_dump_switches: entry (a_dir_name, a_entryname, a_nid, a_ncd, a_code); status_call = ENTRY_status_min; call copy_and_check_pathname_arg; call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code); if code ^= 0 then call fatal_error (code); locked, called_find = "1"b; volume_dump_switches_join: dp = ptr (ep, 0); call get_vtoc_volume_dump_switches; call unlock_dir; a_nid = nid; a_ncd = ncd; go to RETURN; %page; get_max_length_ptr: entry (a_segptr, a_max_length, a_code); status_call = ENTRY_status_min; call copy_and_check_segptr_arg; call dc_find$obj_attributes_read_ptr (segptr, ep, code); if code ^= 0 then call fatal_error (code); locked = "1"b; go to max_length_join; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_max_length: entry (a_dir_name, a_entryname, a_max_length, a_code); status_call = ENTRY_status_min; call copy_and_check_pathname_arg; call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code); if code ^= 0 then call fatal_error (code); locked, called_find = "1"b; max_length_join: dp = ptr (ep, 0); if type = Directory /* check mountedness for non-dirs */ then tcode = 0; else tcode = mountedp (dir.sons_lvid); if tcode ^= 0 then call fatal_error (tcode); call get_vtoc; max_length = sc_info.msl; call unlock_dir; a_max_length = max_length; go to RETURN; %page; get_access_class_ptr: entry (a_segptr, a_access_class, a_code); status_call = ENTRY_status_min; call copy_and_check_segptr_arg; call dc_find$obj_attributes_read_ptr (segptr, ep, code); if code ^= 0 then call fatal_error (code); locked = "1"b; go to access_class_join; get_access_class: entry (a_dir_name, a_entryname, a_access_class, a_code); status_call = ENTRY_status_min; call copy_and_check_pathname_arg; call dc_find$obj_attributes_read (dir_name, entryname, 1, ep, code); if code ^= 0 then call fatal_error (code); locked, called_find = "1"b; access_class_join: dp = ptr (ep, 0); access_class = entry.access_class; call unlock_dir; a_access_class = access_class; go to RETURN; %page; get_access_info: entry (a_dir_name, a_entryname, a_chase, a_return_struc_ptr, a_code); chase = a_chase; pathname_supplied = "1"b; go to get_access_info_join; get_access_info_seg: entry (a_segptr, a_return_struc_ptr, a_code); pathname_supplied = "0"b; get_access_info_join: status_call = ENTRY_status_min; entry_access_info_ptr = a_return_struc_ptr; if entry_access_info_ptr = null () then call fatal_error (error_table_$null_info_ptr); else if entry_access_info.version ^= ENTRY_ACCESS_INFO_VERSION_1 then call fatal_error (error_table_$unimplemented_version); if pathname_supplied then do; call copy_and_check_pathname_arg (); call dc_find$obj_attributes_read (dir_name, entryname, chase, ep, code); if code ^= 0 then call fatal_error (code); dp = ptr (ep, 0); locked, called_find = "1"b; end; else do; call copy_and_check_segptr_arg (); call dc_find$obj_attributes_read_ptr (segptr, ep, code); if code ^= 0 then call fatal_error (code); dp = ptr (ep, 0); locked = "1"b; end; if ^entry.bs /* if entry is a link */ then call fatal_error (error_table_$link); /* we can't continue */ else do; if called_find /* use expensive access lookup */ then call access_mode$effective (ep, mode, exmode, code); else call fs_modes$locked (segptr, mode, exmode, r, code); /* r gets overwritten at get_type */ if code ^= 0 then call fatal_error (code); call get_pathname_ (bin (segno (dp), 17, 0), pathname_varying, code); if code ^= 0 then call fatal_error (code); local_entry_access_info.version = ENTRY_ACCESS_INFO_VERSION_1; call get_type; local_entry_access_info.type = type; local_entry_access_info.dir_name = pathname_varying; local_entry_access_info.entryname = addr (entry.primary_name) -> names.name; local_entry_access_info.uid = entry.uid; local_entry_access_info.ring_brackets (*) = r (*); if type = Directory then local_entry_access_info.extended_ring_brackets (*) = 0; else do i = 1 to 3; local_entry_access_info.extended_ring_brackets (i) = fixed (entry.ex_ring_brackets (i), 3); end; if type = Segment then do; local_entry_access_info.effective_access_modes = mode; local_entry_access_info.extended_access_modes = exmode; end; else do; local_entry_access_info.effective_access_modes = exmode; local_entry_access_info.extended_access_modes = ""b; end; local_entry_access_info.access_class = entry.access_class; local_entry_access_info.multiclass = entry.multiple_class; local_entry_access_info.parent_access_class = dir.access_class; end; call unlock_dir (); entry_access_info = local_entry_access_info; go to RETURN; %page; /* Status entries used by master directory control */ get_mdir_status: entry (a_dir_name, a_entryname, a_uidpath, a_voluid, a_quota, a_code); status_call = 0; call copy_and_check_pathname_arg; return_pathname_sw = "0"b; call dc_find$obj_status_read (dir_name, entryname, 0, ep, code); /* find it without chasing link */ goto mdir_common; get_mdir_status_priv: entry (a_dir_name, a_entryname, a_uidpath, a_voluid, a_quota, a_code); status_call = 0; call copy_and_check_pathname_arg; return_pathname_sw = "0"b; call dc_find$obj_status_read_priv (dir_name, entryname, 0, ep, code); /* find it without chasing link */ mdir_common: if code ^= 0 then if code = error_table_$root then go to mdir_root; /* the root is NOT locked. we are making up this info */ else call fatal_error (code); dp = ptr (ep, 0); locked, called_find = "1"b; call check_master_dir; /* must be master dir, which is on RLV */ call get_vtoc_quota; /* get vtoce atrrbiutes */ a_quota = qcell.received; /* and quota received */ a_voluid = entry.sons_lvid; if ^return_pathname_sw then do; /* need uid pathname */ call uid_path_util$get (dp, uidpath, code); if code ^= 0 then call fatal_error (code); uidpath (dir.tree_depth + 1) = entry.uid; /* finish name */ a_uidpath = uidpath; end; else do; a_dir_name = dir_name; a_entryname = entryname; end; call unlock_dir; go to RETURN; mdir_root: code = 0; /* clear residual error_table_$root */ dp = null; call get_vtoc_root; /* read roots vtoc entry */ a_quota = qcell.received; a_voluid = root_lvid; if ^return_pathname_sw then do; /* make up pathname of root */ uidpath = "0"b; uidpath (0) = (36)"1"b; a_uidpath = uidpath; end; else do; a_dir_name = ">"; a_entryname = ""; end; go to RETURN; /* this entry is similiar to above, but is given a uid pathname to start with */ get_mdir_status_uid_priv: entry (a_uidpath, a_dir_name, a_entryname, a_voluid, a_quota, a_code); status_call = 0; call copy_and_check_pathname_arg; return_pathname_sw = "1"b; /* remember to return pathname */ uidpath = a_uidpath; call dc_find$obj_status_read_priv_uid (uidpath, dir_name, entryname, ep, code); /* find entry and lock dir_name */ go to mdir_common; /* procedure to check for a master directory */ check_master_dir: proc; if entry.bs then if entry.dirsw then if entry.master_dir then do; code = 0; return; end; call fatal_error (error_table_$mdc_not_mdir); end check_master_dir; %page; get_vtoc: proc; uid = entry.uid; pvid = entry.pvid; vtocx = entry.vtocx; call vtoc_attributes$get_info (uid, pvid, vtocx, addr (sc_info), dummy); if dummy ^= 0 then call fatal_error (dummy); end get_vtoc; get_vtoc_dates: proc; call get_vtoc; call vtoc_attributes$get_dump_info (uid, pvid, vtocx, vol_dtd, volid, dummy); if dummy ^= 0 then call fatal_error (dummy); end get_vtoc_dates; get_vtoc_volume_dump_switches: proc; uid = entry.uid; pvid = entry.pvid; vtocx = entry.vtocx; call vtoc_attributes$get_dump_switches (uid, pvid, vtocx, nid, ncd, dummy); if dummy ^= 0 then call fatal_error (dummy); end get_vtoc_volume_dump_switches; get_vtoc_quota: proc; /* special get_vtoc for master dirs */ uid = entry.uid; pvid = entry.pvid; vtocx = entry.vtocx; call vtoc_attributes$get_quota (uid, pvid, vtocx, addr (qcell), 0, code); if code ^= 0 then call fatal_error (code); end get_vtoc_quota; get_vtoc_root: proc; /* get vtoce for the root master dir */ uid = (36)"1"b; pvid = pvt$root_pvid; vtocx = pvt$root_vtocx; root_lvid = pvt$root_lvid; call vtoc_attributes$get_quota (uid, pvid, vtocx, addr (qcell), 0, code); if code ^= 0 then call fatal_error (code); unspec (uidpath) = "0"b; /* make up uidpathname */ uidpath (0) = (36)"1"b; return; end get_vtoc_root; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ unlock_dir: proc; if called_find then call dc_find$finished (dp, locked); /* unlock and unuse */ else if locked then call lock$dir_unlock (dp); locked, called_find = "0"b; end unlock_dir; %page; get_type: proc; if entry.bs then do; /* entry is a branch */ if entry.dirsw then do; /* entry is a directory branch */ type = Directory; r (1) = fixed (entry.ex_ring_brackets (1), 3); /* return extended ring brackets */ r (2) = fixed (entry.ex_ring_brackets (2), 3); r (3) = r (2); end; else do; /* entry is a non_directory branch */ type = Segment; r (1) = fixed (entry.ring_brackets (1), 3); /* return ring brackets */ r (2) = fixed (entry.ring_brackets (2), 3); r (3) = fixed (entry.ring_brackets (3), 3); end; bitcnt = entry.bc; end; else do; /* entry is a link */ type = Link; bitcnt = 0; end; end get_type; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ fatal_error: procedure (e_code); declare e_code fixed bin (35); call unlock_dir; /* cleanup */ call clean_up_status_; /* free storage if already dereferenced */ a_code = e_code; go to ERR_RETURN; end fatal_error; RETURN: a_code = 0; ERR_RETURN: return; copy_and_check_segptr_arg: procedure; segptr = a_segptr; if segptr = null then call fatal_error (error_table_$null_info_ptr); end copy_and_check_segptr_arg; copy_and_check_pathname_arg: procedure; dir_name = a_dir_name; entryname = a_entryname; if dir_name = "" then call fatal_error (error_table_$bad_arg); end copy_and_check_pathname_arg; clean_up_status_: procedure; /* ASSUME that if we are called as a cleanup handler that */ /* a crawlout is in progress, and we should leave the dir locked */ /* so that verify_lock will find it. */ if status_call = ENTRY_status_ | status_call = ENTRY_status_long then do; if return_names_ptr ^= null then free return_names; if return_pathname_ptr ^= null then free return_pathname; end; if called_find /* will be false on error exits */ then do; call dc_find$finished (dp, "0"b); /* dereference, but leave locked so verify_lock will salvage */ called_find = "0"b; end; end clean_up_status_; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include dir_header; %page; %include dir_link; %page; %include dir_name; %page; %include entry_access_info; %page; %include fs_types; %page; %include quota_cell; %page; %include sc_info; %page; %include status_for_backup; %page; %include status_structures; end status_;  tc_shutdown.pl1 11/11/89 1132.4rew 11/11/89 0800.7 21564 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ tc_shutdown: proc; /* Modified by E Stone on 5/74 to call deactivate_segs rather than deact_proc and to turn wait enable on */ dcl aptptr ptr, /* pointer to apt entry */ sstp ptr, /* pointer to SST */ pds_astep ptr; /* pointer to the aste for the pds of a process */ dcl i fixed bin, /* variable used to loop through APT */ state fixed bin, /* executation state of a process */ size fixed bin, /* number of entries in APT */ length fixed bin; /* number of words per apte */ dcl sst_seg$ fixed bin ext, tc_data$apt_size fixed bin ext, tc_data$apt_entry_size fixed bin ext, tc_data$initializer_id ext bit (36) aligned, tc_data$system_shutdown fixed bin ext, tc_data$wait_enable fixed bin ext, tc_data$apt fixed bin ext; dcl deactivate_segs entry (ptr); dcl (addr, addrel, bin) builtin; % include apte; /* */ tc_data$system_shutdown = 1; tc_data$wait_enable = 0; /* make sure we are only process running */ aptptr = addr (tc_data$apt); size = tc_data$apt_size; length = tc_data$apt_entry_size; sstp = addr (sst_seg$); /* destroy all processes except initializer and idle processes */ do i = 1 to size; state = bin(aptptr -> apte.flags.state, 18); if state = 0 | state = 5 then go to end_apt_loop; if aptptr -> apte.processid = tc_data$initializer_id then go to end_apt_loop; if aptptr -> apte.flags.idle | aptptr -> apte.flags.hproc then go to end_apt_loop; pds_astep = ptr (sstp, aptptr -> apte.asteps.pds); call deactivate_segs (pds_astep); end_apt_loop: aptptr = addrel (aptptr, length); end; /* return; /* All done */ end tc_shutdown;  template_address_space.pl1 11/11/89 1132.4r w 11/11/89 0800.7 138870 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ template_address_space: proc (); /* Written October 31, 1975 by R. Bratt Last Modified: October 1984, Keith Loepere even though this is no longer called, to use fs_modes. Also removed use of hdr. Also for terminate_. template_address_space provides functions for creating and deleting a template address space. A template address space is stored in a directory and is defined by two ring zero segments named "template_kst" and "template_dseg". ---> call template_address_space$create (dirname, access_calculated, code) create initiates the segment "kst_seg" in the given directory. It assumes that this segment has the format of a kst. create makes the following demands of its environment and the given segment: * kst.lowseg = active_all_rings_data$stack_base_segno * kst.highseg < active_all_rings_data$max_segno * kst.highest_used_segno > kst.lowseg+7 * kst.time_of_bootload = sys_info$time_of_bootload * kst.highest_used_segno is consistent with bitcount * caller has read access to kst_seg * each kst entry from lowseg to highest_used_segno contains: * a valid uid or a uid of "0"b * baseno (kste.entryp) is valid w.r.t. this kst * usage counts * the caller's address space contains every object in the kst to be built * no segment named "template_dseg" or "template_kst" exists in the given directory create makes two ring zero segments named "template_kst" and "template_dseg" with r *.*.* access. create then uses the information in kst_seg and its callers's address space to transform kst_seg into a secure, valid address space template. If an object in the new address space has a single acl term of *.*.* then access is precalculated in the template address space. If any inconsistancies are found in template_kst or if any of the assertion above are found to be violated then "template_kst" and "template_dseg" are deleted and an error is returned. If the address space template is sucessfully built then kst.template is set to help template_address_space$delete validate its right to delete this template address space and the count of segments which had access precalculated is returned. ---> call template_address_space$delete (dirname,code) delete is called to delete the template address space (template_kst, template_dseg) stored in a given directory. delete requires that the given directory contain two segments named "template_kst" and "template_dseg". These segments must have ring brackets of 0, 0, 0 and the caller must have modify permission to the containing directory. delete validates that the kst is marked as a template kst. Unfortunately, since we don't have property lists, delete cannot be absolutely certain that it is deleting a (template_kst, template_dseg) pair created by template_address_space$create. We assume, somewhat nervously, that the checks made by delete are sufficiently safe to prevent users from destroying ring zero segments not created by template_address_space$create. */ dcl a_dirname char (*), a_access_calculated fixed bin (17), a_code fixed bin (35); dcl access_calculated fixed bin (17), (created_kst, created_dseg) bit (1) aligned, dirname char (168), (mode, exmode) bit (36) aligned, ring fixed bin (3), rings (3) fixed bin (3), level fixed bin (3), (my_kstp, my_kstep, my_dsegp, his_dsegp, his_kstp, his_kstep, input_kstp) ptr, bc fixed bin (24), hash_class fixed bin (17), code fixed bin (35), (slotx, parent_slotx, segno) fixed bin (17); dcl copy_kst bit (bc) aligned based; dcl 1 star_dot_star_dot_star aligned, 2 pers_name char (32) initial ("*"), 2 proj_name char (32) initial ("*"), 2 tag char (1) initial ("*"), 2 modes bit (72); dcl 1 all_access aligned, 2 name char (32) initial ("*.*.*"), 2 modes bit (36) initial ("01000"b), 2 mbz bit (36) initial ("0"b), 2 code fixed bin (35); dcl error_table_$action_not_performed ext fixed bin (35), sys_info$time_of_bootload ext fixed bin (71), active_all_rings_data$max_segno ext fixed bin (17), dseg$ ext fixed bin; dcl acc_list_$match entry (fixed bin, bit (36) aligned, ptr, ptr, ptr, fixed bin, fixed bin (35)), acl$areplace entry (char (*), char (*), ptr, fixed bin (17), bit (1), fixed bin (35)), append$branch entry (char (*), char (*), fixed bin (5), fixed bin (35)), delentry$dfile entry (char (*), char (*), fixed bin (35)), delentry$dseg entry (ptr, fixed bin (35)), fs_modes entry (ptr, bit (36) aligned, bit (36) aligned, (3) fixed bin (3), fixed bin (35)), initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)), initiate$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)), kstsrch entry (bit (36) aligned, fixed bin (17), ptr), level$get entry returns (fixed bin (3)), level$set entry (fixed bin (3)), lock$dir_unlock entry (ptr), set$bc_seg entry (ptr, fixed bin (24), fixed bin (35)), set$safety_sw_path entry (char (*), char (*), bit (1), fixed bin (35)), set$copysw entry (char (*), char (*), fixed bin (1), fixed bin (35)), sum$getbranch entry (ptr, bit (36) aligned, ptr, fixed bin (35)), terminate_$noname entry (ptr, fixed bin (35)); dcl (addr, baseno, baseptr, bin, fixed, null, ptr, rel, string, substr, unspec) builtin; create: entry (a_dirname, a_access_calculated, a_code); dirname = a_dirname; a_access_calculated = 0; a_code = 0; access_calculated = 0; created_kst, created_dseg = "0"b; his_kstp, his_dsegp = null (); my_dsegp = addr (dseg$); my_kstp = pds$kstp; level = level$get (); call level$set (0); /* verify that kst_seg exists, is a segment and is readable by caller */ call initiate$initiate_count (dirname, "kst_seg", "", bc, 0, input_kstp, code); if input_kstp = null () then call abort_create (code); if my_kstp -> kst.kst_entry (fixed (baseno (input_kstp))).dirsw then call abort_create (0); /* nice try fella */ call fs_modes (input_kstp, mode, exmode, rings, code); if code ^= 0 then call abort_create (code); if (mode & R_ACCESS) ^= R_ACCESS | level > rings (2) then call abort_create (0); /* nasty, nasty */ /* create template_kst */ call append$branch (dirname, "template_kst", 01010b, code); if code ^= 0 then call abort_create (code); created_kst = "1"b; call initiate (dirname, "template_kst", "", 0, 0, his_kstp, code); if code ^= 0 then call abort_create (code); /* create dseg */ call append$branch (dirname, "template_dseg", 01010b, code); if code ^= 0 then call abort_create (code); created_dseg = "1"b; call initiate (dirname, "template_dseg", "", 0, 0, his_dsegp, code); if his_dsegp = null () then call abort_create (code); /* copy kst_seg into template_kst */ his_kstp -> copy_kst = input_kstp -> copy_kst; his_kstp -> kst.template = "0"b; call terminate_$noname (input_kstp, (0)); /* validate kst header */ if his_kstp -> kst.time_of_bootload ^= sys_info$time_of_bootload then call abort_create (0); /* must be made this bootload */ if his_kstp -> kst.lowseg ^= my_kstp -> kst.lowseg then call abort_create (0); /* the fool */ if his_kstp -> kst.highseg > active_all_rings_data$max_segno then call abort_create (0); if his_kstp -> kst.highest_used_segno < his_kstp -> kst.lowseg + 7 then call abort_create (0); if bin (rel (addr (his_kstp -> kst_entry (his_kstp -> kst.highest_used_segno + 1)))) * 36 ^= bc then call abort_create (0); if substr (string (his_kstp -> kst.prelinked_ring), 1, level - 1) ^= ""b then call abort_create (0); /* clean out stuff we won't look at */ his_kstp -> kst.free_list = "0"b; unspec (his_kstp -> kst.uid_hash_bucket) = "0"b; do slotx = his_kstp -> kst.lowseg to his_kstp -> kst.highest_used_segno; his_kstep = addr (his_kstp -> kst.kst_entry (slotx)); his_kstep -> kste.segno = slotx; his_kstep -> kste.fp = "0"b; unspec (his_kstep -> kste.access_information) = "0"b; unspec (his_kstep -> kste.flags) = "0"b; his_kstep -> kste.infcount = 0; his_kstep -> kste.dtbm = (36) "1"b; end; /* verify and build kstes */ do slotx = his_kstp -> kst.lowseg to his_kstp -> kst.highest_used_segno; his_kstep = addr (his_kstp -> kst.kst_entry (slotx)); if his_kstep -> kste.uid = "0"b then do; his_kstep -> kste.usage_count = 0; unspec (his_kstep -> kste.entryp) = "0"b; if slotx ^> his_kstp -> kst.lowseg + 7 then his_kstep -> kste.fp = (18)"1"b; /* reserve stack */ else do; his_kstep -> kste.fp = his_kstp -> kst.free_list; his_kstp -> kst.free_list = rel (his_kstep); end; end; else do; call kstsrch (his_kstep -> kste.uid, hash_class, my_kstep); if my_kstep = null () then call abort_create (0); his_kstep -> kste.fp = his_kstp -> kst.uid_hash_bucket (hash_class); his_kstp -> kst.uid_hash_bucket (hash_class) = rel (his_kstep); segno = my_kstep -> kste.segno; if his_kstep -> kste.entryp ^= null () then do; parent_slotx = bin (baseno (his_kstep -> kste.entryp)); if his_kstp -> kst.kst_entry (parent_slotx).uid ^= my_kstp -> kst.kst_entry (bin (baseno (my_kstep -> kste.entryp))).uid then call abort_create (0); his_kstep -> kste.entryp = ptr (his_kstep -> kste.entryp, rel (my_kstep -> kste.entryp)); his_kstp -> kst.kst_entry (parent_slotx).infcount = his_kstp -> kst.kst_entry (parent_slotx).infcount + 1; end; else if my_kstep -> kste.entryp ^= null () then call abort_create (0); call set_access (); his_kstep -> kste.dirsw, his_kstep -> kste.tms = my_kstep -> kste.dirsw; his_kstep -> kste.allow_write = "1"b; do ring = 7 to level + 1 while (his_kstep -> kste.usage_count (ring) = 0); end; end; end; /* mark it as a valid template_kst */ his_kstp -> kst.template = "1"b; /* fix access on template_dseg */ call set$bc_seg (his_dsegp, (his_kstp -> kst.highest_used_segno + 1) * 72, code); if code ^= 0 then call abort_create (code); call acl$areplace (dirname, "template_dseg", addr (all_access), 1, "0"b, code); if code ^= 0 then call abort_create (code); /* fix access on template_kst */ call set$bc_seg (his_kstp, bc, code); if code ^= 0 then call abort_create (code); call acl$areplace (dirname, "template_kst", addr (all_access), 1, "0"b, code); if code ^= 0 then call abort_create (code); /* cleanup */ call terminate_$noname (his_kstp, (0)); call terminate_$noname (his_dsegp, (0)); call level$set (level); a_access_calculated = access_calculated; return; set_access: proc (); dcl dummy_rings (3) fixed bin (3); call sum$getbranch (baseptr (segno), "0"b, ep, code); if code ^= 0 then return; if ep -> entry.acle_count = 1 then do; call acc_list_$match ((entry.acle_count), entry.uid, addr (entry.acl_frp), addr (star_dot_star_dot_star), (null ()), (0), code); if code = 0 then do; call fs_modes (baseptr (segno), ("0"b), ("0"b), dummy_rings, code); if code = 0 then do; access_calculated = access_calculated + 1; his_kstep -> kste.access_information = my_kstep -> kste.access_information; his_dsegp -> sdwa (slotx).r1 = my_dsegp -> sdwa (segno).r1; his_dsegp -> sdwa (slotx).r2 = my_dsegp -> sdwa (segno).r2; his_dsegp -> sdwa (slotx).r3 = my_dsegp -> sdwa (segno).r3; his_dsegp -> sdwa (slotx).read = my_dsegp -> sdwa (segno).read; his_dsegp -> sdwa (slotx).write = my_dsegp -> sdwa (segno).write; his_dsegp -> sdwa (slotx).execute = my_dsegp -> sdwa (segno).execute; end; end; end; call lock$dir_unlock (ptr (ep, 0)); return; end set_access; abort_create: proc (code); dcl code fixed bin (35); if created_dseg then call delentry$dfile (dirname, "template_dseg", (0)); if created_kst then call delentry$dfile (dirname, "template_kst", (0)); call level$set (level); if code = 0 then a_code = error_table_$action_not_performed; else a_code = code; go to return_to_caller; end abort_create; /* */ delete: entry (a_dirname, a_code); dirname = a_dirname; a_code = 0; my_kstp = pds$kstp; his_kstp, his_dsegp = null (); level = level$get (); call level$set (0); /* verify kst_seg exists, is a segment, and has brackets 0, 0, 0 */ call initiate_r0_seg ("template_kst", his_kstp); /* verify dseg exists, is a segment, and has brackets 0, 0, 0 */ call initiate_r0_seg ("template_dseg", his_dsegp); /* verify modify permission on containing directory */ call fs_modes ((my_kstp -> kst.kst_entry (bin (baseno (his_kstp))).entryp), mode, exmode, rings, code); if code ^= 0 then call abort_delete (code); /* UNCOMMENT WHEN FS_GET FIXED if level > rings (2) then call abort_delete (0); */ if (mode & M_ACCESS) ^= M_ACCESS then call abort_delete (0); /* validate that this is a template kst */ if ^his_kstp -> kst.template then call abort_delete (0); /* okay lets do it */ call delete_r0_seg (his_kstp, "template_kst"); call delete_r0_seg (his_dsegp, "template_dseg"); call level$set (level); return; initiate_r0_seg: proc (ename, segptr); dcl ename char (*), segptr ptr; call initiate (dirname, ename, "", 0, 0, segptr, code); if segptr = null () then call abort_delete (code); if my_kstp -> kst.kst_entry (bin (baseno (segptr))).dirsw then call abort_delete (0); call fs_modes (segptr, mode, exmode, rings, code); if code ^= 0 then call abort_delete (code); if rings (1) ^= 0 | rings (2) ^= 0 | rings (3) ^= 0 then call abort_delete (0); /* tut, tut */ return; end initiate_r0_seg; delete_r0_seg: proc (segptr, ename); dcl segptr ptr, ename char (*); call delentry$dseg (segptr, code); if code ^= 0 then do; call set$safety_sw_path (dirname, ename, "0"b, (0)); call set$copysw (dirname, ename, 0, (0)); call delentry$dseg (segptr, code); if code ^= 0 then call abort_delete (code); end; segptr = null (); return; end delete_r0_seg; abort_delete: proc (code); dcl code fixed bin (35); if his_kstp ^= null () then call terminate_$noname (his_kstp, (0)); if his_dsegp ^= null () then call terminate_$noname (his_dsegp, (0)); call level$set (level); if code = 0 then a_code = error_table_$action_not_performed; else a_code = code; go to return_to_caller; end abort_delete; return_to_caller: return; /* */ %include access_mode_values; /* */ %include dir_entry; /* */ %include kst; /* */ %include sdw; end template_address_space;  terminate_.pl1 11/11/89 1132.4r w 11/11/89 0800.7 71073 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ terminate_: proc (a_segptr, a_rsw, a_code); /* This procedure provides a variety of entries to remove names and segments from the RNT and KST. Written October 1974 by R. Bratt as a write around for the old terminate Last modified: R. Bratt 06/03/76 to call find_$finished M. Weaver 04/77 to ignore code r0_refname and to zero lot entry when appropriate B. Margulies May 1982 to not trash refnames with noname terminations. Keith Loepere July 1984 to use the new dc_find. Keith Loepere November 1984 to rename to terminate_; add auditing support; also to remove unused directory undetectability. -- -> terminate_$teseg remove the KST entry for a segment given its segment pointer. USAGE: call terminate_$teseg, call hcs_$terminate_seg (segptr, rsw, code) -- -> terminate_$tefile removes a segments KST entry, given its directory pathname and entry name USAGE: call terminate_$tefile, call hcs_$terminate_file (dirname, ename, rsw, code); -- -> terminate_$noname removes a single null name from a segment given its segment pointer. USAGE: call terminate_$noname call hcs_$terminate_noname (segptr, code) -- -> terminate_$name removes a reference name from a segment. USAGE: call terminate_$name, call hcs_$terminate_name (name, code) note: these last two entries will also remove the KST entry if they have deleted the segments last name. -- -> terminate_$id removes a segment from the kst by uid. It is an internal interface to be used by delentry. USAGE: call terminate_$id (uid, rsw, code); 1) segptr ptr - - - pointer to the segment 2) rsw fixed bin(1) - - - =1 reserve this segment number for later use, = 0 don't bother 3) code fixed bin - - - error code (output) 4) dirname char(*) - - - pathname of superior directory 5) ename char(*) - - - entry name of segment 6) name char(*) - - - reference name of segment 7) uid bit (36) aligned - - - unique identifier of segment */ /* Parameters */ dcl a_code fixed bin (35) parameter; dcl a_dirname char (*) parameter; dcl a_ename char (*) parameter; dcl a_name char (*) parameter; dcl a_rsw fixed bin (1) parameter; dcl a_segptr ptr parameter; dcl a_uid bit (36) aligned parameter; /* Variables */ dcl code fixed bin (35); dcl dirname char (168); dcl ename char (32); dcl hash_bucket fixed bin (17); dcl n_names fixed bin; dcl refname char (32) var; dcl rsw fixed bin (1); dcl segno fixed bin (17); dcl segptr ptr; dcl uid bit (36) aligned; /* External */ dcl error_table_$r0_refname ext fixed bin (35); dcl error_table_$root ext fixed bin (35); dcl error_table_$seg_deleted ext fixed bin (35); dcl pds$stacks (0:7) ptr ext; /* Misc */ dcl (baseno, baseptr, bit, dim, fixed, mod, ptr, rel) builtin; /* Entries */ dcl level$get ext entry () returns (fixed bin); dcl lock$dir_unlock ext entry (ptr); dcl makeunknown_ ext entry (fixed bin (17), bit (36) aligned, bit (1) aligned, fixed bin (35)); dcl makeunknown_$protect_names ext entry (fixed bin, fixed bin, bit (36) aligned, bit (1) aligned, fixed bin (35)); dcl ref_name_$delete ext entry (char (32) varying, fixed bin (17), fixed bin (35)); dcl ref_name_$delete_segno ext entry (fixed bin (17), fixed bin (35)); dcl ref_name_$get_count ext entry (fixed bin (17), fixed bin (17), fixed bin (35)); dcl ref_name_$get_segno ext entry (char (32) varying, fixed bin (17), fixed bin (35)); %page; teseg: entry (a_segptr, a_rsw, a_code); segptr = a_segptr; rsw = a_rsw; segno = fixed (baseno (segptr), 17); call dc_find$obj_terminate_ptr (segptr, ep, code); if code = 0 then call lock$dir_unlock (ptr (ep, 0)); if code = error_table_$root then code = 0; if code = error_table_$seg_deleted then code = 0; if code = 0 then call term_seg; a_code = code; return; %page; tefile: entry (a_dirname, a_ename, a_rsw, a_code); dirname = a_dirname; ename = a_ename; rsw = a_rsw; call dc_find$obj_terminate (dirname, ename, DC_FIND_CHASE, ep, code); if code = 0 then do; uid = entry.uid; call dc_find$finished (ptr (ep, 0), "1"b); call term_uid; end; a_code = code; return; %page; noname: entry (a_segptr, a_code); segptr = a_segptr; segno = fixed (baseno (segptr), 17); call dc_find$obj_terminate_ptr (segptr, ep, code); if code = 0 then call lock$dir_unlock (ptr (ep, 0)); if code = error_table_$root then code = 0; if code = error_table_$seg_deleted then code = 0; if code = 0 then do; call ref_name_$get_count (segno, n_names, code); if code ^= 0 then /* r0_refname */ n_names = 0; /* no refnames */ if n_names > 0 then call terminate_and_zero_lot$$protect (segno, ""b, n_names, code); else call terminate_and_zero_lot (segno, ""b, code); end; a_code = code; return; %page; name: entry (a_name, a_code); refname = a_name; call ref_name_$get_segno (refname, segno, code); if code = 0 then do; segptr = baseptr (segno); call dc_find$obj_terminate_ptr (segptr, ep, code); if code = 0 then call lock$dir_unlock (ptr (ep, 0)); if code = error_table_$root then code = 0; if code = error_table_$seg_deleted then code = 0; if code = 0 then do; call ref_name_$delete (refname, segno, code); if code = 0 then call terminate_and_zero_lot (segno, "0"b, (0)); end; end; a_code = code; return; %page; id: entry (a_uid, a_rsw, a_code); /* called from hardcore */ uid = a_uid; rsw = a_rsw; code = 0; call term_uid; a_code = code; return; %page; term_seg: proc; call ref_name_$delete_segno (segno, code); if (code = 0) | (code = error_table_$r0_refname) then call terminate_and_zero_lot (segno, bit (rsw, 1) || "1"b, code); return; end; term_uid: proc; kstp = pds$kstp; hash_bucket = mod (fixed (uid), dim (kst.uid_hash_bucket, 1)); do kstep = ptr (kstp, kst.uid_hash_bucket (hash_bucket)) repeat (ptr (kstp, kste.fp)) while (rel (kstep) ^= "0"b); if uid = kste.uid then do; segno = kste.segno; call term_seg; return; end; end; return; end; %page; terminate_and_zero_lot: proc (segnum, switches, ecode); dcl ecode fixed bin (35) parameter; dcl segnum fixed bin (17) parameter; dcl switches bit (36) aligned parameter; dcl n_names fixed bin; dcl ring fixed bin; dcl zero_lot bit (1) aligned; call makeunknown_ (segnum, switches, zero_lot, ecode); go to Join; terminate_and_zero_lot$$protect: entry (segnum, switches, n_names, ecode); call makeunknown_$protect_names (segnum, n_names, switches, zero_lot, ecode); if ecode ^= 0 then return; Join: if zero_lot then do; ring = level$get (); if segnum <= pds$stacks (ring) -> stack_header.cur_lot_size then do; /* don't wipe out locations not in lot, isot */ pds$stacks (ring) -> stack_header.lot_ptr -> lot.lp (segnum) = baseptr (0); pds$stacks (ring) -> stack_header.isot_ptr -> isot.isp (segnum) = baseptr (0); end; end; end; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include kst; %page; %include lot; %page; %include stack_header; end;  trap_caller_caller_.pl1 11/11/89 1132.4r w 11/11/89 0800.7 68913 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ trap_caller_caller_: proc (mcptr, header_ptr, def_ptr, type_ptr, link_ptr, ecode_ptr, code); /* This procedure is called by the linker (link_snap) when a trap-before-link or trap-at-first-reference is to be satisfied. It creates a frame in the stack of the faulting ring, putting machine conditions there (with the help of the signaller), sets up an argument list in that frame, and "calls" trap caller in the outer ring. The pointer to trap_caller's entry point is obtained via link_snap$make_ptr so that its linkage section will be properly set up in the outer ring. The "call" will wipe out the stack we are running on, and the return from trap_caller will actually go to the return point in restart_fault so that the machine conditions can be restarted. The entry "for_linker" in signaller is used to perform some of the necessary "secure" features of the restart such as saving a copy of the machine conditions in ring 0 and setting up a cleanup handler to discard these saved machine conditions if they are not to be restarted. Initially coded by M Weaver June 1973 Revised: April 75 by S. Webber to add "secure restart" features. */ declare (mcptr, header_ptr, def_ptr, type_ptr, link_ptr, entry_ptr, old_sp, ecode_ptr) ptr; declare i fixed bin; declare link_snap$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); declare signaller$for_linker entry (ptr, ptr); declare level$get entry () returns (fixed bin); declare code fixed bin (35); declare level fixed bin (18); declare (frame_add, temp) fixed bin (19); declare pds$signal_data (48) fixed bin ext; declare m_c (48) fixed bin based; declare based_fixed based fixed bin; declare error_table_$no_trap_proc ext fixed bin (35); declare label_var label; declare 1 label_temp aligned based, /* label template */ 2 (locp, stackp) ptr; declare (addr, addrel, baseno, baseptr, bin, bit, divide, null, ptr, rel) builtin; declare 1 trap_return_frame aligned based (sp), /* template for frame we will build */ 2 frame_header (40) fixed bin, 2 pad (8) fixed bin, 2 mach_cond (48) fixed bin, /* put in same place that signaller would */ 2 arg (7) ptr, /* are the arguments: mcptr, header_ptr, def_ptr, type_ptr, link_ptr; mcptr must stay where it is because signaller may need it for illegal_return */ 2 arglist, 3 arg_count bit (18) unaligned, 3 code bit (18) unaligned, 3 desc_count bit (18) unaligned, 3 pad bit (18) unaligned, 3 arg_ptrs (7) ptr, 2 pad1 (2) fixed bin, 2 on_unit (16) fixed bin; /* The variables mach_cond and on_unit in the above structure must start at 48 and 128 words from the beginning of the structure respectively because the signaller uses these regions of the stack frame set up by trap_caller_caller_. */ /* */ %include stack_header; %include its; %include stack_frame; %include mc; /* */ /* get ptr to trap caller proc in outer ring */ /* validation level has already been set correctly */ begin: call link_snap$make_ptr (null, "link_trap_caller_", "link_trap_caller_", entry_ptr, code); if code ^= 0 then do; /* have linker return linkage_error */ code = error_table_$no_trap_proc; return; end; if mcptr ^= null then old_sp = mcptr -> mc.prs (6); /* get ptr to proper stack */ else do; /* no mc; get old_sp by tracing threads */ label_var = begin; /* use big kludge to get sp */ sp = addr (label_var) -> label_temp.stackp; /* labels have stack ptrs */ /* get frame of caller of link_snap */ /* look for last sp in stack of validation level because */ /* external reference is being processed for ring of validation level */ level = level$get (); /* get validation level */ i = 0; /* initialize */ if level = 0 then old_sp = sp; /* we are the last frame */ else do; do while (baseno (sp -> stack_frame.prev_sp) = baseno (sp)); sp = sp -> stack_frame.prev_sp; /* try previous one */ i = i + 1; if i = 2000 then do; /* don't loop in ring 0 */ code = error_table_$no_trap_proc; return; end; end; if bin (addr (sp -> stack_frame.prev_sp) -> its.ringno, 3) ^= level then do; /* there are stacks in rings between r0 and target ring which we are not prepared to handle, so we will abort with a linkage_error and let the condition mechanism clean up */ code = error_table_$no_trap_proc; return; end; old_sp = sp -> stack_frame.prev_sp; /* we found the most recent frame in target ring */ end; end; sb = ptr (old_sp, 0); /* get ptr to base of new stack */ temp = bin (rel (sb -> stack_header.stack_end_ptr), 18); /* find starting offset */ if mcptr ^= null then do; /* get ring number from mc */ frame_add = temp + stack_frame_min_length; old_sp -> stack_frame_flags.signaller = "1"b; /* set appropiate flags so will know to truncate */ old_sp -> stack_frame_flags.old_signaller = "1"b; end; else do; /* were called; frame not inconsistent */ frame_add = temp; /* start where old left off */ /* no mc, so don't worry about mod 16 */ end; /* add new frame to outer ring stack */ sp, /* get ptr to new stack frame */ old_sp -> stack_frame.next_sp = ptr (sb, frame_add); /* thread in new frame */ sp -> stack_frame.next_sp, sb -> stack_header.stack_end_ptr = addrel (sp, size (trap_return_frame)); sp -> stack_frame.prev_sp = old_sp; sp -> stack_frame_flags.link_trap = "1"b; /* previous frame was faulted out of */ sp -> stack_frame.translator_id = bit (bin (10, 18), 18); /* trap_caller_caller_ frame */ /* fill in arguments */ if mcptr = null then sp -> trap_return_frame.arg (2) = null; /* no mc */ else do; /* arg must point to copied mc */ old_sp -> stack_frame_flags.old_signaller = "1"b; /* must be after next_sp is updated */ pds$signal_data = mcptr -> m_c; sp -> trap_return_frame.arg (2) = addr (sp -> trap_return_frame.mach_cond); end; sp -> trap_return_frame.arg (1) = null; sp -> trap_return_frame.arg (3) = header_ptr; sp -> trap_return_frame.arg (4) = def_ptr; sp -> trap_return_frame.arg (5) = type_ptr; sp -> trap_return_frame.arg (6) = link_ptr; sp -> trap_return_frame.arg (7) = ecode_ptr; /* points to ec in linker caller's frame */ /* fill in argument list */ sp -> trap_return_frame.arglist.arg_count = bit (bin (12, 18), 18); sp -> trap_return_frame.arglist.code = bit (bin (4, 18), 18); sp -> trap_return_frame.arglist.desc_count, sp -> trap_return_frame.arglist.pad = "0"b; do i = 1 to 7; sp -> trap_return_frame.arglist.arg_ptrs (i) = addr (sp -> trap_return_frame.arg (i)); end; /* put arglist ptr where next proc can find it */ sp -> stack_frame.operator_and_lp_ptr = addr (trap_return_frame.arglist); call signaller$for_linker (sp, entry_ptr); return; /* this will never be executed */ end;  truncate.pl1 11/11/89 1132.4r w 11/11/89 0800.7 58428 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ truncate$trfile: proc (a_dirname, a_ename, a_addrs, a_code); /* Date last modified and reasons: 11/84 by Keith Loepere for terminate_. 7/84 by Keith Loepere to use the new dc_find. 1/82 BIM to lock dir for write to protect truncate_vtoce from activations. 11/2/78 by B. Greenberg for raw/effective mode problem (not checking priv_init). 760630 by L. Scheffler to not audit truncates on copy-on-write segs 05/31/76 by R. Bratt to call find_$finished 04/20/76 by R. Bratt to check mountedness before truncate 760309 by L. Scheffler to use info-only entries in dir_control_error 04/28/75 by Greenberg for NSS 10/10/74 by Kobziar to call new access_mode entry 08/24/71 by RHG for page multi-level and to clean up the overlay for zeroing 07/27/71 by David Vinograd 06/13/71 by R. Gumpertz to check for negative addrs 06/12/71 by R. Gumpertz to add zeroing of last page after addrs and to check fpage properly against seg length and to eliminate accessing of a_addrs while a directory is locked */ %page; /* Parameters */ dcl a_addrs fixed bin (17) parameter; dcl a_code fixed bin (35) parameter; dcl a_dirname char (*) parameter; dcl a_ename char (*) parameter; dcl a_ep ptr parameter; dcl a_segptr ptr parameter; /* Variables */ dcl addrs fixed bin (17); dcl by_name bit (1) aligned init ("0"b); dcl code fixed bin (35); dcl ename char (32); dcl esw fixed bin (17); dcl fpage fixed bin (17); dcl overlay_size fixed bin; dcl parent char (168); dcl segptr ptr; dcl write_lock bit (36) aligned init ((36)"1"b); /* Based */ dcl overlay bit (overlay_size) based aligned; /* This is used to get at the words to be zeroed */ /* External */ dcl error_table_$argerr fixed bin (35) external; dcl error_table_$boundviol fixed bin (35) external; dcl error_table_$dirseg fixed bin (35) external; dcl error_table_$rqover fixed bin (35) external; dcl pds$processid bit (36) aligned ext; /* Entries */ dcl get_kstep entry (fixed bin (18), ptr, fixed bin (35)); dcl initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl lock$dir_unlock entry (ptr); dcl mountedp entry (bit (36) aligned) returns (fixed bin (35)); dcl sum$dirmod entry (ptr); dcl terminate_$noname entry (ptr, fixed bin (35)); dcl truncate_vtoce entry (ptr, fixed bin, fixed bin (35)); /* Misc */ dcl (addrel, baseno, divide, fixed, null, ptr) builtin; dcl out_of_bounds condition; %page; esw = 0; /* set entry point switch */ code = 0; addrs = a_addrs; /* copy the args */ parent = a_dirname; /* copy directory name */ ename = a_ename; /* copy entry name */ call dc_find$obj_truncate (parent, ename, ep, code); /* get pointer to branch + lock directory */ dp = ptr (ep, 0); if code ^= 0 then go to finale; by_name = "1"b; go to join; /* transfer to common code */ trseg: entry (a_segptr, a_addrs, a_code); esw = 1; /* set entry point switch */ code = 0; addrs = a_addrs; /* copy the addrs given */ segptr = ptr (a_segptr, 0); /* copy argument */ call get_kstep (fixed (baseno (segptr)), kstep, code); if code ^= 0 then go to finale; if kste.priv_init then call dc_find$obj_truncate_raw_ptr (segptr, ep, code); /* get pointer to branch + lock directory */ else call dc_find$obj_truncate_ptr (segptr, ep, code); /* get pointer to branch + lock directory */ if code ^= 0 then go to finale; dp = ptr (ep, 0); join: if ep -> entry.dirsw then do; /* truncating directories not allowed */ code = error_table_$dirseg; go to unlock; end; if addrs < 0 then do; /* check for negative length specified */ code = error_table_$argerr; go to unlock; end; /* check for length too big */ fpage = divide (addrs + 1023, 1024, 17, 0); /* get number of first page to be truncated */ go to join1; trentry: entry (a_ep); esw = 2; fpage = 0; ep = a_ep; code = 0; dp = ptr (ep, 0); join1: code = mountedp (dir.sons_lvid); if code = 0 then do; dir.modify = pds$processid; /* Mark dir inconsistent */ call truncate_vtoce (ep, fpage, code); /* Truncate the vtoce/aste */ if code ^= 0 then if code = error_table_$rqover then code = 0; /* ignore rqo */ end; if esw = 2 then return; /* if deleting, return */ dir.modify = "0"b; call sum$dirmod (dp); if by_name then call dc_find$finished (dp, "1"b); else call lock$dir_unlock (dp); /* unlock the directory */ /* The following code zeros out the last page of the segment starting at addrs. This is so that truncating will be to the word, rather than to the page. */ if code ^= 0 then go to finale; on condition (out_of_bounds) go to boundviol; /* Attempt to trunc beyond current length may cause oob here */ overlay_size = (fpage * 1024 - addrs) * 36; /* compute n bits to zero */ if overlay_size ^= 0 then do; /* dont bother if none to zero */ if esw = 0 then do; /* if entered without ptr, we must get one */ call initiate (parent, ename, "", 0, 1, segptr, code); if segptr = null then goto finale; code = 0; /* forget any segknowns */ end; addrel (segptr, addrs) -> overlay = ""b; /* clear the words */ if esw = 0 then call terminate_$noname (segptr, code); /* terminate the pointer if we had to get one */ end; finale: a_code = code; return; unlock: if dir.modify then dir.modify = "0"b; if by_name then call dc_find$finished (dp, "1"b); else call lock$dir_unlock (dp); go to finale; boundviol: a_code = error_table_$boundviol; return; %page; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include dir_header; %page; %include kst; end;  uid_path_util.pl1 11/11/89 1132.4rew 11/11/89 0800.7 50589 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ /* Procedure which contains some entires that now how to deal with uid pathnames. This module was written for use by Master directory Control. */ /* UID_PATH_UTIL has the following entries: 1. uid_path_util$get: Given a pointer to a directory, this entry returns the uidpathname of its parent 2. uid_path_util$get_uid_path: A gate entry which, given a pathname, returns a uid pathname. 3. uid_path_util$decode_uidpath: A gate entry which, given a uid pathanme, returns a directory and entry name. */ /* Written March 1975 by Larry Johnson */ /* Modified July 1984 by Keith Loepere to use the new dc_find. */ /* Modified January 1985 by EJ Sharpe to handle et_$root */ /* Modified May 1985 by EJ Sharpe to add decode_uidpath_raw and decode_uidpath_priv, the decode_uidpath entry now requires "S" on parent */ uid_path_util: proc; /* Parameters */ dcl a_code fixed bin (35); dcl a_dirname char (*); /* Name of directory to return */ dcl a_dp ptr; /* Returned pointer to the directory */ dcl a_ename char (*); /* Entry name to return */ dcl a_uidpath (0:15) bit (36) aligned; /* Pathname of directory to find */ /* Variables */ dcl build_dir char (168) var init (""); dcl code fixed bin (35); dcl decodesw bit (1) init ("0"b);/* Set if entered thru decode_uidpath entry */ dcl dirsw bit (1) init ("0"b);/* Set if entered thru dir entry */ dcl dname char (168); dcl ename char (32); dcl i fixed bin; dcl segnum fixed bin; dcl uidpath (0:15) bit (36) aligned; /* Misc */ dcl (ptr, segno, unspec) builtin; /* External */ dcl error_table_$bad_uidpath ext fixed bin (35); dcl error_table_$root ext fixed bin (35); /* Entries */ dcl get_kstep$dir entry (fixed bin, ptr, fixed bin (35)); dcl uid_path_util$get entry (ptr, dim (0:15) bit (36) aligned, fixed bin (35)); %page; /* This entry will get a uid pathname from a directory pointer */ get: entry (a_dp, a_uidpath, a_code); a_code = 0; dp = a_dp; a_uidpath = "0"b; do i = dir.tree_depth to 0 by -1; /* Scan backwards thru all parents */ segnum = segno (dp); call get_kstep$dir (segnum, kstep, code); /* Find the kst entry */ if code ^= 0 then go to err; a_uidpath (i) = kste.uid; dp = kste.entryp; /* Back to parent */ end; return; /* This entry is called thru a gate. Given a directory and entry name, it returns the uidpath */ get_uidpath: entry (a_dirname, a_ename, a_uidpath, a_code); dname = a_dirname; ename = a_ename; unspec (a_uidpath) = "0"b; call dc_find$obj_status_read_priv (dname, ename, DC_FIND_NO_CHASE, ep, code); /* Find my seg */ if code ^= 0 then go to err; dp = ptr (ep, 0); call uid_path_util$get (dp, uidpath, code); /* Get uidpath of parent */ if code ^= 0 then do; call dc_find$finished (dp, "1"b); go to err; end; uidpath (dir.tree_depth + 1) = entry.uid; /* Finish up with uid of entry */ call dc_find$finished (dp, "1"b); a_uidpath = uidpath; return; err: a_code = code; return; /* This entry, called thru a gate, will return a directory and entry name, given a uidpath name. The caller must have "S" access on parent of the entry. It is used by master directory control via admin_gate_. */ decode_uidpath: entry (a_uidpath, a_dirname, a_ename, a_code); uidpath = a_uidpath; a_dirname, a_ename = ""; a_code = 0; call dc_find$obj_status_read_uid (uidpath, dname, ename, ep, code); goto decode_common; /* This entry, called thru a gate, will return a directory and entry name, given a uidpath name. The caller need not have "S" access on parent of the entry. */ decode_uidpath_priv: entry (a_uidpath, a_dirname, a_ename, a_code); uidpath = a_uidpath; a_dirname, a_ename = ""; a_code = 0; call dc_find$obj_status_read_priv_uid (uidpath, dname, ename, ep, code); goto decode_common; /* This entry, called thru a gate, will return a directory and entry name, given a uidpath name. It allows access to the names of aim isolated dirs. It is called from the volume backup system via the hc_backup_ gate. */ decode_uidpath_raw: entry (a_uidpath, a_dirname, a_ename, a_code); uidpath = a_uidpath; a_dirname, a_ename = ""; a_code = 0; call dc_find$obj_status_read_raw_uid (uidpath, dname, ename, ep, code); decode_common: if code = error_table_$root then do; code = 0; ename = ""; /* no entry */ end; else if code = error_table_$bad_uidpath then do; /* return what we know */ a_dirname = dname; a_ename = ""; go to err; end; else if code ^= 0 then go to err; /* return the error */ else call dc_find$finished (ptr (ep, 0), "1"b); /* we're finished */ a_dirname = dname; a_ename = ename; a_code = 0; return; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include dir_header; %page; %include kst; end uid_path_util;  vacate_pv.pl1 11/11/89 1132.4rew 11/11/89 0800.7 49716 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(88-05-01,Parisek), approve(88-05-27,MCR7907), audit(88-06-02,Fawcett), install(88-09-27,MR12.2-1122): Changed to NOT set pc_vacating in the pvte. This flag would inhibit any new pages being withdrawed from this pv. The concept of inhibit is to inhibit any new segments. If pc_vacating is set and a segment like the kst needs one more page, the system loop trying to get a page on the pv. The kst cannot be moved. END HISTORY COMMENTS */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ vacate_pv: proc (a_pvtx, a_pvid, a_code); /* vacate_pv Bernard Greenberg 05/24/76 Procedure to segmove all of the segments on a given physical volume. Must be driven by pathname from outer ring. */ /* modified 4/77 by M. Weaver to change calling sequences to makeknown_ and terminate_ */ /* Modified March 1982, J. Bongiovanni, for new PVTE, demand_segmove */ /* Modified 84-10-17, BIM, TEMPORARILY set pvte.pc_vacating */ /* Modified July 1984 by Keith Loepere to use the new dc_find. */ /* Modified November 1984 by Keith Loepere for auditing. */ /* Parameters */ dcl a_code fixed bin (35); dcl a_dirname char (*); dcl a_ename char (*); dcl a_pvid bit (36) aligned; dcl a_pvtx fixed bin; dcl a_segptr ptr; /* External */ dcl error_table_$argerr fixed bin (35) ext; dcl error_table_$bad_index fixed bin (33) ext; dcl error_table_$segknown fixed bin (35) ext; dcl pvt$n_entries fixed bin ext; /* Variables */ dcl called_find bit (1) aligned init ("0"b); dcl code fixed bin (35); dcl dir char (168); dcl dp ptr; dcl ent char (32); dcl 1 mkinf aligned like makeknown_info; dcl pvid bit (36) aligned; dcl pvtx fixed bin; dcl segno fixed bin; dcl segptr ptr; /* Entries */ dcl activate entry (ptr, fixed bin (35)) returns (ptr); dcl lock$dir_unlock entry (ptr); dcl makeknown_ entry (ptr, fixed bin, fixed bin, fixed bin (35)); dcl makeunknown_ entry (fixed bin, bit (36) aligned, bit (1) aligned, fixed bin (35)); dcl segment_mover$demand_segmove entry (ptr, ptr, fixed bin, fixed bin (35)); /* Misc */ dcl (addr, ptr, unspec) builtin; %page; /* These entries are not protected by any form of lock. It is assumed that the caller is cooperating with the demounter in the setting of these bits. */ pvtx = a_pvtx; pvt_arrayp = addr (pvt$array); pvid = a_pvid; code = 0; if pvtx <= 0 | pvtx > pvt$n_entries then do; a_code = error_table_$bad_index; return; end; pvtep = addr (pvt_array (pvtx)); /* Address pvte */ if pvte.being_demounted | (pvte.pvid ^= pvid) then code = error_table_$argerr; else if pvte.storage_system & pvte.used & pvid = pvte.pvid then pvte.vacating = "1"b; else code = error_table_$argerr; a_code = code; return; stop_vacate: entry (a_pvtx, a_pvid, a_code); pvt_arrayp = addr (pvt$array); pvid = a_pvid; pvtx = a_pvtx; code = 0; if pvtx <= 0 | pvtx > pvt$n_entries then do; a_code = error_table_$bad_index; return; end; pvtep = addr (pvt_array (pvtx)); if pvte.used & pvte.storage_system & pvte.vacating & (pvte.pvid = pvid) then pvte.vacating = "0"b; else code = error_table_$argerr; a_code = code; return; %page; move_seg_file: entry (a_dirname, a_ename, a_code); /* This entry starts a segmove on a seg given the name */ dir = a_dirname; ent = a_ename; code = 0; call dc_find$obj_status_write_priv (dir, ent, DC_FIND_CHASE, FS_OBJ_SEG_MOVE, ep, code); if code ^= 0 then go to finale; called_find = "1"b; go to join; /* Merge with seg entry */ move_seg_seg: entry (a_segptr, a_code); segptr = a_segptr; code = 0; call dc_find$obj_status_write_priv_ptr (segptr, FS_OBJ_SEG_MOVE, ep, code); if code ^= 0 then go to finale; join: dp = ptr (ep, 0); makeknown_infop = addr (mkinf); /* Get local makeknown info */ unspec (makeknown_info) = ""b; /* Clear all things we don't know about */ makeknown_info.uid = entry.uid; makeknown_info.dirsw = entry.dirsw; makeknown_info.entryp = ep; /* Set up for makeknown */ call makeknown_ (makeknown_infop, segno, (0), code); if code = 0 | code = error_table_$segknown then do; astep = activate (ep, code); /* Get AST entry */ if code = 0 then do; aste.pack_ovfl = "1"b; /* Cause seg mover to do thing */ call segment_mover$demand_segmove (astep, ep, segno, code); end; call makeunknown_ (segno, "0"b, ("0"b), (0)); end; if called_find then call dc_find$finished (dp, "1"b); else call lock$dir_unlock (dp); finale: a_code = code; return; %page; %include aste; %page; %include dc_find_dcls; %page; %include dir_entry; %page; %include fs_obj_access_codes; %page; %include makeknown_info; %page; %include pvte; end; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- 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