create_homedir_.pl1 03/15/89 0840.8r w 03/15/89 0800.7 59553 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ create_homedir_: proc (P_person, P_alias, P_minimum_auth, P_project, P_homedir, P_projdir, P_code); /* This program is used to create home directories. If the "P_person" argument is "anonymous" no directory will be created. Some checks are made to ensure that a home directory will be below the project dir. THVV */ /* Modified May 1981, E. N. Kittlitz. Don't create through link. as_log creation notice severity changed to 0. Miscellaneous changes */ /* Modified September 1982, E. N. Kittlitz. Set dir rbs to 7,7. Fix anonymous. */ /* Modified 1984-08-27 BIM. No more automatic project dir creations. Handle upgraded users. */ /* Modified 1984-12-27, Keith Loepere. Set dir_quota at append. */ dcl P_alias char (*); dcl P_code fixed bin (35); dcl P_homedir char (*); dcl P_person char (*); dcl P_projdir char (*); dcl P_project char (*); dcl P_minimum_auth bit (72) aligned; dcl bitcount fixed bin (24); dcl code fixed bin (35); dcl hd char (32); dcl i fixed bin; dcl ignore_code fixed bin (35); dcl type fixed bin (2); dcl uid char (32); dcl (hdd, hdd_dir) char (168); dcl hdd_entryname char (32); dcl pd_acc bit (72) aligned; dcl 1 cbi aligned like create_branch_info; dcl error_table_$badpath fixed bin (35) external; dcl error_table_$noentry fixed bin (35) external; dcl error_table_$notadir fixed bin (35) external; dcl aim_check_$greater entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl display_access_class_ entry (bit (72) aligned) returns(character (32) aligned); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_group_id_ entry () returns (char (32)); dcl hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$get_access_class entry (char (*), char (*), bit (72) aligned, fixed bin (35)); dcl hcs_$create_branch_ entry (char (*), char (*), ptr, fixed bin (35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl ioa_$rsnnl entry options (variable); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl sys_log_ entry options (variable); dcl sys_log_$error_log entry options (variable); dcl 1 acla (4) aligned, /* structure for setting ACL of new dir */ 2 userid char (32), 2 mode bit (36), 2 rcode fixed bin (35); dcl (addr, substr, unspec) builtin; /* -------------------------------------------------------- */ P_code = 0; code = 0; call ioa_$rsnnl ("^a.^a.*", uid, i, P_person, P_project); if substr (P_homedir, 1, 5) = "[pd]>" then return;/* act_proc will create home dir below process dir */ call expand_pathname_ (P_homedir, hdd, hd, code); if code ^= 0 then go to no_homedir; /* invalid pathname */ call hcs_$status_minf (hdd, hd, 0, type, bitcount, code); /* see if there's an entry */ if code = 0 then if type = 2 then return; else do; /* Type not 2: non-directory branch found. */ if type = 0 then do; /* it's a link, do some more looking */ call hcs_$status_minf (hdd, hd, 1, type, bitcount, code); if code = 0 & type = 2 then return;/* link is to directory, nothing more to do */ end; code = error_table_$notadir; /* Fuss fuss */ go to no_homedir; end; if code ^= error_table_$noentry then go to no_homedir; /* We have a regular user with an nonexistent home directory */ if hdd ^= P_projdir then /* Only certain places we will create it */ if hdd ^= pathname_ (">user_dir_dir", P_project) then do; /* try to fabricate with project name */ if hdd ^= pathname_ (">udd", P_project) then do; /* ditto */ code = error_table_$badpath; go to no_homedir; end; end; call hcs_$get_access_class (">udd", P_project, pd_acc, code); if code ^= 0 then pd_acc = ""b; unspec (cbi) = ""b; cbi.version = create_branch_version_2; cbi.dir_sw = "1"b; cbi.chase_sw = "0"b; /* make it plain - no chasing! */ cbi.parent_ac_sw = ^aim_check_$greater (P_minimum_auth, pd_acc); cbi.access_class = P_minimum_auth; cbi.mode = SMA_ACCESS; cbi.userid = uid; cbi.rings (*) = 7; /* no restrictions here */ call hcs_$create_branch_ (hdd, hd, addr (cbi), code); if code ^= 0 then go to no_homedir; /* Don't try to delete - might bite branch with same name */ if P_alias ^= "" then call hcs_$chname_file (hdd, hd, "", P_alias, code); call sys_log_ (0, "create_homedir_: creating ""^a"" for ""^a"" ^a", P_homedir, uid, display_access_class_ (P_minimum_auth)); return; /* all OK, proceed */ no_homedir: if code = 0 then P_code = error_table_$noentry; else P_code = code; call sys_log_$error_log (0, P_code, "create_homedir_", """^a"" ""^a"" ^a", P_homedir, uid, display_access_class_ (P_minimum_auth)); %page; %include access_mode_values; %include create_branch_info; %page; /* BEGIN MESSAGE DOCUMENTATION Message: create_homedir_: creating "DIRNAME" for "USERID" S: as (severity0). T: $run M: The user USERID did not have a home directory. It was created for him during login, or when his project's PDT was installed. This is reasonable if this is the first time he has logged in. However, his directory may have been destroyed by the Salvager, in which case you have to retrieve his files. A: A retrieval of the user's directory may be necessary. Message: create_homedir_: Bad syntax in pathname. DIRNAME NAME.PROJ S: as (severity0). T: $run M: Typically caused by a homedir specification starting with other than >user_dir_dir or >udd. It may also occur while attempting to create the home directory for the user with name NAME and project PROJ. A: $note_sa Message: create_homedir_: ERROR_MESSAGE. DIRNAME NAME.PROJ S: as (severity0). T: $run M: An error occurred while attempting to create the home directory for the user with name NAME and project PROJ. A: $note_sa END MESSAGE DOCUMENTATION */ end create_homedir_;  hash_.pl1 09/16/83 1408.5rew 09/16/83 1134.7 107325 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ hash_: procedure; /* format: style4 */ /* originally coded by k.willis 2/71 */ /* modified by T. Casey, Feb 75, to keep table between 70% and 85% full, and to rehash only when adding an entry */ /* Modified for move to hardcore; word entrypoints, no-write entrypoints; Benson I. Margulies 1/82 */ /* Modified by E. N. Kittlitz for no-write no-write, ensure that force_grow really does grow. */ %include hashst; /* this subroutine initializes, inserts, deletes, and searches for entries in a hash table. ***to initialize hash table call hash_$make(htp,n,code); htp is a pointer to the hash table(input) n is the number of buckets wanted(input) code is the error code(output) ***to obtain the optimum size table for a given number of entries n = hash_$opt_size(n_entries); n_entries is the initial number of buckets that will be used(input) n is the optimal table size, to be used in a call to hash_$make(output - function return value) ***to insert an entry in the table call hash_$in(htp,ename,eval,code); htp is a pointer to the hash table(input) ename is the name of the entry(input) eval is the value of the entry(input) code is the error code(output) ***to hash in without growing table ***for use when table cannot just be extended off of end. call hash_$in_no_grow(htp,ename,eval,code); htp is a pointer to the hash table(input) ename is the name of the entry(input) eval is the value of the entry(input) code is the error code(output) ***to delete an entry in the table call hash_$out(htp,ename,eval,code); htp is a pointer to the hash table(input) ename is the name of the entry(input) eval is the value of the entry(output) code is the error code(output) ***to search for an entry in the table call hash_$search(htp,ename,eval,code) htp is a pointer to the hash table(input) ename is the name of the entry(input) eval is the value of the entry(output) code is the error code(output) ***to search without writing meters call hash_$search_no_write(htp,ename,eval,code) htp is a pointer to the hash table ename is the name of the entry (input) eval is the value of the entry(output) code is the error code; */ /* PARAMETERS */ dcl code fixed bin (35); /* error code */ dcl ename char (*); /* name of an entry in hash table */ dcl eval bit (36) aligned; /* value of entry corresponding to ename */ dcl htp pointer; /* pointer to the hash table */ dcl n_entries fixed bin; /* initial number of entries to be placed in table */ dcl i fixed bin; dcl n fixed bin; /* number of buckets wanted in new hash table */ dcl loht fixed bin (24); /* length of table in words */ dcl nb fixed bin; /* number of entries (buckets) in table */ dcl max_ht_entries fixed bin; /* max value of nb - function of max_seg_size */ dcl pname char (32) aligned; /* name of entry passed to hash_index */ dcl pn pointer; dcl (hashing_in, rehashing) bit (1) aligned init ("0"b); dcl (emploc, hsi, nhsi, ntries) fixed bin; dcl found bit (1) aligned; dcl sys_info$max_seg_size ext fixed bin (19); dcl (error_table_$namedup, error_table_$segnamedup, error_table_$noentry) ext fixed bin (35); dcl (error_table_$bigarg, error_table_$full_hashtbl) ext fixed bin (35); dcl hash_index_ entry (ptr, fixed bin (21), fixed bin, fixed bin) returns (fixed bin); /* hashing subroutine */ dcl rehash_ entry (ptr, fixed bin, fixed bin (35)); dcl (addr, divide, fixed, float, mod) builtin; opt_size: entry (n_entries) returns (fixed bin); /* Compute optimal table size to accomodate n_entries: make it 70% full, then round upward to the next full page. */ max_ht_entries = divide (sys_info$max_seg_size - 8, 10, 17, 0); if n_entries >= max_ht_entries then /* if there are too many entries */ return (n_entries); /* the caller will find out when he tries to use it */ nb = fixed (float (n_entries) / .7); /* compute number of entries in 70% full table */ loht = 8 + 10 * nb; /* compute word length of that table */ i = mod (loht, 1024); /* round it up to next full page */ if i > 0 then /* if a page is partially used */ loht = loht + 1024 - i; /* fill it up */ nb = divide (loht - 8, 10, 17, 0); /* compute number of entries that will fit */ if nb > max_ht_entries then /* if that is bigger than a segment */ nb = max_ht_entries; /* then make it a full segment */ return (nb); %page; make: entry (htp, n, code); max_ht_entries = divide (sys_info$max_seg_size - 8, 10, 17, 0); /* 8-word header, 10-word entries */ if (n > max_ht_entries | n <= 0) then /* check number of buckets */ code = error_table_$bigarg; else do; code = 0; htable.ni = 0; /* initialize statistical info */ htable.np = 0; htable.tnt = 0; htable.id = "ht02"; htable.gnt = 1; htable.loht = n * 10 + 8; htable.nb = n; /* Now the refer extent is legal ! */ htable.buckets (*).flags.empty = "1"b; htable.buckets (*).flags.ds = "0"b; htable.buckets (*).name = ""; htable.buckets (*).value = ""b; end; return; %page; in: entry (htp, ename, eval, code); if float (htable.ni) / float (htable.nb) > .85 /* if table is more than 85% full */ then call grow_hash_table; /* internal procedure to grow it to 70% full */ join_in: /* no_grow enters here */ hashing_in = "1"b; /* we will rehash, if necessary, to add this entry */ call hasher; if ^found then do; /* entry did not already exist */ htable.ni = htable.ni + 1; /* increment number of entries in table */ htable.flags.empty (emploc), htable.flags.ds (emploc) = "0"b; /* set deleted and empty switches off */ htable.value (emploc) = eval; /* store value in bucket(emploc) */ htable.name (emploc) = pname; /* store identifier */ end; else if htable.value (hsi) = eval then code = error_table_$segnamedup; /* entry existed with same value */ else code = error_table_$namedup; /* entry existed with different value */ return; %page; search: entry (htp, ename, eval, code); call hasher; search_join: if found then eval = htable.value (hsi); /* set return value to that found by search */ else code = error_table_$noentry; /* entry was not found */ return; search_no_write: entry (htp, ename, eval, code); call hasher_no_write; goto search_join; %page; out: entry (htp, ename, eval, code); call hasher; if found then do; /* entry was found-is at hsi */ htable.ni = htable.ni - 1; /* decrement number of entries */ eval = htable.value (hsi); /* set return value */ htable.flags.ds (hsi) = "1"b; /* set deleted switch */ nhsi = hsi + 1; if nhsi > htable.nb then nhsi = 1; /* find the next hash entry */ if htable.flags.empty (nhsi) = "1"b then do i = hsi by -1 to 1, htable.nb by -1 to nhsi; /* if empty */ if htable.flags.ds (i) = "0"b then return; /* then reset any buckets that were deleted to empty */ htable.flags.ds (i) = "0"b; /* to minimize length of future searches, since searches must */ htable.flags.empty (i) = "1"b; /* search past deleted buckets, until they hit an empty one */ end; end; else code = error_table_$noentry; /* entry was not found */ return; %page; /* Entry for use when the table may not grow */ in_no_grow: inagain: entry (htp, ename, eval, code); rehashing = "1"b; /* set switch to prevent endless recursion */ go to join_in; %page; hasher: procedure; declare can_write bit (1) aligned; can_write = "1"b; goto w_join; hasher_no_write: entry; can_write = "0"b; w_join: htentry: emploc, code = 0; /* set to zero-changed if found or error */ found = "0"b; pn = addr (pname); /* get address of name to be passed to hash_index */ if can_write then htable.np = htable.np + 1; /* increment number of probes */ pname = ename; /* make ename 32 characters */ hsi = hash_index_ (pn, 32, 1, htable.nb); /* get the hash index of the name */ hsi = hsi + 1; ntries = 1; srch: if htable.flags.empty (hsi) = "1"b then do; /* if bucket is empty */ if emploc = 0 then emploc = hsi; /* emploc is first empty bucket, either empty or deleted, where this entry could be added, if not found */ update: if can_write then do; if ntries > htable.gnt then htable.gnt = ntries; /* set greatest number of tries */ htable.tnt = htable.tnt + ntries; /* set total number of tries */ end; return; end; if htable.flags.ds (hsi) = "1"b then do; /* if deleted, this would be where to add the entry */ if emploc = 0 then emploc = hsi; /* so set emploc, if not already set */ /* but we can not be sure the entry is not already in the table, until we find an empty (not just deleted) bucket */ end; else do; /* there is an entry at hsi */ if htable.name (hsi) = pname then do; /* if the names match */ found = "1"b; /* then set found to 1 */ go to update; /* go to check gnt */ end; end; contsrch: hsi = hsi + 1; /* continue the search until found or empty bucket */ if hsi > htable.nb then hsi = 1; /* get next bucket */ if ntries > divide (htable.nb, 2, 17, 0) then do; /* if too many tries, we should rehash */ if ^hashing_in then /* but only if this entry is to be added */ goto update; /* so, for $search, or $out, we say "not found" */ else if rehashing then goto giveup; /* also, if we are already rehashing, don't recurse */ call grow_full_hash_table; /* internal procedure - makes a 70% full table */ go to htentry; /* go start search over again, using rehashed table */ end; ntries = ntries + 1; /* increment the number of tries for search */ go to srch; end hasher; grow_hash_table: proc; /* grow an 85% full table to 70% full */ dcl full bit (1) aligned; dcl new_size fixed bin; full = "0"b; /* we will not insist on rehashing */ goto grow_common; grow_full_hash_table: entry; /* grow table to get rid of a run more than half the length of the table long */ full = "1"b; /* we will insist on rehashing */ grow_common: max_ht_entries = divide (sys_info$max_seg_size - 8, 10, 17, 0); if htable.nb >= max_ht_entries then do; /* if table already at max size */ if full then goto giveup; /* if we are insisting, exit with an error code */ else return; /* otherwise add the entry without rehashing */ end; nb = htable.ni; /* pick up count of currently-used entries */ if full then if float (nb) / float (htable.nb) < .7 then /* if table not 70% full */ nb = fixed (float (htable.nb) * .85); /* lie - say its 85% full - to make sure it grows */ new_size = opt_size (nb); /* first estimate on size */ if full then /* ensure it's a real growth */ do while (new_size <= htable.nb); /* now let's force the issue */ nb = nb + 1; new_size = opt_size (nb); end; call rehash_ (htp, new_size, code); if code ^= 0 then goto giveup; /* nonlocal goto */ return; end grow_hash_table; /* Come here if table is too full to rehash */ giveup: code = error_table_$full_hashtbl; htable.tnt = htable.tnt + ntries; /* increment total number of tries */ if ntries > htable.gnt then /* and update greatest number of tries */ htable.gnt = ntries; return; end hash_;  rehash_.pl1 11/12/82 1353.9rew 11/12/82 1042.7 30753 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ rehash_: procedure (htp, newsize, ec); /* originally coded by k.willis 2/71 */ /* Modified for hardcore/cleanup/NSS BIM 1/82 */ %include hashst; %page; /* PARAMETERS */ dcl htp ptr; /* Ptr to existing hash table. */ dcl newsize fixed bin; /* Number of buckets to put in new table */ dcl new_htp pointer; dcl ec fixed bin (35); /* error code. */ /* AUTOMAGIC */ dcl bit_count fixed bin (24); /* the number of bits in a table */ dcl i fixed bin; dcl space_provided_switch bit (1) aligned; /* caller gave us new place */ dcl new_tablep pointer; /* ENTRIES */ dcl hash_$make entry (ptr, fixed bin, fixed bin (35)); /* subroutines called */ dcl hash_$in_no_grow entry (ptr, char (*), bit (36) aligned, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl (get_temp_segment_, release_temp_segment_) entry (char (*), ptr, fixed bin (35)); dcl error_table_$full_hashtbl ext fixed bin (35); dcl null builtin; /* this subroutine changes the size of a hash table. to do this it creates a dummy hash table, initializes it, and inserts each non empty non deleted entry of the old table into the dummy table. */ space_provided_switch = "0"b; goto JOIN; new_storage: entry (htp, new_htp, newsize, ec); space_provided_switch = "1"b; JOIN: ec = 0; /* set error code to 0 */ if space_provided_switch then new_tablep = new_htp; else do; call get_temp_segment_ ("rehash_", new_tablep, ec); if ec ^= 0 then return; end; call hash_$make (new_tablep, newsize, ec); /* initialize dummy table */ if ec ^= 0 then go to term; /* invalid bucket size */ do i = 1 to nb; /* loop on non-empty, non-deleted entries */ if empty (i) = "0"b then if ds (i) ^= "1"b then do; call hash_$in_no_grow (new_tablep, htable.name (i), htable.value (i), ec); if ec = error_table_$full_hashtbl /* if duplicates occur, only one entry in new table */ then go to term; /* .. if new table full, give up */ end; end; /* At this point, if we are growing an existing segment, we reset bit count */ /* The old code assumed the HT was in a segment by itself. This seems */ /* ill advised, so now we use the actual address of the end of the table. */ /* If the new space was provided, then we do not touch any such thing. */ if ^space_provided_switch then do; bit_count = 36 * bin (rel (addr (new_tablep -> htable.end_of_table)), 18); call hcs_$set_bc_seg (ptr (htp, 0), bit_count, ec); if ec ^= 0 then go to term; hash_table_size_ = new_tablep -> htable.nb; htp -> htable.nb = new_tablep -> htable.nb; htp -> htable = new_tablep -> htable; call release_temp_segment_ ("rehash_", new_tablep, (0)); end; return; term: if ^space_provided_switch then call release_temp_segment_ ("rehash_", new_tablep, (0)); return; end rehash_;  up_cdt_.pl1 10/21/92 1528.0rew 10/21/92 1520.0 402480 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1992 * * * * 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 */ up_cdt_: procedure (user_cdtp, wordcount, instaldir, instalname, instalp, ansp, ip, answer, code); /* UP_CDT_ - update the Channel Definition Table (CDT) This program checks a candidate CDT for acceptability before installing. THVV Aug 75 Modified 751024 by PG to check terminal access_class vs. authorization, not max_authorization, to fix bug in bumping innocent users. Modified 760603 by Roy P. Planalp to recognize and attach channels of service_type FTP Modified 760826 by Mike Grady to update version 2 CDTs Modified November 1976 by T. Casey to fix bug in changing terminal access class. Modified June 1977 by Robert Coren to use terminal type names instead of numbers and to . check that specified terminal types are in TTT. Modified September 1977 by T. Casey to make channel deletions reversible during the same bootload, and fix bugs. Modified January 1978 by T. Casey to fix bug in previous modification. Modified February 1978 by G. Dixon to fix bug in Sept 77 modification. Modified Fall 1978 by Larry Johnson for ring-0 demultiplexing. Modified April 1979 by Larry Johnson for fnpe changes. Modified January 1981 by E. N. Kittlitz to eliminate CDTE.phone_no. Modified November 1981, E. N. Kittlitz. user_table_entry conversion. Modified December 1981, Benson I. Margulies. trees in the cdts. Modified February 1982, E. N. Kittlitz. xxx.install.acs conversion. Modified July 1982, BIM, fixes to tree stuff. Modified July 1982, E. N. Kittlitz. to not listen to masked channel. Modified October 1982, E. N. Kittlitz. change some sys_log_ severities. Modified 84-03-26 BIM for version 5 cdt, aim ranges. Modified 1984-08-07 BIM to initialize mpxe fields for new multiplexers. Modified: 10/05/84 by R. Michael Tague: up_sysctl_$check_acs now returns a bit (36) mode string instead of a fixed bin (5) and no longer takes a directoy arg. */ /****^ HISTORY COMMENTS: 1) change(87-04-28,GDixon), approve(87-07-13,MCR7741), audit(87-07-15,Hartogs), install(87-08-04,MR12.1-1055): Updated for change to user_table_entry.incl.pl1. 2) change(92-10-14,Schroth), approve(92-10-14,MCR8264), audit(92-10-15,Zimmerman), install(92-10-21,MR12.5-1036): Correct several potential null pointer faults when attempting to install a new CDT. END HISTORY COMMENTS */ /* parameters */ dcl (user_cdtp, instalp, ansp, ip) ptr, wordcount fixed bin; dcl code fixed bin (35) parameter; dcl instaldir char (*), instalname char (*), answer char (*); /* entries */ dcl aim_check_$equal 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 aim_check_$in_range entry (bit (72) aligned, (2) bit (72) aligned) returns (bit (1) aligned); dcl astty_$tty_order entry (ptr, char (*), ptr, fixed bin (35)); dcl asu_$asu_listen entry (ptr, fixed bin (35)); dcl cdt_mgr_$find_cdt_channel entry (ptr, char (32), fixed bin, bit (1) aligned, fixed bin (35)); dcl cdt_mgr_$thread entry (ptr, fixed bin (35)); dcl cdt_mgr_$thread_out_cdt_channel entry (ptr, fixed bin); dcl cdt_mgr_$thread_in_cdt_channel entry (ptr, fixed bin); dcl display_access_class_ entry (bit (72) aligned) returns (character (32) aligned); dcl display_access_class_$range entry ((2) bit (72) aligned) returns (character (32) aligned); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl (get_temp_segment_, release_temp_segment_) entry (char (*), ptr, fixed bin (35)); dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); dcl hcs_$set_safety_sw entry (char (*), char (*), bit (1) aligned, fixed bin (35)); /* SWS */ dcl hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl cu_$level_get entry (fixed bin); dcl sys_log_ entry options (variable); dcl sys_log_$error_log entry options (variable); dcl ttt_info_$terminal_data entry (character (*), fixed binary, fixed binary, pointer, fixed binary (35)); dcl asu_$attach_channel entry (ptr, fixed bin (35)); dcl asu_$bump_code entry (ptr, fixed bin (35), char (8), fixed bin (35), fixed bin); dcl asu_$write_chn_message entry (ptr, fixed bin (35), char (8), fixed bin (35)); dcl asu_$asu_remove entry (ptr); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); /* dcl ttt_info_$terminal_data /* entry (char (*), fixed bin, fixed bin, ptr, fixed bin (35)); */ dcl up_sysctl_$check_acs entry (char (*), char (*), fixed bin, bit (36) aligned, fixed bin (35)); /* external static */ dcl sc_stat_$sysdir character (168) unaligned external; dcl as_error_table_$chn_auth_excludes fixed bin (35) external static; dcl as_error_table_$chn_deleted fixed bin (35) external static; dcl as_error_table_$chn_svc_changed fixed bin (35) external static; dcl error_table_$action_not_performed fixed bin (35) external static; /* automatic */ dcl (auth_string, old_auth_string) char (32) aligned; dcl (line_type, service_type) fixed bin; dcl system_high bit (72) aligned; dcl fnp_sw bit (1) aligned; dcl (i, cdtx) fixed bin; dcl movelen fixed bin (24); dcl mode bit (36) aligned; dcl ring fixed bin; dcl debg char (8); dcl offset fixed bin (18); dcl (p, q, old_cdtp, new_cdtp) ptr; dcl retry_count fixed bin; /* internal static */ dcl acs_name char (32) int static options (constant) init ("cdt.install.acs"); dcl ( LEGAL char (95) init /* Printables except PAD, semicolon, but with BS */ ( " !""#$%&'()*+,-./0123456789:<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~" ), REMOVE_THIS_CHANNEL fixed bin initial (100), /* this channel is being removed from service */ ATTACH_THIS_CHANNEL fixed bin initial (200), /* this channel is being added */ LISTEN_TO_THIS_CHANNEL fixed bin initial (300), /* this channel existed before, but line type was changed */ DELETE_THIS_CHANNEL fixed bin initial (400), /* this channel being deleted */ UNDELETE_THIS_CHANNEL fixed bin initial (500) /* deleted channel being added back */ ) internal static options (constant); /* based */ dcl 1 movetable based aligned, 2 moveary (movelen) bit (36) aligned; dcl 1 CDT aligned like cdt based; /* No dangerous implicit qualification */ dcl 1 CDTE aligned like cdte based; dcl 1 FNPE aligned like fnpe based; /* Condition */ dcl sub_error_ condition; /* builtin */ dcl (addr, clock, hbound, null, size, string, verify, unspec, wordno) builtin; %page; /* ============================================ */ /* There are three copies of the CDT referenced in this procedure. All references are by explicit use of pointers: user_cdtp points to the supplied CDT (the one that was given to us to be installed); old_cdtp points to the old CDT (>sc1>cdt); new_cdtp points to the temporary segment in which we will build a new CDT by merging the supplied one with the current one; p and q point to CDT entries. They are used for different purposes in various parts of the program. */ /* Check the validity of the supplied CDT and the access permissions of the installer. */ retry_count = 0; RETRY_INSTALLATION: cdtp = null; /* TAKE A FAULT IF WE FORGET TO QUALIFY */ cdtep = null; fnpep = null; mpxep = null; new_cdtp = null; old_cdtp = null; system_high = installation_parms.access_authorization_ceiling; call cu_$level_get (ring); answer = ""; instalp = null; /* pre-set returned pointer */ instaldir = sc_stat_$sysdir; /* used to be anstbl */ instalname = "cdt"; if wordcount < 64 then do; /* make sure segment contains something */ answer = "wordcount < 64"; code = error_table_$action_not_performed; go to RETURN; end; if user_cdtp -> CDT.version ^= CDT_version then do; /* Check right overlay dcl */ answer = "incorrect table version"; code = error_table_$action_not_performed; go to RETURN; end; if user_cdtp -> CDT.current_size > user_cdtp -> CDT.max_size then do; answer = "current_size > max_size"; code = error_table_$action_not_performed; go to RETURN; end; if user_cdtp -> CDT.n_cdtes > user_cdtp -> CDT.current_size then do; answer = "n_cdtes > current_size"; code = error_table_$action_not_performed; go to RETURN; end; offset = wordno (addr (user_cdtp -> cdt.cdt_entry (1))) + (size (cdte) * user_cdtp -> cdt.current_size); if offset ^= wordcount then do; answer = "size inconsistent with wordcount"; code = error_table_$action_not_performed; go to RETURN; end; call up_sysctl_$check_acs (acs_name, (user_cdtp -> CDT.author.proc_group_id), ring, mode, code); if (code ^= 0) | ((mode & RW_ACCESS) ^= RW_ACCESS) then do; answer = "access violation"; code = error_table_$action_not_performed; go to RETURN; end; call hcs_$initiate (instaldir, instalname, "", 0, 0, old_cdtp, code); if old_cdtp = null then do; answer = "cannot initiate old CDT"; code = error_table_$action_not_performed; go to RETURN; end; /* Go thru all channel entries in supplied CDT. */ /* p is a cdtep */ do i = 1 to user_cdtp -> CDT.current_size; p = addr (user_cdtp -> cdt.cdt_entry (i)); if verify (p -> CDTE.name, LEGAL) ^= 0 then do; answer = "name not ASCII"; code = error_table_$action_not_performed; go to RETURN; end; /* Make sure that the channel is threaded in */ on sub_error_ begin; call NEW_CDT_DAMAGE; end; if p -> CDTE.in_use > NOW_FREE then do; call cdt_mgr_$find_cdt_channel (user_cdtp, (p -> CDTE.name), cdtx, fnp_sw, code); if code ^= 0 then do; answer = "channel not threaded in. " || p -> CDTE.name; go to RETURN; end; if fnp_sw then do; code = error_table_$action_not_performed; answer = "non-FNP channel with FNP name " || p -> CDTE.name; go to RETURN; end; if cdtx ^= i then do; code = error_table_$action_not_performed; answer = "Multiple or misthreaded channel " || p -> CDTE.name; go to RETURN; end; end; revert sub_error_; if ^valid_aim_range (p -> CDTE.access_class) then do; answer = "access_class range invalid"; code = error_table_$action_not_performed; go to RETURN; end; if p -> CDTE.service_type > MPX_SERVICE then do; answer = "illegal service type for " || p -> CDTE.name; code = error_table_$action_not_performed; go to RETURN; end; if p -> CDTE.charge_type > 16 then do; answer = "illegal charge type for " || p -> CDTE.name; code = error_table_$action_not_performed; go to RETURN; end; if (p -> CDTE.line_type < LINE_TELNET) | (p -> CDTE.line_type > max_line_type) then do; answer = "illegal line type for " || p -> CDTE.name; code = error_table_$action_not_performed; go to RETURN; end; if p -> CDTE.initial_terminal_type ^= "" then do; call ttt_info_$terminal_data (p -> CDTE.initial_terminal_type, (p -> CDTE.line_type), 0, null, code); if code ^= 0 then do; answer = "illegal terminal type for " || p -> CDTE.name; code = error_table_$action_not_performed; return; end; end; end; /* protect active multiplexers from deletion or changes in service type */ on sub_error_ call OLD_CDT_DAMAGE; do i = 1 to hbound (old_cdtp -> CDT.fnp_entry, 1); if old_cdtp -> CDT.fnp_entry (i).daughter ^= 0 then call protect_mpxes (old_cdtp -> CDT.fnp_entry (i).daughter, old_cdtp -> CDT.fnp_entry (i).daughter_count); end; if old_cdtp -> CDT.threads.daughter ^= 0 then call protect_mpxes (old_cdtp -> CDT.threads.daughter, old_cdtp -> CDT.threads.daughter_count); revert sub_error_; /* Individual items in supplied CDT look ok. Now, build a new CDT in a temporary segment, by merging the old one with the supplied one. We copy the old one into the temporary segment and then start making changes to that copy. Although comments speak of examining and making changes to the old one, the code actually references the copy. Since user pointers to CDT entries are kept, we must not change the position of any existing CDT entry. */ call get_temp_segment_ ("up_cdt_", new_cdtp, code); if new_cdtp = null then do; call sys_log_$error_log (2, code, "up_cdt_", "cannot make temp"); go to RETURN; end; movelen = wordno (addr (user_cdtp -> CDT.cdt_entry (1))) /* size of header plus the FNP entries */ + old_cdtp -> CDT.current_size * size (cdte);/* plus the cdt entries */ new_cdtp -> movetable = old_cdtp -> movetable; /* Shlup */ /* NOTHING should reference off of old_cdtp from here to the final */ /* stage of the installation. */ /* copy header of new cdt over old cdt header, except for meters. */ new_cdtp -> CDT.author.lock = ""b; new_cdtp -> CDT.author.proc_group_id = user_cdtp -> CDT.author.proc_group_id; new_cdtp -> CDT.author.table = user_cdtp -> CDT.author.table; new_cdtp -> CDT.author.w_dir = user_cdtp -> CDT.author.w_dir; new_cdtp -> CDT.author.last_install_time = clock (); new_cdtp -> CDT.max_size = user_cdtp -> CDT.max_size; /* current_size gets set below, while adding channel entries */ new_cdtp -> CDT.version = CDT_version; new_cdtp -> CDT.acceptable_fnp_tbf = user_cdtp -> CDT.acceptable_fnp_tbf; new_cdtp -> CDT.spare_channel_count = user_cdtp -> CDT.spare_channel_count; /* copy FNP entries of new CDT into old CDT, except for dynamic stuff */ do i = 1 to hbound (new_cdtp -> CDT.fnp_entry, 1);/* scan the FNP entries */ p = addr (new_cdtp -> CDT.fnp_entry (i)); /* p points to an old FNP entry */ q = addr (user_cdtp -> CDT.fnp_entry (i)); /* q points to a new FNP entry */ if p -> FNPE.state ^= FNP_FREE & q -> FNPE.state ^= FNP_FREE then do; /* both in use */ call copy_fnpe; /* does not disturb threads ! */ p -> FNPE.current_service_type = p -> FNPE.service_type; call merge_subtrees (addr (p -> FNPE.threads), addr (q -> FNPE.threads)); /* p old, q new */ end; else if p -> FNPE.state = FNP_FREE & q -> FNPE.state > FNP_FREE then do; /* adding FNP */ call copy_fnpe; /* not including threads */ call init_mpxe (addr (p -> FNPE.mpxe)); p -> FNPE.state = NOT_CONFIGURED; unspec (p -> FNPE.threads) = ""b; p -> FNPE.threads.next_sister, p -> FNPE.threads.prev_sister = -2; p -> FNPE.threads.mother = 0; p -> FNPE.threads.daughter, p -> FNPE.threads.daughter_count = 0; call add_subtree (addr (q -> FNPE.threads)); /* add them all */ end; else if p -> FNPE.state ^= FNP_FREE & q -> FNPE.state = FNP_FREE then do; /* deleteing FNP */ call delete_subtree (addr (p -> FNPE.threads)); p -> FNPE.service_type = INACTIVE; p -> FNPE.current_service_type = INACTIVE; unspec (p -> FNPE.threads) = ""b; end; end; p, q = null; /* until something else defines them */ call merge_subtrees (addr (new_cdtp -> cdt.threads), addr (user_cdtp -> cdt.threads)); /** All the channels are merged and updated */ /* We are finally ready to update the actual CDT and get the access set */ instalp = old_cdtp; /* return ptr to >sc1>cdt */ call hcs_$delentry_seg (user_cdtp, code); /* delete the new CDT (the one they gave us to install) */ user_cdtp = null; /* here or gone, its not interesting */ wordcount = wordno (addr (user_cdtp -> CDT.cdt_entry (1))) + new_cdtp -> CDT.current_size * size (cdte); movelen = wordcount; old_cdtp -> movetable = new_cdtp -> movetable; /* Copy new CDT over old one fast. */ call release_temp_segment_ ("up_cdt_", new_cdtp, (0)); /* nuf */ new_cdtp = null; call hcs_$set_bc (instaldir, instalname, 36 * wordcount, code); call hcs_$set_safety_sw (instaldir, instalname, "1"b, code); /* old_cdtp is the new, live, cdt in >sc1. Now make one last pass and attach/listen/remove the channels which were reconfigured by the installation of the new CDT. */ do i = 1 to old_cdtp -> CDT.current_size; q = addr (old_cdtp -> CDT.cdt_entry (i)); /* The following tests for special values of CDTE.in_use must remain in the order of decreasing special values, so the tests for >= will work right. The purpose of the >= tests is to let us add a large number to CDTE.in_use, preserving its value and setting a flag on the CDTE at the same time */ if q -> CDTE.in_use = UNDELETE_THIS_CHANNEL then do; /* a configured channel was deleted, then added back */ q -> CDTE.in_use = NOW_HUNG_UP; /* so we can use it immediately */ q -> CDTE.current_service_type = q -> CDTE.service_type; if q -> CDTE.current_service_type = ANS_SERVICE then begin; declare listen bit (1); listen = "0"b; if q -> CDTE.mother < 0 then if old_cdtp -> CDT.fnp_entry (-q -> CDTE.mother).mpxe.state = MPX_UP then listen = "1"b; else ; else if q -> CDTE.mother > 0 then do; mpxep = addr (old_cdtp -> CDT.cdt_entry (q -> CDTE.mother).initial_command); if mpxe.state = MPX_UP then listen = "1"b; end; else listen = "1"b; /* top level in ANS_SERVICE? why not! */ if listen & q -> cdte.state ^= TTY_MASKED then do; call asu_$attach_channel (q, code); call asu_$asu_listen (q, code); end; end; end; else if q -> CDTE.in_use >= DELETE_THIS_CHANNEL then do; q -> CDTE.in_use = q -> CDTE.in_use - DELETE_THIS_CHANNEL; /* put back real in_use value */ if q -> CDTE.current_service_type ^= MPX_SERVICE then call asu_$asu_remove (q); /* so asu_remove will do the right thing */ if q -> CDTE.tra_vec = WAIT_REMOVE /* should not be true for MPX's */ then /* if dialup_ will remove channel after destroying process */ q -> CDTE.tra_vec = WAIT_DELETE_CHANNEL; /* tell dialup_ to mark the cdte deleted, instead */ else do; q -> CDTE.in_use = CHANNEL_DELETED; /* but if no process, mark it deleted now */ q -> CDTE.current_service_type = INACTIVE; /* inactive */ end; end; else if q -> CDTE.in_use = LISTEN_TO_THIS_CHANNEL then do; /* We assume CDTE.dim did not change */ /* (because the old line was never removed) */ line_type = q -> CDTE.line_type; /* Unpack new line type */ call astty_$tty_order (q, "set_line_type", addr (line_type), code); if line_type = LINE_TELNET then do; service_type = q -> CDTE.service_type; /* Unpack service type */ call astty_$tty_order (q, "set_service_type", addr (service_type), code); end; if q -> cdte.state ^= TTY_MASKED then call asu_$asu_listen (q, code); end; else if q -> CDTE.in_use = ATTACH_THIS_CHANNEL then do; if q -> CDTE.state ^= TTY_MASKED then do; call asu_$attach_channel (q, code); call asu_$asu_listen (q, code); end; end; else if q -> CDTE.in_use >= REMOVE_THIS_CHANNEL then do; q -> CDTE.in_use = q -> CDTE.in_use - REMOVE_THIS_CHANNEL; /* restore real value of in_use */ call asu_$asu_remove (q); /* so asu_remove will do the right thing */ end; end; code = 0; RETURN: return; /* Internal procedure to change the service type of a channel */ change_service_type: procedure (p, q); dcl (p, q) pointer; /* p is FROM, q is TO */ /* automatic */ dcl jumpx fixed bin; /* program */ call sys_log_ (0, "up_cdt_: changing service type for channel ^a ^a from ^d^[^x(cur:^d)^;^s^] to ^d", q -> CDTE.name, q -> CDTE.comment, p -> CDTE.service_type, (p -> CDTE.service_type ^= p -> CDTE.current_service_type), p -> CDTE.current_service_type, q -> CDTE.service_type); if p -> CDTE.current_service_type < 1 | p -> CDTE.current_service_type > 8 | q -> CDTE.service_type < 1 | q -> CDTE.service_type > 8 | q -> CDTE.service_type = 5 then do; call sys_log_ (2, "up_cdt_: Service type out of range for ^a", q -> CDTE.name); return; /* we'll take a fault if we try to continue */ end; jumpx = 10 * p -> CDTE.current_service_type + q -> CDTE.service_type; go to change (jumpx); change (11): /* ANS -> ANS */ change (22): /* FTP -> FTP */ change (33): /* MC -> MC */ change (44): /* SLAVE -> SLAVE */ change (66): /* OUT -> OUT */ change (77): /* INACTIVE -> INACTIVE */ change (88): /* MPX -> MPX */ return; change (12): /* ANS -> FTP */ p -> CDTE.in_use = LISTEN_TO_THIS_CHANNEL; return; change (13): /* ANS -> MC */ p -> CDTE.in_use = p -> CDTE.in_use + REMOVE_THIS_CHANNEL; goto tell_user; change (14): /* ANS -> SLAVE */ change (17): /* ANS -> INACTIVE */ change (18): /* ANS -> MPX */ p -> CDTE.in_use = p -> CDTE.in_use + REMOVE_THIS_CHANNEL; goto tell_user; change (16): /* ANS -> OUT */ return; change (21): /* FTP -> ANS */ p -> CDTE.in_use = LISTEN_TO_THIS_CHANNEL; return; change (23): /* FTP -> MC */ change (24): /* FTP -> SLAVE */ change (27): /* FTP -> INACTIVE */ change (28): /* FTP -> MPX */ p -> CDTE.in_use = p -> CDTE.in_use + REMOVE_THIS_CHANNEL; goto tell_user; change (26): /* FTP -> OUT */ p -> CDTE.in_use = LISTEN_TO_THIS_CHANNEL; return; change (31): /* MC -> ANS */ change (32): /* MC -> FTP */ change (34): /* MC -> SLAVE */ change (36): /* MC -> OUT */ change (37): /* MC -> INACTIVE */ change (38): /* MC -> MPX */ /* Don't attach a former MC channel. If MC is still using it, the operator would get upset. Let attach command or next bootload attach it. */ return; change (41): /* SLAVE -> ANS */ change (42): /* SLAVE -> FTP */ p -> CDTE.in_use = ATTACH_THIS_CHANNEL; return; change (43): /* SLAVE -> MC */ change (47): /* SLAVE -> INACTIVE */ change (48): /* SLAVE -> MPX */ return; change (46): /* SLAVE -> OUT */ p -> CDTE.in_use = ATTACH_THIS_CHANNEL; return; change (51): /* DIAL -> ANS */ change (52): /* DIAL -> FTP */ p -> CDTE.in_use = ATTACH_THIS_CHANNEL; return; change (53): /* DIAL -> MC */ change (54): /* DIAL -> SLAVE */ change (56): /* DIAL -> OUT */ change (57): /* DIAL -> INACTIVE */ change (58): /* DIAL -> NPX */ return; change (61): /* OUT -> ANS */ return; change (62): /* OUT -> FTP */ p -> CDTE.in_use = LISTEN_TO_THIS_CHANNEL; return; change (63): /* OUT -> MC */ change (67): /* OUT -> INACTIVE */ change (68): /* OUT -> MPX */ p -> CDTE.in_use = p -> CDTE.in_use + REMOVE_THIS_CHANNEL; goto tell_user; change (64): /* OUT -> SLAVE */ p -> CDTE.in_use = p -> CDTE.in_use + REMOVE_THIS_CHANNEL; goto tell_user; change (71): /* INACTIVE -> ANS */ change (72): /* INACTIVE -> FTP */ change (76): /* INACTIVE -> OUT */ p -> CDTE.in_use = ATTACH_THIS_CHANNEL; return; change (73): /* INACTIVE -> MC */ change (74): /* INACTIVE -> SLAVE */ change (78): /* INACTIVE -> MPX */ return; change (81): /* MPX -> ANS */ change (82): /* MPX -> FTP */ change (83): /* MPX -> MC */ change (84): /* MPX -> SLAVE */ change (85): /* MPX -> DIAL */ change (86): /* MPX -> OUT */ change (87): /* MPX -> INACTIVE */ p -> CDTE.in_use = p -> CDTE.in_use + REMOVE_THIS_CHANNEL; return; tell_user: if p -> CDTE.in_use >= NOW_LOGGED_IN + REMOVE_THIS_CHANNEL then /* if somebody is there, tell them why it's going to hang up */ call asu_$write_chn_message (p, as_error_table_$chn_svc_changed, debg, code); return; end change_service_type; /* Internal proc to copy new FNP entry into old FNP entry */ copy_fnpe: procedure; /* p and q are implicit parameters */ p -> FNPE.type = q -> FNPE.type; p -> FNPE.memory = q -> FNPE.memory; p -> FNPE.service_type = q -> FNPE.service_type; p -> FNPE.mpx_type = q -> FNPE.mpx_type; p -> FNPE.coreimage = q -> FNPE.coreimage; p -> FNPE.nlslas = q -> FNPE.nlslas; p -> FNPE.nhslas = q -> FNPE.nhslas; return; end copy_fnpe; /* Internal procedure to copy NEW cdt entry over OLD cdt entry */ copy_cdte: proc (from_cdtep, to_cdtep); declare (from_cdtep, to_cdtep) pointer; to_cdtep -> CDTE.access_class = from_cdtep -> CDTE.access_class; to_cdtep -> CDTE.comment = from_cdtep -> CDTE.comment; to_cdtep -> CDTE.charge_type = from_cdtep -> CDTE.charge_type; to_cdtep -> CDTE.service_type = from_cdtep -> CDTE.service_type; to_cdtep -> CDTE.current_service_type = from_cdtep -> CDTE.service_type; to_cdtep -> CDTE.line_type = from_cdtep -> CDTE.line_type; to_cdtep -> CDTE.initial_terminal_type = from_cdtep -> CDTE.initial_terminal_type; if ^(from_cdtep -> CDTE.autobaud) then to_cdtep -> CDTE.baud_rate = from_cdtep -> CDTE.baud_rate; to_cdtep -> CDTE.modem_type = from_cdtep -> CDTE.modem_type; to_cdtep -> CDTE.answerback = from_cdtep -> CDTE.answerback; string (to_cdtep -> CDTE.flags) = string (from_cdtep -> CDTE.flags); to_cdtep -> CDTE.mpx_type = from_cdtep -> CDTE.mpx_type; to_cdtep -> CDTE.mpx_service = from_cdtep -> CDTE.mpx_service; if to_cdtep -> CDTE.current_service_type ^= MPX_SERVICE then to_cdtep -> CDTE.initial_command = from_cdtep -> CDTE.initial_command; return; end copy_cdte; merge_subtrees: procedure (old_thread_ptr, new_thread_ptr); declare (old_thread_ptr, new_thread_ptr) pointer; declare 1 old_threads aligned like channel_threads based (old_thread_ptr); declare 1 new_threads aligned like channel_threads based (new_thread_ptr); declare old_x fixed bin; /* current position in old tree (cdtx) */ declare new_x fixed bin; /* current position in new tree (cdtx) */ declare (old_check, new_check) fixed bin; /* chain chase counters */ declare (old_limit, new_limit) fixed bin; /* copied so that thread_in wont disturb */ /**** Note that this merge takes place in place in the "old" cdt. */ /**** This works because thread_in's always happen in the part of */ /**** the tree that has already been visited. */ /**** the following cases happen when channels stop being multiplexers */ /**** or start, for that matter */ if old_threads.daughter_count = 0 | /** **/ new_threads.daughter_count = 0 then do; if old_threads.daughter_count = 0 & new_threads.daughter_count = 0 /* its winter, and the trees are bare */ then return; if old_threads.daughter_count = 0 then call add_subtree (new_thread_ptr); /* easy case */ if new_threads.daughter_count = 0 then call delete_subtree (old_thread_ptr); /* another easy case */ return; end; old_x = old_threads.daughter; if old_x = 0 then call OLD_CDT_DAMAGE; /* dcount ^= ndaughters */ new_x = new_threads.daughter; if new_x = 0 then call NEW_CDT_DAMAGE; /* dcount ^= ndaughters */ old_check, new_check = 0; /* check them off as we use them up */ old_limit = old_threads.daughter_count; new_limit = new_threads.daughter_count; COMPARE_TWO_CHANNELS: /* This is the basic loop. */ begin; declare 1 ocdte aligned like cdte based (addr (new_cdtp -> CDT.cdt_entry (old_x))); declare 1 ncdte aligned like cdte based (addr (user_cdtp -> CDT.cdt_entry (new_x))); /**** The RULES: ****/ /**** ** if the old name is alphaless than the new name, than it is a **/ /**** deleted channel, for if it were in the new tree, we would have **/ /**** seen it already. **/ /**** ** if the old name is equal to the new name, things are peachy. **/ /**** ** if the old name is greater than the new name, then the new name **/ /**** must be added. For if it were not, we would have already seen the **/ /**** equal old name. ******/ if ocdte.name < ncdte.name then DELETE: do; /* Deleted Channel */ call delete_channel (old_x); /* deletes children too. */ old_x = ocdte.threads.next_sister; old_check = old_check + 1; if old_check > old_limit then call OLD_CDT_DAMAGE; if old_x = 0 /* run out, rest must be added */ then NO_MORE_OLD: begin; /* construct dummy thread block */ declare 1 t aligned like channel_threads; unspec (t) = ""b; t.daughter_count = new_threads.daughter_count - new_check; t.daughter = new_x; /* start by adding this. */ t.mother = new_threads.mother; t.next_sister, t.prev_sister = 0; /* lie */ call add_subtree (addr (t)); /* adds children too */ return; /* merge complete at this level */ end NO_MORE_OLD; go to COMPARE_TWO_CHANNELS; end DELETE; else if ocdte.name = ncdte.name then MERGE: do; /* Ha HA! */ call update_channel (old_x, new_x);/* change data */ old_check = old_check + 1; /* use up channels */ if old_check > old_limit then call OLD_CDT_DAMAGE; new_check = new_check + 1; if new_check > new_limit then call NEW_CDT_DAMAGE; if ocdte.threads.daughter ^= 0 & ncdte.threads.daughter ^= 0 then call merge_subtrees (addr (ocdte.threads), addr (ncdte.threads)); else if ocdte.threads.daughter ^= 0 then call delete_subtree (addr (ocdte.threads)); else call add_subtree (addr (ncdte.threads)); /* RECURSE */ if ocdte.next_sister = 0 /** No more there */ & ncdte.next_sister = 0 /** chains at end */ then return; old_x = ocdte.threads.next_sister; /** chase both chains **/ new_x = ncdte.threads.next_sister; /** before trying to add remainder **/ if old_x = 0 /** to avoid adding this new_x twice */ then go to NO_MORE_OLD; if new_x = 0 then NO_MORE_NEW: begin; /* the rest of the old chain goes away */ declare 1 t aligned like channel_threads; unspec (t) = ""b; t.daughter_count = old_threads.daughter_count - old_check; t.mother = old_threads.mother; t.next_sister, t.prev_sister = 0; t.daughter = old_x; call delete_subtree (addr (t)); return; /* End of merge at this level */ end; go to COMPARE_TWO_CHANNELS; end MERGE; else ADD: do; /* old > new, new is added ! */ call add_channel (new_x); /* allocates cdte, fills in, threads in, and recurses over children */ new_check = new_check + 1; if new_check > new_limit then call NEW_CDT_DAMAGE; new_x = ncdte.threads.next_sister; if new_x = 0 then go to NO_MORE_NEW; go to COMPARE_TWO_CHANNELS; end ADD; end COMPARE_TWO_CHANNELS; /* never get here */ end merge_subtrees; add_subtree: procedure (thread_ptr); /* simplified version that just adds */ declare thread_ptr pointer; declare 1 threads aligned like channel_threads based (thread_ptr); declare x fixed bin; declare check fixed bin; declare original_daughter_count fixed bin; check = 0; if threads.daughter_count = 0 then return; do x = threads.daughter repeat (user_cdtp -> CDT.cdt_entry (x).threads.next_sister) while (x ^= 0); check = check + 1; if check > threads.daughter_count then call NEW_CDT_DAMAGE; call add_channel (x); /* easy enough */ end; return; delete_subtree: entry (thread_ptr); check = 0; if threads.daughter_count = 0 then return; original_daughter_count = threads.daughter_count; do x = threads.daughter repeat (new_cdtp -> CDT.cdt_entry (x).threads.next_sister) while (x ^= 0); check = check + 1; if check > original_daughter_count then call OLD_CDT_DAMAGE; call delete_channel$$no_protect (x); end; end add_subtree; %page; /**** Okay, now all we need are procedures to handle the cases */ update_channel: procedure (oldx, newx); /*** Take care of channels in both cdts, that may have stuff to do to them */ /*** Note that we merge from new into old. */ declare (oldx, newx) fixed bin; declare 1 ocdte aligned like cdte based (addr (new_cdtp -> CDT.cdt_entry (oldx))); declare 1 ncdte aligned like cdte based (addr (user_cdtp -> CDT.cdt_entry (newx))); if ocdte.in_use = CHANNEL_DELETED then do; /* old channel is marked deleted */ ocdte.in_use = UNDELETE_THIS_CHANNEL; /* we are un-deleting it */ call sys_log_ (0, "up_cdt_: Adding previously-deleted channel ^a ^a", ocdte.name, ocdte.comment); end; /* For channels that are configured and might be in use, changing the service type or line type requires some action (like doing a bump, a hangup, or a listen), in addition to changing the service_type or line_type variables */ if ocdte.in_use ^= NOT_CONFIGURED & ocdte.in_use ^= UNDELETE_THIS_CHANNEL then do; /* only for real channels */ /**** Check for change in service type */ if ocdte.service_type ^= ncdte.service_type then call change_service_type (addr (ocdte), addr (ncdte)); /* Check for change in line type */ if ocdte.line_type ^= ncdte.line_type then do; if ((ncdte.service_type = ANS_SERVICE) /** if giving to AS */ | (ncdte.service_type = FTP_SERVICE)) /** **/ & ((ocdte.current_service_type = ANS_SERVICE) /** & now held by AS */ | (ocdte.current_service_type = FTP_SERVICE)) & ocdte.in_use <= NOW_LISTENING /* noone connected */ then do; /* use old CDTE to get old CDTE.dim, etc */ /* stop listening so can reset old line type later */ call astty_$tty_order (addr (ocdte), "hangup", null, code); ocdte.in_use = LISTEN_TO_THIS_CHANNEL; end; end; end; /* Check for change in access class */ if ^equal_aim_ranges (ocdte.access_class (*), ncdte.access_class (*)) then do; old_auth_string = display_access_class_$range (ocdte.access_class (*)); auth_string = display_access_class_$range (ncdte.access_class (*)); utep = null (); /* start assuming noone */ call sys_log_ (0, "up_cdt_: changing access class of channel ^a from ^a to ^a", ocdte.name, old_auth_string, auth_string); if ((ocdte.current_service_type = ANS_SERVICE) /** **/ | (ocdte.current_service_type = FTP_SERVICE)) then do; if unspec (ocdte.process) ^= ""b /* is this possibly a valid process? */ then utep = ocdte.process; /* Get ptr to process now using. */ if utep ^= null then /* .. if any */ if ute.active >= NOW_LOGGED_IN & ^aim_check_$in_range (ute.process_authorization, ncdte.access_class) & ute.preempted = 0 then do; old_auth_string = display_access_class_$range (ncdte.access_class); auth_string = display_access_class_ (ute.process_authorization); call sys_log_ (1, "up_cdt_: bumping ^a.^a, channel ^a access class ^a no longer includes user authorization ^a.", ute.person, ute.project, ocdte.name, old_auth_string, auth_string); call asu_$bump_code (utep, as_error_table_$chn_auth_excludes, debg, code, (0) /* NO GRACE ! */); end; end; end; /* Copy other stuff from new CDTE into merged one */ call copy_cdte (addr (ncdte), addr (ocdte)); end update_channel; delete_channel: procedure (cdtx); declare cdtx fixed bin; declare no_protect bit (1) aligned; no_protect = "0"b; /* Protect by using DELETE_THIS_CHANNEL */ go to Join; delete_channel$$no_protect: entry (cdtx); no_protect = "1"b; /* Deleting parent mpx, definitively flush this */ Join: declare 1 dcdte aligned like cdte based (addr (new_cdtp -> CDT.cdt_entry (cdtx))); call sys_log_ (0, "up_cdt_: Deleting channel ^a ^a", dcdte.name, dcdte.comment); if dcdte.threads.daughter_count > 0 then call delete_subtree (addr (dcdte.threads)); /* get rid of kiddies */ /* since we wont decend further */ /* note that _subtree calls no_protect */ /***** Ignoring in_use for no_protect is allowed because */ /***** an inactive multiplexer cannot have active subchannels */ if dcdte.in_use = NOT_CONFIGURED | no_protect then /* if channel was never "live" */ do; dcdte.in_use = NOW_FREE; on sub_error_ call OLD_CDT_DAMAGE; call cdt_mgr_$thread_out_cdt_channel (new_cdtp, cdtx); /* free the CDTE immediately */ end; else do; /* otherwise take channel out of service in several steps */ /* no matter what the channel's service type is, */ if dcdte.in_use >= NOW_DIALED /* if somebody there, tell them what's happening */ then call asu_$write_chn_message (addr (dcdte), as_error_table_$chn_deleted, debg, code); dcdte.in_use = dcdte.in_use + DELETE_THIS_CHANNEL; /* set reminder to delete it later */ end; end delete_channel; add_channel: procedure (cdtx); declare cdtx fixed bin; declare 1 acdte aligned like cdte based (addr (user_cdtp -> CDT.cdt_entry (cdtx))); declare nx fixed bin; do nx = 1 to new_cdtp -> CDT.current_size /* find a free entry */ while (new_cdtp -> CDT.cdt_entry (nx).in_use ^= NOW_FREE); end; if nx = new_cdtp -> CDT.current_size + 1 then /* if no free ones within the old CDT */ do; if nx > hbound (new_cdtp -> CDT.cdt_entry, 1) then do; answer = "Too many channels defined."; code = error_table_$action_not_performed; go to RETURN; end; new_cdtp -> CDT.current_size = nx; /* add a new entry to the end * */ end; begin; declare 1 ncdte aligned like cdte based (addr (new_cdtp -> cdt.cdt_entry (nx))); ncdte.in_use = NOT_CONFIGURED; /* new chn */ ncdte.name = acdte.name; call copy_cdte (addr (acdte), addr (ncdte)); /* FROM, TO */ if ncdte.line_type = LINE_TELNET then ncdte.in_use = ATTACH_THIS_CHANNEL; ncdte.event = 0; ncdte.tra_vec = 0; ncdte.count = 0; ncdte.twx = 0; ncdte.state = 0; ncdte.current_terminal_type = ""; ncdte.tty_id_code = ""; ncdte.process = null; ncdte.dialed_to_procid = ""b; ncdte.next_channel = 0; ncdte.n_dialups = 0; /* Reset meters. */ ncdte.n_logins = 0; ncdte.dialed_up_time = 0; ncdte.dialup_time = 0; if ncdte.service_type = MPX_SERVICE then call init_mpxe (addr (ncdte.initial_command)); on sub_error_ call NEW_CDT_DAMAGE; call cdt_mgr_$thread_in_cdt_channel (new_cdtp, nx); auth_string = display_access_class_$range (ncdte.access_class); call sys_log_ (0, "up_cdt_: Adding channel ^a ^a ^a", ncdte.name, ncdte.comment, auth_string); call add_subtree (addr (acdte.threads)); end; end add_channel; init_mpxe: procedure (nmpxep); declare nmpxep pointer; nmpxep -> mpxe.current_service_type = INACTIVE; /* The first load has to be explicit */ nmpxep -> mpxe.n_bootloads = 0; nmpxep -> mpxe.time_initial_load = 0; nmpxep -> mpxe.time_last_load = 0; nmpxep -> mpxe.time_last_crash = 0; nmpxep -> mpxe.time_load_start = 0; nmpxep -> mpxe.last_tbf = 0; return; end init_mpxe; protect_mpxes: procedure (muxx, d_limit); /* This is recursive ... */ declare muxx fixed bin unal; /* always cdtx, never fnpx */ declare d_limit fixed bin unal; declare check fixed bin; declare newx fixed bin; declare x fixed bin; /* we visit each MUX in the old cdt (old_cdtp) */ check = 0; do x = muxx repeat (old_cdtp -> CDT.cdt_entry (x).threads.next_sister) while (x ^= 0); p = addr (old_cdtp -> CDT.cdt_entry (x)); check = check + 1; if check > d_limit | check > old_cdtp -> cdt.n_cdtes then call OLD_CDT_DAMAGE; if p -> CDTE.current_service_type = MPX_SERVICE then do; mpxep = addr (p -> CDTE.initial_command); if (mpxe.state ^= FNP_DOWN) & (mpxe.state ^= FNP_UNKNOWN) then do; /* found an active one */ call cdt_mgr_$find_cdt_channel (user_cdtp, (p -> cdte.name), newx, ("0"b), code); if code = 0 then do; q = addr (user_cdtp -> CDT.cdt_entry (newx)); if q -> CDTE.service_type ^= MPX_SERVICE then do; answer = "Cant change service type for active mpx " || p -> CDTE.name; code = error_table_$action_not_performed; go to RETURN; end; end; else do; answer = "cant delete active mpx " || p -> CDTE.name; code = error_table_$action_not_performed; go to RETURN; end; end; end; /* interesting state */ if p -> CDTE.threads.daughter_count > 0 then call protect_mpxes (p -> CDTE.threads.daughter, p -> CDTE.threads.daughter_count); end; /* the doloop */ end protect_mpxes; OLD_CDT_DAMAGE: procedure; go to OLD_CDT_DAMAGE_LABEL; /* place to hang breakpoint in debugging */ end OLD_CDT_DAMAGE; OLD_CDT_DAMAGE_LABEL: /* the copy of the current CDT is sick. Retry */ if retry_count = 0 then do; call sys_log_ (1, "up_cdt_: CDT thread damage in live CDT. Rethreading."); on sub_error_ begin; call find_condition_info_ (null, addr (auto_condition_info), (0)); sub_error_info_ptr = auto_condition_info.info_ptr; call sys_log_$error_log (1, code, "up_cdt_", "cdt_mgr_$thread: ^a.", sub_error_info.info_string); /***** Return, cdt_mgr_ will do what recovery it can. */ end; call cdt_mgr_$thread (old_cdtp, code); if code ^= 0 then go to GIVE_UP; call sys_log_ (1, "up_cdt_: Rethreading complete."); retry_count = 1; call cleanup; go to RETRY_INSTALLATION; GIVE_UP: call sys_log_ (1, "up_cdt_: Repeated CDT threading errors. Installation aborted."); call cleanup; code = error_table_$action_not_performed; answer = "live CDT threading errors, shutdown and reboot to correct"; go to RETURN; end; NEW_CDT_DAMAGE: procedure; answer = "CDT threading error(s) in supplied CDT"; code = error_table_$action_not_performed; go to RETURN; end; valid_aim_range: procedure (range) returns (bit (1) aligned) reducible; declare range (2) bit (72) aligned; if ^aim_check_$greater_or_equal (range (2), range (1)) /* valid range ? */ then return ("0"b); if ^aim_check_$greater_or_equal (system_high, range (2)) /* valid for the system ? */ then return ("0"b); else return ("1"b); end valid_aim_range; equal_aim_ranges: procedure (r1, r2) returns (bit (1) aligned); /* the every bif would fix this */ declare (r1, r2) (2) bit (72) aligned; return (aim_check_$equal (r1 (1), r2 (1)) & aim_check_$equal (r1 (2), r2 (2))); end equal_aim_ranges; cleanup: procedure; if new_cdtp ^= null then call release_temp_segment_ ("up_cdt_", new_cdtp, (0)); if old_cdtp ^= null then call hcs_$terminate_noname (old_cdtp, (0)); end cleanup; %page; %include access_mode_values; %page; %include author_dcl; %page; %include cdt; %page; %include condition_info; declare 1 auto_condition_info aligned like condition_info; %include condition_info_header; %page; %include dialup_values; %page; %include installation_parms; %page; %include line_types; %page; %include sub_error_info; %page; %include user_attributes; %page; %include user_table_entry; end up_cdt_;  up_mgt_.pl1 07/13/88 1141.1r w 07/13/88 0943.1 164988 /****^ *********************************************************** * * * 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 */ up_mgt_: procedure (mgtp, wordcount, instaldir, instalname, instalp, P_ansp, ip, answer, code); /* up_mgt_ - update master_group_table Initially coded by T. Casey, June 1975 Modified by T. Casey, October 1976 for version 3 MGT. Modified by T. Casey, Sept 1977 to allow deletion of group if no processes or projects in it. Modified by T. Casey, November 1978, to add group parameters: absentee_(max min pct). Modified by J. Bongiovanni, July 1981, for governed work classes. Modified November 1981, E. N. Kittlitz. user_table_entry conversion. Modified January 1982, BIM, for author changes (lock and install time). Modified February 1982, E. N. Kittlitz. xxx.install.acs change. Modified: 10/05/84 by R. Michael Tague: up_sysctl_$check_acs now returns a bit (36) mode string instead of a fixed bin (5) and no longer takes a directoy arg. */ /****^ HISTORY COMMENTS: 1) change(86-06-05,GJohnson), approve(86-06-05,MCR7387), audit(86-06-10,Martinson), install(86-07-11,MR12.0-1092): Correct error message documentation. 2) change(87-04-26,GDixon), approve(87-07-13,MCR7741), audit(87-07-16,Hartogs), install(87-08-04,MR12.1-1055): Upgraded for change to answer_table.incl.pl1. END HISTORY COMMENTS */ /* DECLARATION OF PARAMETERS */ dcl (mgtp, instalp, P_ansp, ip) pointer; dcl wordcount fixed bin; dcl code fixed bin (35); dcl (instaldir char (*), instalname char (*), answer char (*)); /* DECLARATION OF EXTERNAL SYMBOLS */ dcl up_sysctl_$check_acs entry (char (*), char (*), fixed bin, bit (36) aligned, fixed bin (35)); dcl get_process_id_ entry () returns (bit (36)); dcl hcs_$set_safety_sw entry (char (*), char (*), bit (1), fixed bin (35)); dcl hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35)); dcl cu_$level_get entry (fixed bin); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl sys_log_$error_log entry options (variable); dcl reassign_work_classes_ entry (fixed bin (35)); dcl ioa_$rsnnl entry options (variable); dcl error_table_$action_not_performed ext fixed bin (35); dcl (addr, clock, fixed, null, rel, string) builtin; /* DECLARATION OF INTERNAL STATIC VARIABLES */ dcl acs_name char (32) int static options (constant) init ("mgt.install.acs"); /* dcl LEGAL char (95) int static init /* Printables except PAD, semicolon, but with BS */ /* (" !""#$%&'()*+,-./0123456789:<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~");/* */ /* DECLARATION OF AUTOMATIC STORAGE VARIABLES */ dcl (i, j, rslen, bad_wc) fixed bin; /* counters */ dcl first_group fixed bin; dcl omgtp ptr; /* ptr to current mgt */ dcl omgtep ptr; /* ptr to entries in current mgt */ dcl (satp, satep) ptr; /* satep not used - but referenced in sat.incl */ dcl notables bit (1); /* switch to indicate that an old table doesn't exist */ dcl no_words fixed bin (24); dcl offset bit (18) aligned; /* for wordcount. */ dcl syacn fixed bin init (1); dcl ring fixed bin; dcl mode bit (36) aligned; dcl pct_is_used bit (1) aligned; dcl shift fixed bin; dcl shift_used (0:7) bit (1) aligned; dcl shift_pct fixed bin; dcl wcp ptr; dcl no_abs bit (1) aligned; dcl dflt_q (4) bit (1) unaligned; dcl char8 char (8) varying; dcl digits (4) char (1) unaligned int static init ("1", "2", "3", "4"); dcl rq_problem bit (3) unaligned; dcl resp bit (1) unaligned defined (rq_problem) pos (1); dcl int bit (1) unaligned defined (rq_problem) pos (2); /* DECLARATION OF BASED STRUCTURES */ dcl 1 dum aligned based, 2 array (no_words) fixed bin; %page; ansp = P_ansp; if anstbl.as_procid ^= get_process_id_ () then return; instalp = null; /* pre-set returned pointer */ instaldir = anstbl.sysdir; /* Make name of place to put copy. */ instalname = "mgt"; /* Make segment name. */ call hcs_$initiate (instaldir, instalname, "", 0, 0, omgtp, code); if omgtp = null then notables = "1"b; /* no old MGT. How about that? */ else notables = "0"b; if wordcount < 64 then do; /* make sure segment contains something */ answer = "wordcount < 64"; goto mgt_error; end; if mgt.version_indicator ^= "VERSION " then goto badversn; if mgt.version ^= MGT_version_3 then do; badversn: answer = "incorrect table format"; goto mgt_error; end; if mgt.current_size > mgt.max_size then do; answer = "current_size > max_size"; goto mgt_error; end; offset = rel (addr (mgt.entry (mgt.current_size + 1))); if fixed (offset, 18) - 1 > wordcount then do; /* Check size vs file system. */ answer = "size inconsistent with wordcount"; goto mgt_error; end; call cu_$level_get (ring); call up_sysctl_$check_acs (acs_name, (mgt.author.proc_group_id), ring, mode, code); if (code ^= 0) | ((mode & RW_ACCESS) ^= RW_ACCESS) then do; answer = "access violation"; goto mgt_error; end; call hcs_$initiate (instaldir, "sat", "", 0, 1, satp, code); if satp = null then do; answer = "cannot initiate SAT"; goto mgt_error; end; /* Now, verify the correctness of the new MGT */ do shift = 0 to 7; /* check consistency on each shift */ shift_used (shift) = ""b; /* remember which shifts are used */ shift_pct = 0; /* sum of percentages */ no_abs = ""b; string (dflt_q) = ""b; /* keep track of absentee groups */ do i = 1 to 16; /* first go thru work classes */ /* checking if defined, and adding up percentages */ wcp = addr (mgt.entry (i)); if wcp -> work_class.switches.defined (shift) then do; /* if defined */ shift_used (shift) = "1"b; /* at least one is, on this shift */ if mgt.switches.deadline_mode (shift) | wcp -> work_class.switches.realtime (shift) then /* if realtime or deadline */ pct_is_used = ""b; /* percent is ignored */ else pct_is_used = "1"b; /* otherwise it is used */ if pct_is_used & wcp -> work_class.min_pct (shift) <= 0 then do; call ioa_$rsnnl ("zero or negative work class percentage: work class ^d, shift ^d", answer, rslen, i, shift); goto mgt_error; end; if pct_is_used & (wcp -> work_class.max_pct (shift) < 0 | wcp -> work_class.max_pct (shift) > 100) then do; call ioa_$rsnnl ("invalid work class max percent: work class ^d, shift ^d", answer, rslen, i, shift); goto mgt_error; end; if pct_is_used then /* except for realtime workclasses */ shift_pct = shift_pct + wcp -> work_class.min_pct (shift); /* add up percentages */ /* RESPONSE AND QUANTUM CHECKS: * work_class.int_quantum(shift) and work_class.quantum(shift) must be > 0; * work_class.int_response(shift) and work_class.response(shift) must be >= 0 * but ONLY if work_class.switches.realtime(shift) = "1"b; */ rq_problem = "000"b; /* no problem */ if wcp -> work_class.int_quantum (shift) <= 0 then rq_problem = "011"b; /* resp=0;int=1 */ else if wcp -> work_class.quantum (shift) <= 0 then rq_problem = "001"b; /* resp=0;int=0 */ else if wcp -> work_class.switches.realtime (shift) then if wcp -> work_class.int_response (shift) < 0 then rq_problem = "111"b; /* resp=1;int=1 */ else if wcp -> work_class.response (shift) < 0 then rq_problem = "101"b; /* resp=1;int=0 */ if rq_problem ^= "000"b then do; /* if one of the above problems was found */ call ioa_$rsnnl ("^[^;zero or ^]negative ^[int_^]^[response^;quantum^] for ^[realtime ^]work class ^d, shift ^d", answer, rslen, resp, int, resp, resp, i, shift); goto mgt_error; end; end; end; /* end loop on work classes */ if shift_pct > 100 then do; call ioa_$rsnnl ("sum of work class percentages > 100 on shift ^d", answer, rslen, shift); goto mgt_error; end; do i = 17 to mgt.current_size; /* now go thru all groups */ mgtep = addr (mgt.entry (i)); if ^shift_used (shift) then do; /* if no work classes defined on this shift */ if group.int_wc (shift) ^= 0 then do; bad_wc = group.int_wc (shift); goto shift_err; /* there better be no work classes used */ end; if group.abs_wc (shift) ^= 0 then do; bad_wc = group.abs_wc (shift); shift_err: call ioa_$rsnnl ("work class ^d used on shift ^d (for which it is undefined)", answer, rslen, bad_wc, shift); goto mgt_error; end; end; else do; /* some work classes are defined */ wcp = addr (mgt.entry (group.int_wc (shift))); if ^wcp -> work_class.switches.defined (shift) then do; /* see if this one is */ bad_wc = group.int_wc (shift); goto shift_err; /* and complain if not */ end; if group.absentee.allowed then do; /* if absentees allowed in this group */ wcp = addr (mgt.entry (group.abs_wc (shift))); if ^wcp -> work_class.switches.defined (shift) then do; /* make sure their work class is defined */ bad_wc = group.abs_wc (shift); goto shift_err; /* and complain if not */ end; if ^wcp -> work_class.switches.absentee_allowed (shift) then do; call ioa_$rsnnl ("absentees are in work class ^d, which does not allow them", answer, rslen, group.abs_wc (shift)); goto mgt_error; end; if group.absentee.default_group then do; /* if this is a default group for some queue(s) */ do j = 1 to 4; /* go thru queues */ if group.absentee.default_queue (j) then /* if it is for this queue */ if dflt_q (j) then do; /* but there already is one */ call ioa_$rsnnl ("more than one default group for absentee queue ^d; second is ""^a""", answer, rslen, j, group.group_id); goto mgt_error; end; else dflt_q (j) = "1"b; /* otherwise, just remember that we have a default for this queue */ end; end; end; /* end absentee allowed */ else do; /* absentee not allowed in this group */ no_abs = "1"b; /* remember that there is such a group */ if group.absentee.default_group then do; call ioa_$rsnnl ("inconsistency: default absentee group ""^a"" does not permit absentees", answer, rslen, group.group_id); goto mgt_error; end; end; /* end absentees not allowed */ end; /* end some work classes defined on this shift */ end; /* end loop thru all groups */ if no_abs then /* if a no-absentee group exists */ if string (dflt_q) ^= "1111"b then do; /* and there are not default groups for all queues */ char8 = ""; do j = 1 to 4; /* build string listing queues for which */ if ^dflt_q (j) then /* there is no default group */ char8 = char8 || digits (j) || " "; end; call ioa_$rsnnl ("no default group for absentee queue(s) ^a", answer, rslen, char8); goto mgt_error; end; end; /* end loop on shifts */ do i = 17 to mgt.current_size; /* check on per-group parameters */ mgtep = addr (mgt.entry (i)); if group.absentee_pct < 0 | group.absentee_pct > 100 then do; call ioa_$rsnnl ("illegal absentee_pct (^d%) for group ""^a""", answer, rslen, group.absentee_pct, group.group_id); goto mgt_error; end; if group.absentee_min > group.absentee_max then do; call ioa_$rsnnl ("absentee_min (^d) greater than absentee_max (^d) for group ""^a""", answer, rslen, group.absentee_min, group.absentee_max, group.group_id); goto mgt_error; end; if group.absentee_max < 0 then do; call ioa_$rsnnl ("absentee_max (^d) for group ""^a"" is negative", answer, rslen, group.absentee_max, group.group_id); goto mgt_error; end; end; /* end check of per-group parameters */ /* shift_used(*) tells us which shifts were used. later, add code to check this against which shifts are defined in installation parms - but got to write an up_ip_ first ... */ /* If we fall thru here, the mgt was probably ok */ /* If there was an old MGT, copy the current load figures into the new one */ if ^notables then do; first_group = 1; /* old mgt might be version 1 format */ if omgtp -> mgt.version_indicator = "VERSION " then if omgtp -> mgt.version >= 2 then first_group = 17; /* it is version 2 or greater */ mgt.total_units = omgtp -> mgt.total_units; /* in either case, copy current total_units from header */ if first_group = 17 then do; /* if version 2, also copy current work class information */ mgt.switches.prio_sked_on_tape = omgtp -> mgt.switches.prio_sked_on_tape; mgt.user_wc_defined (*) = omgtp -> mgt.user_wc_defined (*); mgt.user_wc_min_pct (*) = omgtp -> mgt.user_wc_min_pct (*); end; do i = first_group to omgtp -> mgt.current_size; /* now, copy the figures for each load control group */ omgtep = addr (omgtp -> mgt.entry (i)); do j = 17 to mgt.current_size /* look up this group in the new mgt */ while (omgtep -> group.group_id ^= addr (mgt.entry (j)) -> group.group_id); end; mgtep = addr (mgt.entry (j)); /* remember address of entry in case we need it */ if j = mgt.current_size + 1 then do; /* was this group deleted? */ /* If we get here, this group got deleted from the new mgt. We can only allow this if the group is not used. See if it is */ j = omgtep -> group.n_prim + omgtep -> group.n_sec + omgtep -> group.n_eo; if j ^= 0 then do; call ioa_$rsnnl ("attempt to delete load control group ""^a"", which has ^d users in it", answer, rslen, group.group_id, j); goto mgt_error; end; /* See if the SAT references it */ do j = 1 to sat.current_size; satep = addr (sat.project (j)); if project.state = 1 then do; /* if this project entry is used */ if project.group = omgtep -> group.group_id then do; call ioa_$rsnnl ("attempt to delete load control group ""^a"", which is the default group for project ""^a""", answer, rslen, group.group_id, project.project_id); goto mgt_error; end; if project.groups (1) = omgtep -> group.group_id | project.groups (2) = omgtep -> group.group_id then do; call ioa_$rsnnl ("attempt to delete load control group ""^a"", which is an authorized group for project ""^a""", answer, rslen, group.group_id, project.project_id); goto mgt_error; end; end; /* end project state = 1 */ end; /* end loop thru SAT */ end; /* if we get here, it is ok to delete the group */ /* naturally, we skip the copying of the old group into the new MGT */ else do; /* if group not deleted, copy its current load values */ if group.max_prim ^= -1 then /* if not a special value being installed */ group.max_prim = omgtep -> group.max_prim; /* save the computed one in the current mgt */ group.n_prim = omgtep -> group.n_prim; group.n_sec = omgtep -> group.n_sec; group.n_eo = omgtep -> group.n_eo; group.absolute_max = omgtep -> group.absolute_max; group.absentee_limit = omgtep -> group.absentee_limit; group.n_abs = omgtep -> group.n_abs; end; end; end; /* If no old mgt, just create a segment to hold the new one */ else do; call hcs_$make_seg (instaldir, instalname, "", 01010b, omgtp, code); if code ^= 0 then do; answer = "unable to create new MGT"; goto mgt_error; end; end; /* if there was an old MGT, we leave its acl unchanged */ /* now, copy the new mgt, with the current load figures in it, over the old one */ no_words = wordcount; /* length of move, in words */ omgtp -> dum = mgtp -> dum; omgtp -> mgt.author.last_install_time = clock (); omgtp -> mgt.author.lock = ""b; /* and set the bitcount to the (possibly new) value */ call hcs_$set_bc (instaldir, instalname, 36 * wordcount, code); call hcs_$set_safety_sw (instaldir, instalname, "1"b, code); /* Now, go reassign everyone to their new work classes */ call reassign_work_classes_ (code); if code ^= 0 then do; /* We will try this twice, in case another privileged process is trying to alter the work class definitions at the same time that we are. Doing it twice is not foolproof, but it decreases the probability of ultimate failure by orders of magnitude */ call reassign_work_classes_ (code); if code ^= 0 then do; call sys_log_$error_log (2, code, "up_mgt_", "during work class reassignment"); return; end; end; code = 0; instalp = omgtp; /* return pointer to merged mgt */ return; mgt_error: code = error_table_$action_not_performed; /* MGT not installed */ return; %page; %include access_mode_values; %page; %include answer_table; %page; %include mgt; %page; %include sat; %page; %include user_attributes; %page; %include user_table_header; %page; /* BEGIN MESSAGE DOCUMENTATION Message: up_mgt_: ERROR_MESSAGE During work class reassignment S: as (severity2) T: $run M: The error described by ERROR_MESSAGE occurred while a system administrator was attempting to install a new mgt. The operation was tried twice and failed both times. More detailed reasons for the failure are given in messages immediately preceding this one. The new mgt has been installed. Hardcore is operating with a set of parameters inconsistent with the new mgt. A: $notify_sa END MESSAGE DOCUMENTATION */ end up_mgt_;  up_pdt_.pl1 10/10/88 1512.9rew 10/07/88 1232.8 262530 /****^ *********************************************************** * * * 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 */ up_pdt_: procedure (segp, wordcount, instaldir, instalname, instalp, P_ansp, ip, answer, code); /* UP_PDT_ - update project definition table. A major rewrite of this module was done in March 1792, to provide for the management of usage figures per user in the PDT entry. This requires that the position of a PDT entry not change while the system is running, since there are pointers in the answer table to a user's usage figures, for use by act_ctl_. Initially coded by Michael J. Spier, February 13, 1970 Modified by J. Phillppps 6/72 to give project administrators read access to their PDT. Modified 741204 by PG for AIM stuff. Modified May 1976 by T. Casey to update cutoff warning thresholds. Modified May 1978 by T. Casey to update pdir_quota, and issue warning msg for grace, pdir quota, or rings > project max. Modified June 1978 by T. Casey to build hash table for pdt. Modified November 1978 by T. Casey for MR7.0 absentee control parameters. Modified July 1979 by C. Hornig to adjust user cutoff BEFORE installing new cutoff. Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures. (UNCA) Modified by R. McDonald May 1980 to include page charges. (UNCA) Modified by E. N. Kittlitz June 1981 for UNCA rate structures, page charges, bug fixes. Modified November 1981, E. N. Kittlitz. user_table_entry conversion. Modified December 1981, E. N. Kittlitz. add user_warn controls. Modified January 1982, BIM for author changes (lock and install_time) Modified February 1982, E. N. Kittlitz. part of the xxx.install.acs changes. Modified September 1982, E. N. Kittlitz. ACL changes. default_ring. Modified June 1983, E.N. Kittlitz. fix bumping of deleted users. Modified 1984-08-27 BIM for user login ranges. */ /****^ HISTORY COMMENTS: 1) change(86-06-05,GJohnson), approve(86-06-05,MCR7387), audit(86-06-10,Martinson), install(86-07-11,MR12.0-1092): Correct error message documentation. 2) change(86-09-26,GDixon), approve(86-09-26,MCR7499), audit(86-10-08,Beattie), install(86-10-13,MR12.0-1183): Initialize htp pointer to null to avoid reference through unset variable (phx20042). 3) change(87-04-26,GDixon), approve(87-07-13,MCR7741), audit(87-07-16,Hartogs), install(87-08-04,MR12.1-1055): Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1 4) change(88-09-14,Parisek), approve(88-09-28,MCR7996), audit(88-10-05,Hunter), install(88-10-07,MR12.2-1140): Truncate the revised pdt to its current length which might have changed. END HISTORY COMMENTS */ /* parameters */ dcl code fixed bin (35); dcl (segp, instalp, P_ansp, ip) ptr, wordcount fixed bin; dcl instaldir char (*), instalname char (*), answer char (*); /* DECLARATION OF EXTERNAL SYMBOLS */ dcl adjust_cutoff_ entry (ptr, fixed bin (71)); dcl aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl aim_check_$in_range entry (bit (72) aligned, (2) bit (72) aligned) returns (bit (1) aligned); dcl get_group_id_ entry () returns (char (32) aligned); dcl get_process_id_ entry () returns (bit (36) aligned); dcl (sys_log_, sys_log_$error_log) entry options (variable); dcl hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); dcl hcs_$set_safety_sw entry (char (*), char (*), bit (1) aligned, fixed bin (35)); dcl hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl create_homedir_ entry (character (*), character (*), bit (72) aligned, character (*), character (*), character (*), fixed binary (35)); dcl asu_$bump_code entry (ptr, fixed bin (35), char (8), fixed bin (35), fixed bin); dcl ioa_$rsnnl entry options (variable); dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); dcl hash_$in entry (ptr, char (*) aligned, fixed bin, fixed bin (35)); dcl hash_$make entry (ptr, fixed bin, fixed bin (35)); dcl match_star_name_ entry (char (*), char (*), fixed bin (35)); /* based */ dcl 1 movetable based aligned, 2 moveary (movelen) fixed bin (35); /* builtins */ dcl (addr, clock, fixed, float, index, max, min, null, rel, rtrim, string, substr, verify) builtin; /* external static */ dcl (as_error_table_$user_deleted, as_error_table_$user_auth_excludes) fixed bin (35) external static; /* DECLARATION OF INTERNAL STATIC VARIABLES */ dcl LEGAL char (95) int static options (constant) init /* Printables except PAD, semicolon, but with BS */ (" !""#$%&'()*+,-./0123456789:<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~"); dcl 1 acla (12) aligned, 2 userid char (32), 2 mode bit (36), 2 xmode bit (36), 2 rcode fixed bin (35); /* DECLARATION OF AUTOMATIC STORAGE VARIABLES */ dcl access_ceiling bit (72) aligned; dcl time_now fixed bin (71); /* clock reading */ dcl n_acl fixed bin; dcl n_acl_pjadmin fixed bin; dcl (i, ii, j, k) fixed bin (18); dcl lcode fixed bin (35); dcl movelen fixed bin (24); dcl anonymous_user bit (1) aligned; dcl offset bit (18) aligned; dcl (p, q, satp, satep, pdtp, pdtep, htp, oldp, xp, tp) ptr; dcl procid bit (36) aligned; dcl tempid char (30) aligned; dcl debg char (8); dcl (bad_lr, bad_mr, bad_pq, bad_gt) fixed bin init (0); dcl (lr, mr) fixed bin; %page; /* ======================================================= */ /* This first section of code checks every entry in the proposed new PDT, to make sure that all entries are in a legal format and that the installer is authorized to install this PDT */ time_now = clock (); procid = get_process_id_ (); ansp = P_ansp; if procid ^= anstbl.as_procid then return; /* privileged proc */ access_ceiling = installation_parms.access_authorization_ceiling; instalp = null; /* pre-set returned pointer */ instaldir, instalname = " "; /* ... */ if wordcount < 64 then do; /* make sure segment contains something */ answer = "wordcount < 64"; code = 10; return; end; if segp -> pdt.version ^= PDT_version then do; /* Check table format */ answer = "incorrect table format"; code = 9; return; end; if segp -> pdt.current_size > segp -> pdt.max_size then do; answer = "current_size > max_size"; code = 11; return; end; if segp -> pdt.n_users > segp -> pdt.current_size then do; answer = "n_users > current_size"; code = 12; return; end; offset = rel (addr (segp -> pdt.user (segp -> pdt.current_size + 1))); if fixed (offset, 18) - 1 > wordcount then do; answer = "size inconsistent with wordcount"; code = 13; return; end; if verify (segp -> pdt.project_name, LEGAL) ^= 0 then do; answer = "project_name not ASCII"; code = 16; return; end; call hcs_$initiate (anstbl.sysdir, "sat", "", 0, 0, satp, code); if satp = null then do; answer = "cannot initiate SAT"; code = 15; return; end; do i = 1 to sat.current_size; satep = addr (sat.project (i)); if project.state = 1 then if project.project_id = segp -> pdt.project_name then go to project_validated; end; answer = "project not in SAT: " || segp -> pdt.project_name; code = 21; return; project_validated: segp -> pdt.project_dir = project.project_dir; instaldir = anstbl.sysdir; instaldir = rtrim (instaldir) || ">pdt"; instalname = project.project_id; instalname = rtrim (instalname) || ".pdt"; i = index (segp -> pdt.author.proc_group_id, " "); if i > 32 then i = 33; if i = 0 then i = 33; tempid = substr (segp -> pdt.author.proc_group_id, 1, i - 3); /* knock off instance tag */ j = 1 + index (tempid, "."); /* locate projectid begin */ do i = 1 to 2; /* check for system administrator */ if tempid = sat.system_admin (i) then go to administrator_validated; if substr (sat.system_admin (i), 1, 2) = "*." then if substr (sat.system_admin (i), 3, 28) = substr (tempid, j, 31 - j) then go to administrator_validated; if substr (sat.system_admin (i), j) = "*" then if substr (sat.system_admin (i), 1, j - 1) = substr (tempid, 1, j - 1) then go to administrator_validated; end; do i = 1 to 4; /* check administrator's name */ if tempid = project.admin (i).userid then go to administrator_validated; if substr (project.admin (i).userid, 1, 2) = "*." then if substr (project.admin (i).userid, 3, 28) = substr (tempid, j, 31 - j) then go to administrator_validated; if substr (project.admin (i).userid, j) = "*" then if substr (project.admin (i).userid, 1, j - 1) = substr (tempid, 1, j - 1) then go to administrator_validated; end; answer = "installer not administrator " || tempid; code = 22; return; administrator_validated: n_acl = 0; do i = 1 to 4; /* put all proj. administrators on PDT ACL */ if project.admin (i).userid = "" then go to x2; /* when find blank acl branch out of loop */ n_acl = n_acl + 1; acla (n_acl).userid = rtrim (project.admin (i).userid) || ".*"; acla (n_acl).mode = "1000"b; /* set READ access */ acla (n_acl).xmode = ""b; end; x2: n_acl_pjadmin = n_acl; /* number of project administrators */ do i = 1 to 2; /* put system admin on acl too. */ if sat.system_admin (i) = "" then go to x2a; n_acl = n_acl + 1; acla (n_acl).userid = rtrim (sat.system_admin (i)) || ".*"; do ii = 1 to n_acl_pjadmin; /* dont let a projadmin term deny w to a sysadmin */ call match_star_name_ ((acla (ii).userid), (acla (n_acl).userid), lcode); if lcode = 0 then /* project admin is also system admin */ acla (ii).mode = "1010"b; /* give proj admin rw to prevent blocking of sysadmin term */ end; acla (n_acl).mode = "1010"b; /* RW */ acla.xmode (n_acl) = ""b; end; x2a: n_acl = n_acl + 1; acla (n_acl).userid = get_group_id_ (); acla (n_acl).mode = "1010"b; acla.xmode (n_acl) = ""b; anonymous_user = "0"b; do i = 1 to segp -> pdt.current_size; p = addr (segp -> pdt.user (i)); if p -> user.state < 0 then go to bast; if p -> user.state > 2 then do; /* installing state 0 or 2 entries does nothing */ bast: answer = "illegal state value"; code = 17; return; end; if verify (p -> user.person_id, LEGAL) ^= 0 then do; answer = "person_id not ASCII"; code = 16; return; end; do j = 1 to i - 1; if addr (segp -> pdt.user (j)) -> user.person_id = p -> user.person_id then do; answer = "User ID duplication " || p -> user.person_id; code = 23; return; end; end; if p -> user.person_id = "*" then do; if project.at.anonymous = "0"b then do; answer = "anonymous user not allowed"; code = 24; return; end; anonymous_user = "1"b; end; if verify (p -> user.initial_procedure, LEGAL) ^= 0 then do; answer = "init_proc not ASCII " || p -> user.person_id; code = 16; return; end; if verify (p -> user.home_dir, LEGAL) ^= 0 then do; answer = "home_dir not ASCII " || p -> user.person_id; code = 16; return; end; if verify (p -> user.outer_module, LEGAL) ^= 0 then do; answer = "outer_module not ASCII " || p -> user.person_id; code = 16; return; end; if p -> user.low_ring < project.min_ring then do; bad_lr = bad_lr + 1; /* count instances of this, for warning message */ lr = project.min_ring; /* this is the one the user will get when he logs in */ end; else lr = p -> user.low_ring; /* this is the one the user will get */ if p -> user.high_ring > project.max_ring then do; bad_mr = bad_mr + 1; /* count these for warning message */ mr = project.max_ring; /* user gets this on login */ end; else mr = p -> user.high_ring; /* user gets this */ if p -> user.low_ring <= 0 then do; answer = "minimum ring less than 1 " || p -> user.person_id; code = 25; return; end; if lr > mr then do; /* if lr that user gets is > mr that he gets, he can't log in */ call ioa_$rsnnl ("^[project^x^]low ring > ^[project^x^]high ring ^a", answer, i, (lr = project.min_ring), (mr = project.max_ring), p -> user.person_id); code = 25; return; end; if p -> user.default_ring > 0 & /* have a default ring (new enough PDT) */ p -> user.default_ring < lr then do; /* and it's too low */ answer = "default ring is less than minimum allowed by SAT and PDT"; code = 25; return; end; if p -> user.default_ring > mr then do; answer = "default ring is greater than maximum allowed by SAT and PDT"; code = 25; end; if ^aim_check_$greater_or_equal (p -> user.user_authorization (2), p -> user.user_authorization (1)) then do; answer = "Invalid authorization range"; code = 26; end; if ^aim_check_$greater_or_equal (access_ceiling, p -> user.user_authorization (2)) then do; answer = "authorization > access_ceiling"; code = 18; return; end; if p -> user.pdir_quota > project.pdir_quota then bad_pq = bad_pq + 1; /* count these for warning message */ if p -> user.bump_grace > project.grace_max then bad_gt = bad_gt + 1; /* count these for warning message */ end; /* Now we will compare the new PDT with the current version, and merge the two files */ call hcs_$initiate (instaldir, instalname, "", 0, 1, oldp, code); if oldp = null then do; /* cannot locate old pdt */ call hcs_$make_seg (instaldir, instalname, "", 01010b, oldp, code); if oldp = null then return; /* Die if cannot create new segment. */ segp -> pdt.rs_number = project.rs_number; segp -> pdt.n_users = 0; /* recompute */ do i = 1 to segp -> pdt.current_size; p = addr (segp -> pdt.user (i)); if p -> user.state ^= 1 then go to bast;/* not install new user with state 2 */ segp -> pdt.n_users = segp -> pdt.n_users + 1; call zero_usage_items; /**** Get the alias and supply it here, someday. */ call create_homedir_ ((p -> user.person_id), "", p -> user.user_authorization (1), (project.project_id), (p -> user.home_dir), (project.project_dir), code); end; go to finish_up; /* Go clean up and set ACL */ end; /* There is an old PDT. Make up a temporary PDT which will be the merged copy. We start by making it look just like the current copy, and then apply changes */ call hcs_$make_seg (instaldir, "", "", 1011b, tp, code); if tp = null then do; answer = "cannot make temp"; return; end; movelen = PDT_header_lth + oldp -> pdt.current_size * PDT_entry_lth; tp -> movetable = oldp -> movetable; /* copy current pdt into temp seg */ if tp -> pdt.version ^= PDT_version then do; /* old pdt not same version as new one */ /* we checked earlier, and the new one is the correct version */ /* in general, something special must be done to get the information out of the old one */ /* ... */ /* having done what we can ... */ tp -> pdt.version = PDT_version; /* put latest version number into merged copy */ end; tp -> pdt.n_users = 0; /* recalculate this */ tp -> pdt.author.proc_group_id = segp -> pdt.author.proc_group_id; tp -> pdt.author.lock = ""b; tp -> pdt.author.last_install_time = clock (); tp -> pdt.author.table = segp -> pdt.author.table; tp -> pdt.author.w_dir = segp -> pdt.author.w_dir; tp -> pdt.rs_number = project.rs_number; do i = 1 to tp -> pdt.current_size; /* loop thru old copy. find any merges or deletes */ p = addr (tp -> pdt.user (i)); if p -> user.state = 0 then go to x1; /* skip free entries */ p -> user.state = 2; do j = 1 to segp -> pdt.current_size; q = addr (segp -> pdt.user (j)); if q -> user.state = 1 then /* not install dead users */ if p -> user.person_id = q -> user.person_id then do; p -> user.state = 1; /* old user still in project. merge */ tp -> pdt.n_users = tp -> pdt.n_users + 1; if p -> user.datof ^= 0 then do; /* returning user? */ p -> user.daton = time_now; p -> user.datof = 0; end; q -> user.state = -1; /* now mark new boy deleted, so not scan again */ call adjust_cutoff_ (p, time_now); call merge_admin_info; if p -> user.daton = time_now /* if user was just reregistered */ then call create_homedir_ ((p -> user.person_id), "", p -> user.user_authorization (1), (project.project_id), (p -> user.home_dir), (project.project_dir), code); go to x1; /* leave old usage figures */ end; end; p -> user.datof = time_now; /* deleted user - state will be 2 */ x1: end; do i = 1 to segp -> pdt.current_size; /* loop thru new copy, looking for new users */ q = addr (segp -> pdt.user (i)); if q -> user.state = 1 then do; /* any user left in new file with state 1 is new */ badx: j = tp -> pdt.freep; if j = 0 then j, tp -> pdt.current_size = tp -> pdt.current_size + 1; else do; xp = addr (tp -> pdt.user (j)); if xp -> user.state ^= 0 then do; call sys_log_ (SL_LOG_BEEP, "up_pdt_: ^a ^a on free list state nonzero", instalname, xp -> user.person_id); tp -> pdt.freep = 0; go to badx; end; tp -> pdt.freep = xp -> user.chain; end; p = addr (tp -> pdt.user (j)); p -> user.state = 1; tp -> pdt.n_users = tp -> pdt.n_users + 1; p -> user.person_id = q -> user.person_id; call merge_admin_info; /* put in limits and stuff */ call zero_usage_items; call create_homedir_ ((p -> user.person_id), "", p -> user.user_authorization (1), (project.project_id), (p -> user.home_dir), (project.project_dir), code); end; end; do i = 1 to anstbl.current_size; /* scan answer table */ utep = addr (anstbl.entry (i)); if ute.active >= NOW_LOGGED_IN then /* look for logged in users on this proj */ if ute.project = tp -> pdt.project_name then do; if ute.anonymous = 0 then /* regular user */ do j = 1 to tp -> pdt.current_size; q = addr (tp -> pdt.user (j)); if q -> user.state = 1 then if q -> user.person_id = ute.person then do; if rel (ute.pdtep) ^= rel (q) then do; call sys_log_ (SL_LOG_BEEP, "up_pdt_: synch error ^a.^a", ute.person, ute.project); end; if ^aim_check_$in_range ( ute.process_authorization_range (1), q -> user.user_authorization) | ^aim_check_$in_range ( ute.process_authorization_range (2), q -> user.user_authorization) then do; call sys_log_ (SL_LOG, "up_pdt_: bumping ^a.^a, user authorization now outside range.", ute.person, ute.project); call asu_$bump_code (utep, as_error_table_$user_auth_excludes, debg, code, (0)); end; go to next_entry; end; end; else if anonymous_user then go to next_entry; /* arrived here we have a logged-in user who is no longer accredited by his project */ if ute.preempted = 0 then do; call sys_log_ (SL_LOG, "up_pdt_: bumping ^a.^a, omitted from new pdt", ute.person, ute.project); call asu_$bump_code (utep, as_error_table_$user_deleted, debg, code, (installation_parms.warning_time)); end; end; next_entry: end; instalp = oldp; call hcs_$delentry_seg (segp, code); segp = tp; finish_up: /* Build hash table. Maybe. */ pdtp = segp; /* avoid lots of segp ->'s */ pdt.ht_relp = 0; /* no hash table yet */ wordcount = 0; /* length of hash table */ if pdt.current_size < 8 then /* if PDT fits into 1 or 2 pages */ goto finish_up_2; /* a hash table won't save us any page faults */ code = 0; htp = null; /* no hash table seg created so far. */ if pdt.current_size > 956 then do; /* room for only 956 users, with hash table at end */ call sys_log_ (SL_LOG, "up_pdt_: ^a has ^d users, leaving insufficient room for a hash table.", instalname, pdt.current_size); goto no_ht; end; call hcs_$make_seg (instaldir, "pdt.ht.temp", "", 1011b, htp, code); if code ^= 0 then goto no_ht; call hcs_$truncate_seg (htp, (0), code); if code ^= 0 then goto no_ht; /* figure out how long to make it */ if pdt.n_users > 70 then /* if reasonably large number of users */ i = fixed (float (pdt.n_users) / .7); /* use Knuth's recommendation of 70% */ else i = min (101, max (24, fixed (float (pdt.n_users) / .5))); /* but small hash tables act funny, so make it 50% full, subject to being between 1/4 and 1 page long */ call hash_$make (htp, (i), code); if code ^= 0 then goto no_ht; do i = 1 to pdt.current_size; pdtep = addr (pdt.user (i)); if user.state = 1 then do; call hash_$in (htp, user.person_id, (i), code); if code ^= 0 then goto no_ht; end; end; pdtep = addr (pdt.user (i)); /* get ptr to where to put ht - after last user */ wordcount = htable.loht; /* length of table */ movelen = wordcount; pdtep -> movetable = htp -> movetable; /* copy table onto end of new pdt */ pdt.ht_relp = fixed (rel (pdtep)); /* put relptr to it into header */ call hcs_$delentry_seg (htp, (0)); /* clean up */ finish_up_2: wordcount = wordcount + segp -> pdt.current_size * PDT_entry_lth + PDT_header_lth; movelen = wordcount; /* Now copy new pdt over old one. */ oldp -> movetable = segp -> movetable; /* zoop. */ call hcs_$truncate_seg (oldp, wordcount, code); if code ^= 0 then answer = "Unable to truncate pdt to current length"; /* not worth stopping for though */ call hcs_$add_acl_entries (instaldir, instalname, addr (acla), n_acl, code); call hcs_$set_bc (instaldir, instalname, 36 * wordcount, code); call hcs_$set_safety_sw (instaldir, instalname, "1"b, code); code = 0; /* Succeeded. */ if bad_lr > 0 | bad_mr > 0 | bad_pq > 0 | bad_gt > 0 then do; /* return warning if necessary */ call ioa_$rsnnl ("SAT limits exceeded (will be enforced at login time): ^[min_ring: ^d, ^d users;^x^;^2s^]^[max_ring: ^d, ^d users;^x^;^2s^]^[pdir_quota: ^d, ^d users;^x^;^2s^]^[grace_time: ^d, ^d users;^x^;^2s^]", answer, i, (bad_lr > 0), project.min_ring, bad_lr, (bad_mr > 0), project.max_ring, bad_mr, (bad_pq > 0), project.pdir_quota, bad_pq, (bad_gt > 0), project.grace_max, bad_gt); substr (answer, i - 1, 1) = ""; /* get rid of last ";"; up_sysctl_ supplies a period */ end; return; no_ht: call sys_log_$error_log (SL_LOG_BEEP, code, "up_pdt_", "^a will be installed with no hash table", instalname); if htp ^= null then call hcs_$delentry_seg (htp, (0)); goto finish_up_2; /* Internal proc to copy limits and other administrator-specified data into pdt entry */ merge_admin_info: proc; p -> user.password = q -> user.password; string (p -> user.at) = string (q -> user.at); p -> user.user_authorization = q -> user.user_authorization; p -> user.initial_procedure = q -> user.initial_procedure; p -> user.ip_len = q -> user.ip_len; p -> user.ss_len = q -> user.ss_len; p -> user.home_dir = q -> user.home_dir; p -> user.bump_grace = q -> user.bump_grace; p -> user.high_ring = q -> user.high_ring; p -> user.low_ring = q -> user.low_ring; p -> user.default_ring = q -> user.default_ring; p -> user.outer_module = q -> user.outer_module; p -> user.lot_size = q -> user.lot_size; p -> user.kst_size = q -> user.kst_size; p -> user.cls_size = q -> user.cls_size; p -> user.pdir_quota = q -> user.pdir_quota; string (p -> user.uflags) = string (q -> user.uflags); p -> user.dollar_limit = q -> user.dollar_limit; p -> user.absolute_limit = q -> user.absolute_limit; p -> user.absolute_cutoff = q -> user.absolute_cutoff; p -> user.absolute_increm = q -> user.absolute_increm; p -> user.user_warn_days = q -> user.user_warn_days; p -> user.user_warn_pct = q -> user.user_warn_pct; p -> user.user_warn_dollars = q -> user.user_warn_dollars; p -> user.warn_days = q -> user.warn_days; p -> user.warn_pct = q -> user.warn_pct; p -> user.warn_dollars = q -> user.warn_dollars; p -> user.group = q -> user.group; p -> user.max_foreground = q -> user.max_foreground; p -> user.max_background = q -> user.max_background; p -> user.abs_foreground_cpu_limit = q -> user.abs_foreground_cpu_limit; call adjust_cutoff_ (p, time_now); do k = 0 to 7; p -> user.shift_limit (k) = q -> user.shift_limit (k); end; end merge_admin_info; /* Internal procedure to clear usage in pdt entry */ zero_usage_items: proc; p -> user.now_in = 0; /* not logged in because is new guy */ p -> user.n_foreground = 0; p -> user.n_background = 0; p -> user.time_last_reset, p -> user.daton = time_now; p -> user.datof = 0; p -> user.dollar_charge = 0e0; p -> user.absolute_spent = 0e0; p -> user.last_login_time = 0; p -> user.last_login_unit = ""; p -> user.last_login_type = 0; p -> user.last_login_line_type = 0; p -> user.time_last_bump = 0; do k = 0 to 7; p -> user.interactive.charge (k) = 0e0; p -> user.interactive.cpu (k) = 0; p -> user.interactive.core (k) = 0; p -> user.interactive.connect (k) = 0; p -> user.interactive.io_ops (k) = 0; end; do k = 1 to 4; p -> user.absentee.charge (k) = 0e0; p -> user.absentee.jobs (k) = 0; p -> user.absentee.cpu (k) = 0; p -> user.absentee.memory (k) = 0; end; do k = 1 to 4; p -> user.iod.charge (k) = 0e0; p -> user.iod.pieces (k) = 0; p -> user.iod.pages (k) = 0; p -> user.iod.lines (k) = 0; end; do k = 1 to 16; p -> user.devices (k) = 0e0; end; end zero_usage_items; %page; %include answer_table; %page; %include dialup_values; %page; %include hashst; %page; %include installation_parms; %page; %include pdt; %page; %include sat; %page; %include sys_log_constants; %page; %include user_attributes; %page;%include user_table_entry; %page;%include user_table_header; %page; /* BEGIN MESSAGE DOCUMENTATION Message: up_pdt_: bumping NAME.PROJ, omitted from new pdt S: as (severity1) T: $run M: The supervisor of project PROJ has removed the user named NAME from the project while he was logged in. He is no longer authorized to be logged in on that project and is bumped. A: $ignore Message: up_pdt_: bumping NAME.PROJ, user authorization now outside range. S: as (severity1) T: $run M: A project administrator has installed a new pdt that changes the authorization range for the user identified by NAME on project PROJ. The user NAME.PROJ is currently logged in with an authorization outside the new range. Therefore, the user is being bumped from the system. A: $ignore Message: up_pdt_: synch error NAME.PROJ S: as (severity2) T: $run M: A new project definition table for PROJ is being installed. The answer table entry for NAME.PROJ should contain a pointer to the user's PDT entry but the pointer is incorrect. Accounting figures may be scrambled. The system continues operation. A: $contact_sa Message: up_pdt_: PROJ.pdt NAME on free list state nonzero S: as (severity2) T: $run M: A new project definition table for PROJ is being installed. The thread of free entries appears to include some user whose state is not zero. The program abandons the free chain and continues. A: $inform_sa Message: up_pdt_: PROJ.pdt has N users, leaving insufficient room for a hash table. S: as (severity1) T: $run M: A new project definition table (PDT) for project PROJ is being installed. It has so many users that there is no room in it for a hash table. The PDT will be installed without a hash table. Logins on that project will take longer and place an extra load on the system. A: $inform Message: up_pdt_: ERROR_MESSAGE. PROJ.pdt will be installed with no hash table S: as (severity2) T: $run M: A new PDT is being installed for project PROJ. An error described by ERROR_MESSAGE occurred while its hash table was being built. The PDT will be installed without a hash table. Logins on that project will take longer and place an extra load on the system. A: $inform END MESSAGE DOCUMENTATION */ end up_pdt_;  up_rtdt_.pl1 08/04/87 1455.8rew 08/04/87 1221.8 325863 /****^ *********************************************************** * * * 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 */ up_rtdt_: procedure (upd_rtdtp, wordcount, instaldir, instalname, instalp, P_ansp, ip, answer, code); /* up_rtdt_ - update resource type description table. Stolen from up_mgt_ on 03/21/78 by C. D. Tavares Modified 10/03/80 by CDT to fix subscripting error causing additon of only one new attribute per resource type per installation. Modified November 1981, E. N. Kittlitz. user_table_entry conversion. Modified January 1982, BIM for author changes (lock and install time). Modified February 1982, E. N. Kittlitz. xxx.install.acs change. Modified July 1982, E. N. Kittlitz. Put back CDT's fix of 10/03/80. Modified October 1982, B. Braun to add attributes correctly (phx8087). Modified September 1983, S. Harris (UNCA) via E. N. Kittlitz. Put back CDT's fixes again. Modified: 10/05/84 by R. Michael Tague: up_sysctl_$check_acs now returns a bit (36) mode string instead of a fixed bin (5) and no longer takes a directoy arg. */ /****^ HISTORY COMMENTS: 1) change(86-06-05,GJohnson), approve(86-06-05,MCR7387), audit(86-06-10,Martinson), install(86-07-11,MR12.0-1092): Correct error message documentation. 2) change(87-04-26,GDixon), approve(87-07-13,MCR7741), audit(87-07-16,Hartogs), install(87-08-04,MR12.1-1055): Upgraded for change to answer_table.incl.pl1. END HISTORY COMMENTS */ /* DECLARATION OF PARAMETERS */ dcl (upd_rtdtp, instalp, P_ansp, ip) pointer; dcl wordcount fixed bin; dcl code fixed bin (35); dcl (instaldir char (*), instalname char (*), answer char (*)); /* DECLARATION OF EXTERNAL SYMBOLS */ dcl define_area_ ext entry (pointer, fixed bin (35)); dcl get_ring_ entry () returns (fixed bin (3)); dcl unique_chars_ ext entry (bit (*)) returns (char (15)); dcl hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); dcl hcs_$get_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35)); dcl hcs_$set_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35)); dcl up_sysctl_$check_acs entry (char (*), char (*), fixed bin, bit (36) aligned, fixed bin (35)); dcl get_process_id_ entry () returns (bit (36)); dcl get_group_id_ entry () returns (char (32)); dcl hcs_$replace_acl entry (char (*), char (*), ptr, fixed bin, bit (1), fixed bin (35)); dcl hcs_$list_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35)); dcl hcs_$set_safety_sw entry (char (*), char (*), bit (1), fixed bin (35)); dcl hcs_$set_safety_sw_seg entry (pointer, bit (1) aligned, fixed bin (35)); dcl hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35)); dcl cu_$level_get entry (fixed bin); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl sys_log_ entry options (variable); dcl sys_log_$error_log entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl error_table_$action_not_performed ext fixed bin (35); dcl sys_info$max_seg_size ext fixed bin (35); dcl (rcp_sys_$create_registry, rcp_sys_$update_registry_header) ext entry (char (*) aligned, pointer, fixed bin (35)), rcp_sys_$remove_registry ext entry (char (*) aligned, char (*) aligned, fixed bin (35)); dcl (addr, binary, clock, empty, hbound, index, length, null, nullo, offset, pointer, rel, rtrim, size, string, substr, unspec) builtin; dcl cleanup condition; /* DECLARATION OF INTERNAL STATIC VARIABLES */ dcl acs_name char (32) int static options (constant) init ("rtdt.install.acs"); dcl debug_sw bit (1) aligned static initial (""b); dcl (TYPE_AND_LOG_MSG initial (1), TYPE_AND_LOG_MSG_WITH_BANNER initial (2)) fixed bin internal static options (constant); /* dcl LEGAL char (95) int static init /* Printables except PAD, semicolon, but with BS */ /* (" !""#$%&'()*+,-./0123456789:<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~");/* */ /* DECLARATION OF AUTOMATIC STORAGE VARIABLES */ dcl (i, j) fixed bin; /* counters */ dcl registry_dir char (168) aligned; dcl newname char (32); dcl acl_area area (300); dcl acl_ptr pointer; dcl acl_count fixed bin; dcl unique_name char (32); dcl bitcount fixed bin (24); dcl tempstring char (128) aligned; dcl upd_to_new (72) fixed bin; dcl auto_upd_attributes_valid bit (72) aligned; dcl not_found bit (1) aligned; dcl no_prev_table bit (1); /* switch to indicate that an old table doesn't exist */ dcl syacn fixed bin init (1); dcl ring fixed bin; dcl mode bit (36) aligned; dcl rtdt_rings (3) fixed bin (3); dcl 1 aclb (5) aligned int, 2 userid char (32), 2 mode bit (36), 2 rpad bit (36) init ((5) (36)"0"b), 2 rcode fixed bin (35); %page; /* ====================================================================== */ %include rtdt; dcl 1 old_rtdt aligned like rtdt based (old_rtdtp); dcl 1 new_rtdt aligned like rtdt based (new_rtdtp); dcl 1 upd_rtdt aligned like rtdt based (upd_rtdtp); dcl 1 old_rtde aligned based (old_rtdep), 2 fixed_info like rtde.fixed_info aligned, 2 mates (N_MATES refer (old_rtde.n_mates)) char (32) aligned, 2 subtypes (N_SUBTYPES refer (old_rtde.n_subtypes)) aligned, 3 subtype_name char (32), 3 subtype_defaults like rtde.registration_defaults aligned; dcl 1 new_rtde aligned based (new_rtdep), 2 fixed_info like rtde.fixed_info aligned, 2 mates (N_MATES refer (new_rtde.n_mates)) char (32) aligned, 2 subtypes (N_SUBTYPES refer (new_rtde.n_subtypes)) aligned, 3 subtype_name char (32), 3 subtype_defaults like rtde.registration_defaults aligned; dcl 1 upd_rtde aligned based (upd_rtdep), 2 fixed_info like rtde.fixed_info aligned, 2 mates (N_MATES refer (upd_rtde.n_mates)) char (32) aligned, 2 subtypes (N_SUBTYPES refer (upd_rtde.n_subtypes)) aligned, 3 subtype_name char (32), 3 subtype_defaults like rtde.registration_defaults aligned; dcl (last_rtdep, upd_rtdep, new_rtdtp, new_rtdep, old_rtdtp, old_rtdep, old_cttp, upd_cttp, delthru_ptr) pointer; dcl 1 auto_ctt aligned automatic, 2 n_charge_types fixed bin, 2 charge_types (100) char (32); %page; ansp = P_ansp; if anstbl.as_procid ^= get_process_id_ () then return; rtdtp = null; /* this will catch unqualified refs to rtdt */ instalp = null; /* pre-set returned pointer */ delthru_ptr = null; /* delete nothing if we fail(yet) */ instaldir = anstbl.sysdir; /* Make name of place to put copy. */ registry_dir = rtrim (instaldir, " ") || ">rcp"; instalname = "rtdt"; /* Make segment name. */ call hcs_$initiate (instaldir, instalname, "", 0, 0, old_rtdtp, code); if old_rtdtp = null then do; no_prev_table = "1"b; /* no old RTDT. How about that? */ rtdt_rings (*) = get_ring_ (); end; else do; no_prev_table = "0"b; call hcs_$get_ring_brackets (instaldir, instalname, rtdt_rings, code); if code ^= 0 then rtdt_rings (*) = get_ring_ (); end; if wordcount < 64 then do; /* make sure segment contains something */ answer = "wordcount < 64"; goto rtdt_error; end; if (upd_rtdt.version ^= RTDT_version_2) & (upd_rtdt.version ^= RTDT_version_3) then do; answer = "unimplemented version"; goto rtdt_error; end; if ^no_prev_table then do; call cu_$level_get (ring); call up_sysctl_$check_acs (acs_name, (upd_rtdt.author.proc_group_id), ring, mode, code); if (code ^= 0) | ((mode & RW_ACCESS) ^= RW_ACCESS) then do; answer = "access violation"; goto rtdt_error; end; end; /* Create a unique named segment to hold the RTDT during merge */ unique_name = unique_chars_ (""b); on cleanup call clean_up; call hcs_$make_seg (instaldir, unique_name, "", 1010b, new_rtdtp, code); if code ^= 0 then do; answer = "cannot create temp RTDT"; goto rtdt_error; end; delthru_ptr = new_rtdtp; new_rtdt.author = upd_rtdt.author; new_rtdt.author.last_install_time = clock (); new_rtdt.author.lock = ""b; new_rtdt.version = upd_rtdt.version; new_rtdt.charge_type_table_ptr, new_rtdt.first_resource = nullo; new_rtdt.installed_under_resource_mgt = ip -> installation_parms.rcp_init_flags.resource_mgmt_enabled; RTDT_area_len = 0; RTDT_area_len = sys_info$max_seg_size - size (rtdt); unspec (auto_area_info) = ""b; auto_area_info.version = area_info_version_1; auto_area_info.no_freeing, auto_area_info.dont_free = "1"b; auto_area_info.owner = "RTDT"; auto_area_info.size = RTDT_area_len; auto_area_info.areap = addr (new_rtdt.rtdt_area); call define_area_ (addr (auto_area_info), code); if code ^= 0 then do; answer = "Cannot define area in RTDT"; goto rtdt_error; end; old_cttp, last_rtdep = null; auto_ctt.n_charge_types = 0; upd_cttp = pointer (upd_rtdt.charge_type_table_ptr, upd_rtdt.rtdt_area); /* If there is an RTDT already, we have to merge the new with the old. */ if ^no_prev_table then do; old_cttp = pointer (old_rtdt.charge_type_table_ptr, old_rtdt.rtdt_area); do old_rtdep = pointer (old_rtdt.first_resource, old_rtdt.rtdt_area) repeat (pointer (old_rtde.next_resource, old_rtdt.rtdt_area)) while (old_rtdep ^= null); old_rtde.deletion_pending = ""b; /* initialize this */ if old_rtde.valid then do; not_found = "1"b; upd_to_new (*) = 0; do upd_rtdep = pointer (upd_rtdt.first_resource, upd_rtdt.rtdt_area) repeat (pointer (upd_rtde.next_resource, upd_rtdt.rtdt_area)) while (upd_rtdep ^= null & not_found); if upd_rtde.valid then if old_rtde.name = upd_rtde.name then do; not_found = ""b; N_MATES = upd_rtde.n_mates; N_SUBTYPES = upd_rtde.n_subtypes; allocate new_rtde in (new_rtdt.rtdt_area); /* Examine and merge the header for this RTDE. */ if old_rtde.is_volume ^= upd_rtde.is_volume then do; if old_rtde.is_volume then answer = "attempt to change volume to device: " || old_rtde.name; else answer = "attempt to change device to volume: " || old_rtde.name; goto rtdt_error; /* This would screw up registration database no end */ end; if old_rtde.is_synonym ^= upd_rtde.is_synonym then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: ^a is ^[now^;no longer^] a synonym.", old_rtde.name, upd_rtde.is_synonym); if (debug_sw & ^upd_rtde.is_synonym) then do; if old_rtde.manual_clear ^= upd_rtde.manual_clear then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: ^a ^a changed from ^b to ^b.", old_rtde.name, "manual_clear", old_rtde.manual_clear, upd_rtde.manual_clear); if old_rtde.process_limit ^= upd_rtde.process_limit then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: ^a ^a changed from ^d to ^d.", old_rtde.name, "process_limit", old_rtde.process_limit, upd_rtde.process_limit); if old_rtde.default_time ^= upd_rtde.default_time then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: ^a ^a changed from ^d to ^d.", old_rtde.name, "default_time", old_rtde.default_time, upd_rtde.default_time); if old_rtde.max_time ^= upd_rtde.max_time then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: ^a ^a changed from ^d to ^d.", old_rtde.name, "max_time", old_rtde.max_time, upd_rtde.max_time); if old_rtde.advance_notice_time ^= upd_rtde.advance_notice_time then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: ^a ^a changed from ^d to ^d.", old_rtde.name, "advance_notice_time", old_rtde.advance_notice_time, upd_rtde.advance_notice_time); if old_rtde.advance_notice_time ^= upd_rtde.advance_notice_time then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: ^a ^a changed from ^d to ^d.", old_rtde.name, "advance_notice_time", old_rtde.advance_notice_time, upd_rtde.advance_notice_time); if old_rtdt.version ^= RTDT_version_2 then if old_rtde.precanon_proc ^= upd_rtde.precanon_proc then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: ^a ^a changed from ^a to ^a.", old_rtde.name, "precanon_proc", old_rtde.precanon_proc, upd_rtde.precanon_proc); if old_rtde.n_subtypes ^= upd_rtde.n_subtypes then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: ^a ^a changed from ^d to ^d.", old_rtde.name, "n_subtypes", old_rtde.n_subtypes, upd_rtde.n_subtypes); end; if upd_rtdt.version = RTDT_version_3 then call check_canon_proc (upd_rtde.precanon_proc); unspec (new_rtde.fixed_info) = unspec (upd_rtde.fixed_info); new_rtde.next_resource = nullo; new_rtde.deletion_pending, new_rtde.addition_pending = ""b; if new_rtde.is_synonym then do; /* syns are mostly hoochy-coochy */ upd_rtde.valid = ""b; /* otherwise it shows up as an addition */ goto skip_validation; end; /* RTDT's will be installed before Resource Management. The initial release of RTDT's will not be accompanied by registries. When Resource Management is turned on at a site, we will have to create fresh registries for each resource type. The following code does this. Note that a site's RTDT must be reinstalled to create these registries. */ if old_rtdt.installed_under_resource_mgt = ""b then if ip -> installation_parms.rcp_init_flags.resource_mgmt_enabled then new_rtde.addition_pending = "1"b; /* Now, examine the attributes and merge the new attributes with the old, preserving the ordering of the old attributes. This is necessary because all the resources described in the registration database reference these attributes by a positional bit string, and thus we can never shift any of these bits without passing through the entire registry for this resource and doing the same thing to all those attribute bits too. */ auto_upd_attributes_valid = upd_rtde.attributes_valid; new_rtde.attributes_valid = old_rtde.attributes_valid; new_rtde.attributes_to_match = old_rtde.attributes_to_match; new_rtde.attribute_names (*) = old_rtde.attribute_names (*); new_rtde.n_defined_attributes = old_rtde.n_defined_attributes; /* we diddle this as we go, but we NEVER lower it */ do i = 1 to old_rtde.n_defined_attributes; if substr (old_rtde.attributes_valid, i, 1) then do; do j = 1 to upd_rtde.n_defined_attributes while (^substr (auto_upd_attributes_valid, j, 1) | upd_rtde.attribute_names (j) ^= old_rtde.attribute_names (i)); end; if j > upd_rtde.n_defined_attributes then do; if debug_sw then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: ^a attribute ^a deleted.", old_rtde.name, old_rtde.attribute_names (i)); substr (new_rtde.attributes_valid, i, 1) = ""b; end; else do; substr (auto_upd_attributes_valid, j, 1) = ""b; /* it matches, remove it from further consideration */ upd_to_new (j) = i; end; end; end; /* At this point we've found and matched all the existing attributes in the old RTDE (or noticed their deletion.) Now we scan to see if new attributes have been defined. */ do while (auto_upd_attributes_valid ^= ""b); j = index (auto_upd_attributes_valid, "1"b); do i = 1 to old_rtde.n_defined_attributes while (old_rtde.attribute_names (i) ^= upd_rtde.attribute_names (j)); end; if i > old_rtde.n_defined_attributes then do; if i > hbound (upd_to_new, 1) then do; answer = "attribute overflow on " || old_rtde.name; goto rtdt_error; end; i = new_rtde.n_defined_attributes + 1; new_rtde.attribute_names (i) = upd_rtde.attribute_names (j); substr (new_rtde.attributes_to_match, i, 1) = substr (upd_rtde.attributes_to_match, j, 1); new_rtde.n_defined_attributes = i; end; upd_to_new (j) = i; substr (new_rtde.attributes_valid, i, 1) = "1"b; substr (auto_upd_attributes_valid, j, 1) = ""b; /* mark it ignored */ if debug_sw then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: New attribute ^a for ^a.", new_rtde.attribute_names (i), new_rtde.name); end; /* At this point, we've scanned all the attributes and know where each goes. Now we scan the implication string to see if it has changed. */ do j = 1 to upd_rtde.n_defined_attributes; i = upd_to_new (j); if i > 0 then if substr (upd_rtde.attributes_to_match, j, 1) ^= substr (new_rtde.attributes_to_match, i, 1) then do; if debug_sw then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: ^a ^a ^[now^;no longer^] implies.", upd_rtde.name, upd_rtde.attribute_names (j), substr (upd_rtde.attributes_to_match, j, 1)); substr (new_rtde.attributes_to_match, i, 1) = substr (upd_rtde.attributes_to_match, j, 1); end; end; /* Now we (possibly) restructure the exclusion specifications. */ do i = 1 to upd_rtde.n_exclusion_specs; new_rtde.exclusion_specs (i) = ""b; /* start out fresh */ do j = 1 to upd_rtde.n_defined_attributes; if upd_to_new (j) > 0 then /* do only if attr not deleted */ substr (new_rtde.exclusion_specs (i), upd_to_new (j), 1) = substr (upd_rtde.exclusion_specs (i), j, 1); end; end; /* All the attributes are now known and loved. Now we merge the mates. */ unspec (new_rtde.mates) = unspec (upd_rtde.mates); if debug_sw then do; do i = 1 to old_rtde.n_mates; do j = 1 to upd_rtde.n_mates while (upd_rtde.mates (j) ^= old_rtde.mates (i)); end; if j > upd_rtde.n_mates then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: ^a no longer mates with ^a.", old_rtde.mates (i), old_rtde.name); else upd_rtde.mates (j) = ""; end; do j = 1 to upd_rtde.n_mates; if upd_rtde.mates (j) ^= "" then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: ^a now mates with ^a.", upd_rtde.mates (j), upd_rtde.name); end; end; /* Now we check the defaults and the defaults' attribute strings. */ call check_subtype (old_rtde.registration_defaults, upd_rtde.registration_defaults, new_rtde.registration_defaults, old_rtde.name); do i = 1 to old_rtde.n_subtypes; do j = 1 to upd_rtde.n_subtypes while (upd_rtde.subtype_name (j) ^= old_rtde.subtype_name (i)); end; if j > upd_rtde.n_subtypes then if debug_sw then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: Subtype ^a deleted from ^a.", old_rtde.subtype_name (i), old_rtde.name); else ; else do; new_rtde.subtype_name (j) = upd_rtde.subtype_name (j); call ioa_$rsnnl ("^a (subtype ^a)", tempstring, 0, upd_rtde.name, upd_rtde.subtype_name (j)); call check_subtype (old_rtde.subtype_defaults (i), upd_rtde.subtype_defaults (j), new_rtde.subtype_defaults (j), tempstring); upd_rtde.subtype_name (j) = ""; end; end; do j = 1 to upd_rtde.n_subtypes; if upd_rtde.subtype_name (j) ^= "" then do; if debug_sw then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: Subtype ^a added to ^a.", upd_rtde.subtype_name (j), upd_rtde.name); /* Don't get confused by the double subscript of "j"-- the new RTDE was allocated with just as many subtypes as the upd RTDE. Therefore, if there are any extra (new) subtypes in the upd RTDE, by definition we must have encountered (j - n_extra) in the old RTDE. Confused? The answering service isn't! */ unspec (new_rtde.subtypes (j)) = unspec (upd_rtde.subtypes (j)); call normalize_attributes (upd_rtde.subtypes (j).potential_attributes, new_rtde.subtypes (j).potential_attributes); call normalize_attributes (upd_rtde.subtypes (j).potential_attributes, new_rtde.subtypes (j).potential_attributes); call normalize_attributes (upd_rtde.subtypes (j).attributes, new_rtde.subtypes (j).attributes); call normalize_charge_type (upd_cttp -> charge_type_table.charge_types (upd_rtde.subtypes (j).charge_type), new_rtde.subtypes (j).charge_type); end; end; upd_rtde.valid = ""b; /* exhausted this rtde, turn it off. */ skip_validation: if last_rtdep = null then new_rtdt.first_resource = offset (new_rtdep, new_rtdt.rtdt_area); else last_rtdep -> rtde.next_resource = offset (new_rtdep, new_rtdt.rtdt_area); last_rtdep = new_rtdep; end; /* end processing of matching rtdes */ end; /* end search for an upd_rtde to match an old_rtde */ if not_found then old_rtde.deletion_pending = "1"b; end; /* end finding of a valid old_rtde */ end; /* end the loop thru all old_rtdes */ end; /* end consideration of old RTDT */ /* We interrupt this program to bring you a few brief and timely internal procedures. */ check_subtype: proc (old_defaults, upd_defaults, new_defaults, name); dcl 1 old_defaults aligned parameter like rtde.registration_defaults; dcl 1 upd_defaults aligned parameter like rtde.registration_defaults; dcl 1 new_defaults aligned parameter like rtde.registration_defaults; dcl name char (*) aligned parameter; dcl new_charge_type char (32) aligned; if debug_sw then do; if old_defaults.potential_attributes_given ^= upd_defaults.potential_attributes_given then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: Default ^a ^[added^;removed^] for ^a", "potential_attributes", upd_defaults.potential_attributes_given, name); if old_defaults.attributes_given ^= upd_defaults.attributes_given then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: Default ^a ^[added^;removed^] for ^a", "attributes", upd_defaults.attributes_given, name); if old_defaults.aim_range_given ^= upd_defaults.aim_range_given then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: Default ^a ^[added^;removed^] for ^a", "access_bounds", upd_defaults.aim_range_given, name); if old_defaults.charge_type_given ^= upd_defaults.charge_type_given then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: Default ^a ^[added^;removed^] for ^a", "charge_type", upd_defaults.charge_type_given, name); end; string (new_defaults.default_flags) = string (upd_defaults.default_flags); if upd_defaults.potential_attributes & ^upd_rtde.attributes_valid then do; invalid_atts: answer = "invalid attributes as defaults"; goto rtdt_error; end; call normalize_attributes (upd_defaults.potential_attributes, new_defaults.potential_attributes); if upd_defaults.attributes & ^upd_rtde.attributes_valid then goto invalid_atts; call normalize_attributes (upd_defaults.attributes, new_defaults.attributes); if debug_sw then do; if old_defaults.potential_attributes ^= new_defaults.potential_attributes then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: Default potential attributes changed for ^a", name); if old_defaults.attributes ^= new_defaults.attributes then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: Default attributes changed for ^a", name); if old_defaults.aim_range_given & upd_defaults.aim_range_given then if (old_defaults.aim_range (1) ^= upd_defaults.aim_range (1) | old_defaults.aim_range (2) ^= upd_defaults.aim_range (2)) then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: Default ^a changed for ^a", "access_bounds", name); end; new_defaults.aim_range = upd_defaults.aim_range; if upd_defaults.charge_type_given then new_charge_type = upd_cttp -> charge_type_table.charge_types (upd_defaults.charge_type); else new_charge_type = "* ERROR! *"; if debug_sw then if upd_defaults.charge_type_given & old_defaults.charge_type_given then if new_charge_type ^= old_cttp -> charge_type_table.charge_types (old_defaults.charge_type) then call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: Charge type changed for ^a", name); call normalize_charge_type (new_charge_type, new_defaults.charge_type); return; end check_subtype; normalize_attributes: proc (upd_attributes, new_attributes); dcl (upd_attributes, new_attributes) bit (72) aligned; dcl (i, j) fixed bin; new_attributes = ""b; do i = 1 to length (upd_attributes); j = upd_to_new (i); if j > 0 then substr (new_attributes, j, 1) = substr (upd_attributes, i, 1); end; return; end normalize_attributes; normalize_charge_type: proc (type_name, type_num); dcl type_name char (32) aligned parameter, type_num fixed bin parameter; dcl i fixed bin; do i = 1 to auto_ctt.n_charge_types while (auto_ctt.charge_types (i) ^= type_name); end; if i > auto_ctt.n_charge_types then do; auto_ctt.n_charge_types = i; auto_ctt.charge_types (i) = type_name; end; type_num = i; return; end normalize_charge_type; check_canon_proc: proc (canon_proc_name); dcl canon_proc_name char (*) aligned parameter; dcl cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry), entrypt entry variable; if canon_proc_name = "" then return; /* no canon proc */ entrypt = cv_entry_ (rtrim (canon_proc_name), null, code); /* if you give the poor dolt trailing blanks he has a breakdown */ if code = 0 then return; answer = "canonicalizer not found: " || canon_proc_name; goto rtdt_error; end check_canon_proc; /* Now consider all the new RTDE's that weren't in the old RTDT. This block of code also installs the first RTDT when there is no old RTDT. (which is a good trick, since the system won't come UP without an old rtdt...?!?) */ do upd_rtdep = pointer (upd_rtdt.first_resource, upd_rtdt.rtdt_area) repeat (pointer (upd_rtde.next_resource, upd_rtdt.rtdt_area)) while (upd_rtdep ^= null); if upd_rtde.valid then do; N_MATES = upd_rtde.n_mates; N_SUBTYPES = upd_rtde.n_subtypes; allocate new_rtde in (new_rtdt.rtdt_area); unspec (new_rtde) = unspec (upd_rtde); /* not completely right, but not bad for starters */ if ^new_rtde.is_synonym then do; /* don't waste time on syns */ if upd_rtdt.version = RTDT_version_3 then call check_canon_proc (upd_rtde.precanon_proc); call normalize_charge_type (upd_cttp -> charge_type_table.charge_types (upd_rtde.registration_defaults.charge_type), new_rtde.registration_defaults.charge_type); do i = 1 to upd_rtde.n_subtypes; call normalize_charge_type (upd_cttp -> charge_type_table.charge_types (upd_rtde.subtypes (i).charge_type), new_rtde.subtypes (i).charge_type); end; end; new_rtde.addition_pending = "1"b; new_rtde.next_resource = nullo; if last_rtdep = null then new_rtdt.first_resource = offset (new_rtdep, new_rtdt.rtdt_area); else last_rtdep -> rtde.next_resource = offset (new_rtdep, new_rtdt.rtdt_area); last_rtdep = new_rtdep; end; end; N_CHARGE_TYPES = auto_ctt.n_charge_types; allocate charge_type_table in (new_rtdt.rtdt_area); unspec (charge_type_table.charge_types) = unspec (auto_ctt.charge_types); new_rtdt.charge_type_table_ptr = offset (cttp, new_rtdt.rtdt_area); bitcount = binary (rel (addr (charge_type_table.flagword))) * 36; call hcs_$set_bc (instaldir, unique_name, bitcount, code); call hcs_$set_safety_sw (instaldir, unique_name, "1"b, code); call hcs_$set_ring_brackets (instaldir, unique_name, rtdt_rings, code); if no_prev_table then do; aclb (1).userid = get_group_id_ (); /* make up acl for newly-created RTDT */ aclb (1).mode = "101"b; /* RW */ aclb (syacn + 1).userid = "*.SysDaemon.*"; aclb (syacn + 1).mode = "100"b; aclb (syacn + 2).userid = "*.*.*"; aclb (syacn + 2).mode = "100"b; syacn = syacn + 2; call hcs_$replace_acl (instaldir, unique_name, addr (aclb), syacn, "1"b, code); end; else do; call hcs_$list_acl (instaldir, instalname, addr (acl_area), acl_ptr, null, acl_count, code); if code ^= 0 then do; answer = "cannot list ACL of current RTDT"; goto rtdt_error; end; call hcs_$replace_acl (instaldir, unique_name, acl_ptr, acl_count, ""b, code); if code ^= 0 then do; answer = "cannot set ACL of new RTDT"; goto rtdt_error; end; end; /* Now create the new databases if resource types have been added. */ do new_rtdep = pointer (new_rtdt.first_resource, new_rtdt.rtdt_area) repeat (pointer (new_rtde.next_resource, new_rtdt.rtdt_area)) while (new_rtdep ^= null); if new_rtde.addition_pending then do; if ^new_rtde.is_synonym then if ip -> installation_parms.rcp_init_flags.resource_mgmt_enabled then do; new_rtde.addition_pending = ""b; /* otherwise, fun when we later try to compare registry headers! */ call rcp_sys_$create_registry (registry_dir, new_rtdep, code); if code ^= 0 then do; call sys_log_$error_log (TYPE_AND_LOG_MSG_WITH_BANNER, code, "up_rtdt_", "Cannot create RCP registry for ^a", new_rtde.name); answer = "cannot create registry for " || new_rtde.name; goto rtdt_error; end; end; call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: Adding resource type ""^a"" to the system.", new_rtde.name); end; else do; if ^new_rtde.is_synonym then if ip -> installation_parms.rcp_init_flags.resource_mgmt_enabled then do; call rcp_sys_$update_registry_header (registry_dir, new_rtdep, code); if code ^= 0 then do; /* EXTREMELY unlikely */ call sys_log_$error_log (TYPE_AND_LOG_MSG_WITH_BANNER, code, "up_rtdt_", "Cannot update registry for ^a", new_rtde.name); answer = "cannot update registry for " || new_rtde.name; goto rtdt_error; end; end; end; end; /* Now, QuickAsABunny rename the old and new RTDTS, replacing them. */ if ^no_prev_table then do; call ioa_$rsnnl ("^a.-.^a", newname, 0, instalname, unique_name); call hcs_$chname_file (instaldir, instalname, instalname, newname, code); if code ^= 0 then do; call sys_log_$error_log (TYPE_AND_LOG_MSG_WITH_BANNER, code, "up_rtdt_", "Cannot rename old rtdt."); answer = "cannot rename old RTDT."; goto rtdt_error; end; end; call hcs_$chname_file (instaldir, unique_name, unique_name, instalname, code); if code ^= 0 then do; call sys_log_$error_log (TYPE_AND_LOG_MSG_WITH_BANNER, code, "up_rtdt_", "Cannot rename new rtdt."); answer = "cannot rename new RTDT."; if ^no_prev_table then do; call hcs_$chname_file (instaldir, newname, newname, instalname, code); if code ^= 0 then call sys_log_$error_log (TYPE_AND_LOG_MSG_WITH_BANNER, code, "up_rtdt_", "Cannot recover by renaming original RTDT either."); goto rtdt_error; end; end; /* Now that no one can reference the dead resources, if any, we can free their registries. */ if ^no_prev_table then do old_rtdep = pointer (old_rtdt.first_resource, old_rtdt.rtdt_area) repeat (pointer (old_rtde.next_resource, old_rtdt.rtdt_area)) while (old_rtdep ^= null); if old_rtde.deletion_pending then do; call sys_log_ (TYPE_AND_LOG_MSG, "up_rtdt_: Deleting resource type ""^a"" from the system.", old_rtde.name); if ^old_rtde.is_synonym then if ip -> installation_parms.rcp_init_flags.resource_mgmt_enabled then do; call rcp_sys_$remove_registry (registry_dir, old_rtde.name, code); if code ^= 0 then do; call sys_log_$error_log (TYPE_AND_LOG_MSG_WITH_BANNER, code, "up_rtdt_", "Unable to remove RCP registry for ^a.", old_rtde.name); goto rtdt_error; end; end; old_rtde.deletion_pending = ""b; end; /* deletion of a resource */ end; code = 0; instalp = old_rtdtp; /* ***** returning ptr to the old table seems useless, but all the other up_something_'s do it */ return; rtdt_error: code = error_table_$action_not_performed; /* RTDT not installed */ call clean_up; clean_up: proc; if delthru_ptr ^= null then do; call hcs_$set_safety_sw_seg (delthru_ptr, "0"b, 0); call hcs_$delentry_seg (delthru_ptr, 0); end; end clean_up; return; /* BEGIN MESSAGE DOCUMENTATION Message: up_rtdt_: ERROR_MESSAGE Cannot create RCP registry for RESOURCE_NAME. S: as (severity2) T: $run M: The error described by ERROR_MESSAGE occurred while a system administrator was attempting to install a new rtdt. The rtdt contained a new resource type, but the resource management registry for that resource type could not be created. The rtdt is not installed. Some other registries may already have been modified according to information in the new rtdt. A: Notify the system administrator. Message: up_rtdt_: ERROR_MESSAGE Cannot update RCP registry for RESOURCE_NAME. S: as (severity2) T: $run M: The error described by ERROR_MESSAGE occurred while a system administrator was attempting to install a new rtdt. The rtdt contained changes to a resource type, but the resource management registry for that resource type could not be modified. The rtdt is not installed. Some other registries may already have been modified according to information in the new rtdt. A: Notify the system administrator. Message: up_rtdt_: ERROR_MESSAGE Cannot rename old RTDT. S: as (severity2) T: $run M: The current rtdt could not be renamed to accomodate the installation of a new rtdt. A: Notify the system administrator. Message: up_rtdt_: ERROR_MESSAGE Cannot rename new rtdt. S: as (severity2) T: $run M: The new rtdt being installed could not be renamed to "rtdt". The rtdt is not installed. A: Notify the system administrator. Message: up_rtdt_: ERROR_MESSAGE Cannot recover by renaming old RTDT either. S: as (severity2) T: $run M: The program that installs rtdt's cannot recover correctly from an earlier error in renaming, for which an error message is also printed. Although the current rtdt is not destroyed, it is no longer accessible to users. This will affect the operation of resource management and RCP. A: Notify the system administrator. Message: up_rtdt_: Deleting resource type RESOURCE_TYPE from the system. S: as (severity1) T: $run M: The named resource type is no longer accessible by system users. This is an advisory message. A: None. Message: up_rtdt_: Adding resource type RESOURCE_TYPE to the system. S: as (severity1) T: $run M: The named resource type has been newly defined and will be accessible by system users. This is an advisory message. A: None. END MESSAGE DOCUMENTATION */ debug_rtdt_on: entry; debug_sw = "1"b; return; debug_rtdt_off: entry; debug_sw = ""b; return; %page; %include access_mode_values; %page; %include answer_table; %page; %include area_info; dcl 1 auto_area_info aligned automatic like area_info; %page; %include installation_parms; %page; %include user_table_header; %page; end up_rtdt_;  up_sat_.pl1 07/13/88 1141.1r w 07/13/88 0938.7 239796 /****^ *********************************************************** * * * 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 */ up_sat_: procedure (segp, wordcount, instaldir, instalname, instalp, P_ansp, ip, answer, code); /* UP_SAT_ - update the System Administrator's Table (SAT) This program checks a candidate SAT for acceptability before installing. If a new project has been created, and the project dir does not exist, this program creates it and sets up the access. Initially coded by Michael J. Spier, February 13, 1970 Modified 741030 by PG for authorizations, etc. Modified 750523 by PG to check for duplicate alias's. Modified May 1976 by T. Casey to update project cutoff data. Modified May 1978 by T. Casey to update pdir_quota. Modified June 1978 by T. Casey to add make_sat_hash entry point, implementing hash table for SAT. Modified November 1978 by T. Casey for MR7.0 absentee control parameters. Modified July, 1979 by J. N. R. Barnecut to implement multiple rate structures. (UNCA) Modified June, 1981 by E. N. Kittlitz for UNCA rate structures Modified November 1981, E. N. Kittlitz. user_table_entry conversion. Modified January 1982, BIM for author changes (lock and install time) Modified February 1982, E. N. Kittlitz. xxx.install.acs change. Modified May 1982, E. N. Kittlitz. to only check supplied sat live projects for duplicate names. Modified 1984-09-11 BIM for auth ranges. Modified: 10/05/84 by R. Michael Tague: up_sysctl_$check_acs now returns a bit (36) mode string instead of a fixed bin (5) and no longer takes a directory arg */ /****^ HISTORY COMMENTS: 1) change(86-06-05,GJohnson), approve(86-06-05,MCR7387), audit(86-06-10,Martinson), install(86-07-11,MR12.0-1092): Correct error message documentation. 2) change(86-09-05,Parisek): Check for existence of renamed project in new SAT and if found flag corresponding old SAT entry as renamed. This renamed state will become useful during billing procedures so duplicate bills are not produced. 3) change(87-04-26,GDixon), approve(87-07-13,MCR7741), audit(87-07-16,Hartogs): Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1 END HISTORY COMMENTS */ /* parameters */ dcl segp ptr; dcl wordcount fixed bin; dcl instaldir char (*); dcl instalname char (*); dcl instalp ptr; dcl P_ansp ptr; dcl ip ptr; dcl answer char (*); dcl code fixed bin (35); /* entries */ dcl aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl aim_check_$in_range entry (bit (72) aligned, (2) bit (72) aligned) returns (bit (1) aligned); dcl asu_$bump_code entry (ptr, fixed bin (35), char (8), fixed bin (35), fixed bin); dcl display_access_class_$range entry ((2) bit (72) aligned) returns (character (32) aligned); dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl display_access_class_ entry (bit (72) aligned) returns (character (32) aligned); dcl get_group_id_ entry () returns (char (32)); dcl get_process_id_ entry () returns (bit (36)); dcl hash_$in entry (ptr, char (*), fixed bin, fixed bin (35)); dcl hash_$make entry (ptr, fixed bin, fixed bin (35)); dcl hash_$opt_size entry (fixed bin) returns (fixed bin); dcl hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35)); dcl hcs_$set_safety_sw entry (char (*), char (*), bit (1) aligned, fixed bin (35)); /* SWS */ dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); dcl ioa_$rsnnl entry () options (variable); dcl sys_log_ entry options (variable); dcl sys_log_$error_log entry options (variable); dcl system_info_$max_rs_number entry (fixed bin); dcl up_sat_$make_sat_hash entry (ptr, fixed bin, ptr, char (*), fixed bin (35)); dcl up_sysctl_$check_acs entry (char (*), char (*), fixed bin, bit (36) aligned, fixed bin (35)); /* external static */ dcl as_error_table_$proj_auth_excludes fixed bin (35) static external; dcl as_error_table_$proj_deleted fixed bin (35) static external; dcl as_error_table_$proj_max fixed bin (35) static external; dcl error_table_$noentry ext fixed bin (35); /* automatic */ dcl access_ceiling bit (72) aligned; dcl auth_string char (32) aligned; dcl csc_long char (100) aligned; dcl csc_short char (8) aligned; dcl debg char (8); dcl do_attributes bit (1) aligned; dcl do_authorization bit (1) aligned; dcl htp ptr init (null); dcl i fixed bin; dcl j fixed bin; dcl jj fixed bin; dcl k fixed bin; dcl max_rs_number fixed bin; dcl maxprim fixed bin; dcl mode bit (36) aligned; dcl movelen fixed bin (24); dcl new_project bit (1) aligned; dcl newhtp ptr init (null); dcl offset bit (18) aligned; dcl old_auth_string char (32) aligned; dcl oldhtp ptr init (null); dcl p ptr; dcl procid bit (36) aligned; dcl q ptr; dcl satep ptr; dcl satp ptr; dcl sp ptr; dcl syj fixed bin; dcl tp ptr; dcl xp ptr; dcl 1 dir_acl (7) aligned, 2 userid char (32), 2 mode bit (36), 2 rcode fixed bin (35); dcl 1 sys_dir_acl (7) aligned, 2 userid char (32), 2 mode bit (36), 2 rcode fixed bin (35); /* internal static */ dcl acs_name char (32) int static options (constant) init ("sat.install.acs"); dcl system_low bit (72) aligned internal static initial (""b); dcl LEGAL char (95) int static init /* Printables except PAD, semicolon, but with BS */ (" !""#$%&'()*+,-./0123456789:<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~") options (constant); /* based */ dcl 1 movetable based aligned, 2 moveary (movelen) fixed bin (35); /* builtin */ dcl (addr, clock, fixed, index, null, rel, string, substr, unspec, verify) builtin; %page; ansp = P_ansp; call system_info_$max_rs_number (max_rs_number); procid = get_process_id_ (); if procid ^= anstbl.as_procid then return; /* privileged entrypoint */ do_authorization = segp -> sat.author.update_authorization; do_attributes = segp -> sat.author.update_attributes; access_ceiling = installation_parms.access_authorization_ceiling; new_project = "0"b; instalp = null; /* pre-set returned pointer */ instaldir = anstbl.sysdir; instalname = "sat"; if wordcount < 64 then do; /* make sure segment contains something */ answer = "wordcount < 64"; code = 10; return; end; if segp -> sat.version ^= SAT_version then do; /* Check right overlay dcl */ answer = "incorrect table version"; code = 9; return; end; if segp -> sat.current_size > segp -> sat.max_size then do; answer = "current_size > max_size"; code = 11; return; end; if segp -> sat.n_projects > segp -> sat.current_size then do; answer = "n_projects > current_size"; code = 12; return; end; offset = rel (addr (segp -> sat.project (segp -> sat.current_size + 1))); if fixed (offset, 18) - 1 > wordcount then do; answer = "size inconsistent with wordcount"; code = 13; return; end; call up_sysctl_$check_acs (acs_name, (segp -> sat.author.proc_group_id), -1, mode, code); if (code ^= 0) | ((mode & RW_ACCESS) ^= RW_ACCESS) then do; answer = "access violation"; code = 14; return; end; call hcs_$initiate (instaldir, instalname, "", 0, 0, sp, code); if sp = null then do; answer = "cannot initiate old SAT"; code = 15; return; end; if segp -> sat.uwt_size > 24 then do; answer = "uwt_size > 24"; code = 41; return; end; do i = 1 to segp -> sat.uwt_size; if verify (segp -> sat.uwt (i).initproc, LEGAL) ^= 0 then do; answer = "uwt.initproc not ASCII"; code = 16; return; end; j = segp -> sat.uwt (i).units; if ((j < 0) | (j > 100)) then do; answer = "uwt.units illegal value"; code = 41; return; end; end; if verify (segp -> sat.system_admin (1), LEGAL) ^= 0 then go to badsa; if verify (segp -> sat.system_admin (2), LEGAL) ^= 0 then do; badsa: answer = "system administrator not ASCII"; code = 16; return; end; maxprim = 0; do i = 1 to segp -> sat.current_size; p = addr (segp -> sat.project (i)); if p -> project.state < 0 then go to bast; /* Check entry state - filters junk */ if p -> project.state > 3 then do; /* Installing state 0 or 2 is ignored */ bast: answer = "illegal entry state value"; code = 17; return; end; if verify (p -> project.project_id, LEGAL) ^= 0 then do; answer = "project_id not ASCII"; code = 16; return; end; if p -> project.state = 1 then /* only check if it's live */ do j = 1 to i - 1; q = addr (segp -> sat.project (j)); if q -> project.state = 1 then do; /* only check if it's live */ if q -> project.project_id = p -> project.project_id then do; answer = "duplicate project " || p -> project.project_id; code = 42; return; end; if q -> project.alias ^= "" /* ignore blank aliases */ then if q -> project.alias = p -> project.alias then do; answer = "duplicate alias " || p -> project.alias; code = 42; return; end; end; end; if p -> project.state > 0 then do; if verify (p -> project.project_dir, LEGAL) ^= 0 then do; answer = "project_dir not ASCII " || p -> project.project_id; code = 16; return; end; if ^aim_check_$greater_or_equal (access_ceiling, p -> project.project_authorization (2)) then do; answer = "authorization > access_ceiling"; code = 18; end; if p -> project.rs_number ^= 0 then do; if p -> project.rs_number > max_rs_number then do; answer = "bad rate_structure number " || p -> project.project_id; code = 44; return; end; end; end; p -> project.at.nopreempt = "1"b; maxprim = maxprim + p -> project.max_users; end; /* Individual items in proposed SAT look ok. Now build new SAT by merging old and new. Since user pointers to SAT entries are kept, must not change order. */ call hcs_$make_seg (instaldir, "", "", 1011b, tp, code); if tp = null then do; call sys_log_$error_log (2, code, "up_sat_", "cannot make temp"); return; end; movelen = SAT_header_lth + sp -> sat.current_size * SAT_entry_lth; tp -> movetable = sp -> movetable; /* Shlup */ /* copy header of new sat over old sat header. */ tp -> sat.author.lock = ""b; tp -> sat.author.last_install_time = clock (); tp -> sat.author.proc_group_id = segp -> sat.author.proc_group_id; tp -> sat.author.table = segp -> sat.author.table; tp -> sat.author.w_dir = segp -> sat.author.w_dir; if do_attributes then do; tp -> sat.max_size = segp -> sat.max_size; tp -> sat.max_units = segp -> sat.max_units; tp -> sat.uwt_size = segp -> sat.uwt_size; do j = 1 to tp -> sat.uwt_size; tp -> sat.uwt.initproc (j) = segp -> sat.uwt.initproc (j); tp -> sat.uwt.units (j) = segp -> sat.uwt.units (j); end; tp -> sat.system_admin (1) = segp -> sat.system_admin (1); tp -> sat.system_admin (2) = segp -> sat.system_admin (2); end; tp -> sat.n_projects = 0; /* will recompute (note use old val of freep) */ tp -> sat.version = SAT_version; do i = 1 to tp -> sat.current_size; /* search old SAT for projects not in new */ p = addr (tp -> sat.project (i)); if p -> project.state = 0 then go to x1; /* ignore free entries in old sat */ p -> project.state = 2; do j = i to segp -> sat.current_size, 1 to i - 1; q = addr (segp -> sat.project (j)); if q -> project.state = 1 | q -> project.state = 3 then /* Ignore any non-state-1&3 entries in new copy */ if p -> project.project_id = q -> project.project_id then do; if q -> project.state = 3 then do; p -> project.state = 3; /* Flag renamed project in old SAT */ go to rnp; end; p -> project.state = 1; /* Old project, still in new version */ tp -> sat.n_projects = tp -> sat.n_projects + 1; q -> project.state = -1; /* so not check again */ if do_authorization then if unspec (p -> project.project_authorization) ^= unspec (q -> project.project_authorization) then do; auth_string = display_access_class_$range (q -> project.project_authorization); old_auth_string = display_access_class_$range (p -> project.project_authorization); call sys_log_ (0, "up_sat_: changing authorization of ^a project from ^a to ^a", p -> project.project_id, old_auth_string, auth_string); end; call copy; /* have now merged new values into entry. if project.max_users changed, proj may be over max users */ k = p -> project.n_users - p -> project.max_users; do jj = 1 to anstbl.current_size; utep = addr (anstbl.entry (jj)); if ute.active >= NOW_LOGGED_IN then if ute.project = p -> project.project_id then do; if ute.at.nobump = "0"b then do; if k <= 0 then go to sak; k = k - 1; if ute.preempted ^= 0 then go to sak; call sys_log_ (1, "up_sat_: bumping ^a.^a, over max users on project", ute.person, ute.project); call asu_$bump_code (utep, as_error_table_$proj_max, debg, code, (installation_parms.warning_time)); sak: end; if ^aim_check_$in_range (ute.process_authorization_range (1), p -> project.project_authorization) | ^aim_check_$in_range (ute.process_authorization_range (2), p -> project.project_authorization) then do; call sys_log_ (1, "up_sat_: bumping ^a.^a, project authorization ^a now excludes user authorization ^a.", ute.person, ute.project, display_access_class_$range (p -> project.project_authorization), display_access_class_ (ute.process_authorization)); call asu_$bump_code (utep, as_error_table_$proj_auth_excludes, debg, code, (0)); end; end; end; go to x1; end; end; /* Project in old sat does not exist in new sat. May bump all users */ rnp: if ^do_attributes then go to cant_add_or_delete_proj; if p -> project.project_id = "SysAdmin" then go to eek; if p -> project.project_id = "SysDaemon" then do; eek: answer = "Attempt to delete project " || p -> project.project_id; code = 14; return; end; do jj = 1 to anstbl.current_size; /* scan answer table for users on deleted proj */ utep = addr (anstbl.entry (jj)); if ute.active >= NOW_LOGGED_IN then if ute.project = p -> project.project_id then do; call sys_log_ (1, "up_sat_: bumping ^a.^a, project deleted.", ute.person, ute.project); call asu_$bump_code (utep, as_error_table_$proj_deleted, debg, code, (installation_parms.warning_time)); end; end; x1: end; do i = 1 to 7; sys_dir_acl (i).mode, dir_acl (i).mode = "111"b; /* SMA */ end; do syj = 1 to 2; /* set up ACL for system admin. */ if tp -> sat.system_admin (syj) = " " then go to set_acl1; k = index (tp -> sat.system_admin (syj), " "); sys_dir_acl (syj).userid = (substr (tp -> sat.system_admin (syj), 1, k - 1) || ".*"); end; syj = 3; set_acl1: sys_dir_acl (syj).userid = get_group_id_ (); /* Now scan new sat for any entries which were not matched in old sat. These are new projects */ do i = 1 to segp -> sat.current_size; q = addr (segp -> sat.project (i)); if q -> project.state = 1 then do; /* this is a new project */ if ^do_attributes then go to cant_add_or_delete_proj; tp -> sat.n_projects = tp -> sat.n_projects + 1; badx: j = tp -> sat.freep; /* allocate new SAT entry */ if j = 0 then j, tp -> sat.current_size = tp -> sat.current_size + 1; else do; xp = addr (tp -> sat.project (j)); if xp -> project.state ^= 0 then do; call sys_log_ (2, "up_sat_: project ^a on free list state nonzero", xp -> project.project_id); tp -> sat.freep = 0; go to badx; end; tp -> sat.freep = xp -> project.chain; end; p = addr (tp -> sat.project (j)); p -> project.state = 1; /* new proj */ p -> project.project_id = q -> project.project_id; call copy; if ^do_authorization then do; p -> project.project_authorization = system_low; p -> project.audit = ""b; end; if (p -> project.project_authorization (1) | p -> project_authorization (2)) ^= system_low then do; auth_string = display_access_class_$range (p -> project.project_authorization); call sys_log_ (0, "up_sat_: adding ^a project with authorization ^a", p -> project.project_id, auth_string); end; p -> project.pdt_ptr = null; p -> project.n_users = 0; end; end; instalp = sp; call hcs_$delentry_seg (segp, code); segp = tp; /* Make a new hash table for the SAT. The old one is mostly still valid, since no project entries have been moved. The new hash table will only reflect added and deleted projects, and changed aliases. */ call hcs_$make_seg (instaldir, "sat.ht.temp", "", 1011b, newhtp, code); if newhtp = null then do; answer = "unable to get segment for new SAT hash table"; call sys_log_$error_log (2, code, "up_sat_", "sat.ht.temp"); code = 33; /* any old nonzero code will do */ return; /* We have not replaced the SAT yet. We won't */ end; call up_sat_$make_sat_hash (segp, segp -> sat.n_projects, newhtp, answer, code); if code ^= 0 then do; call hcs_$delentry_seg (newhtp, (0)); return; end; /* Now replace the SAT */ wordcount = SAT_header_lth + tp -> sat.current_size * SAT_entry_lth; movelen = wordcount; sp -> movetable = segp -> movetable; /* Copy new SAT over old one fast. */ call hcs_$set_bc (instaldir, instalname, 36 * wordcount, code); call hcs_$set_safety_sw (instaldir, instalname, "1"b, code); /* Now replace the hash table. Recall that the old one is mostly good, so if anything goes wrong, it is not a disaster */ call hcs_$initiate (instaldir, "sat.ht", "", 0, 1, oldhtp, code); if oldhtp = null then do; /* can't initiate it - either not there or something wrong */ if code ^= error_table_$noentry then goto unab; call hcs_$chname_file (instaldir, "sat.ht.temp", "sat.ht.temp", "sat.ht", code); if code ^= 0 then goto unab; end; else do; /* can initiate sat.ht */ call hcs_$truncate_seg (oldhtp, (0), code); if code ^= 0 then do; unab: call sys_log_$error_log (2, code, "up_sat_", "sat.ht"); answer = "unable to replace old SAT hash table"; code = 33; /* any nonzero code is ok */ return; end; movelen = newhtp -> htable.loht; oldhtp -> movetable = newhtp -> movetable; /* copy new hash table over old */ call hcs_$delentry_seg (newhtp, (0)); /* delete temp new hash table */ end; call hcs_$set_bc (instaldir, "sat.ht", 36 * movelen, (0)); call hcs_$set_safety_sw (instaldir, "sat.ht", "1"b, (0)); /* do not change the acl of sat.ht */ code = 0; return; no_dir: answer = "cannot create project directory"; code = 43; return; cant_add_or_delete_proj: answer = "not allowed to add/delete project"; code = 44; return; /* internal procedure to copy sat entry pointed to by q into that pointed to by p */ copy: proc; if do_authorization then do; p -> project.project_authorization = q -> project.project_authorization; p -> project.audit = q -> project.audit; end; if ^do_attributes then return; p -> project.project_dir = q -> project.project_dir; p -> project.max_users = q -> project.max_users; string (p -> project.at) = string (q -> project.at); p -> project.admin (1).userid = q -> project.admin (1).userid; p -> project.admin (2).userid = q -> project.admin (2).userid; p -> project.admin (3).userid = q -> project.admin (3).userid; p -> project.admin (4).userid = q -> project.admin (4).userid; p -> project.cutoff = q -> project.cutoff; p -> project.min_ring = q -> project.min_ring; p -> project.max_ring = q -> project.max_ring; p -> project.pdir_quota = q -> project.pdir_quota; p -> project.alias = q -> project.alias; p -> project.group = q -> project.group; p -> project.groups (1) = q -> project.groups (1); p -> project.groups (2) = q -> project.groups (2); p -> project.days_to_cutoff = q -> project.days_to_cutoff; p -> project.pct_balance = q -> project.pct_balance; p -> project.dollars_to_cutoff = q -> project.dollars_to_cutoff; p -> project.grace_max = q -> project.grace_max; p -> project.max_foreground = q -> project.max_foreground; p -> project.max_background = q -> project.max_background; p -> project.abs_foreground_cpu_limit = q -> project.abs_foreground_cpu_limit; p -> project.rs_number = q -> project.rs_number; end copy; make_sat_hash: entry (segp, n_entries, dhtp, an, co); /* This entry point builds a hash table for the SAT. It is called from above, and also by lg_ctl_ if the hash table is missing at startup time or appears to be garbaged when someone is trying to log in. Since it is an entry point, and not an internal procedure, it gets a new stack frame when called from above, and the only variables that have good values in them are the ones in the argument list. */ /* segp is the first argument in the main entry point's arg list, and is declared above. It is a pointer to the SAT for which we are building the hash table. */ dcl dhtp ptr; /* ptr to seg in which ht to be built */ dcl n_entries fixed bin; /* initial number of entries */ dcl an char (*); /* if error, this is msg explaining what happened */ dcl co fixed bin (35); /* error code */ call hash_$make (dhtp, hash_$opt_size (n_entries), co); if co ^= 0 then do; an = "too many buckets in hash table"; return; end; satp = segp; /* avoid the need for lots of segp ->'s */ do i = 1 to sat.current_size; /* look at all entries */ satep = addr (sat.project (i)); /* avoid more ->'s */ if project.state = 1 then do; /* only put real projects in the hash table */ call hash_$in (dhtp, project.project_id, i, co); if co ^= 0 then do; call convert_status_code_ (co, csc_short, csc_long); call ioa_$rsnnl ("Hash table error for project ^a. ^a", an, (0), project.project_id, csc_long); return; end; if project.alias ^= "" then do; /* put aliases in hash table, too */ call hash_$in (dhtp, project.alias, i, co); if co ^= 0 then do; call convert_status_code_ (co, csc_short, csc_long); call ioa_$rsnnl ("Hash table error for alias ^a. ^a", an, (0), project.project_id, csc_long); return; end; end; end; end; co = 0; return; %page; %include access_mode_values; %page; %include answer_table; %page; %include dialup_values; %page; %include hashst; %page; %include installation_parms; %page; %include sat; %page; %include user_attributes; %page; %include user_table_entry; %page; %include user_table_header; %page; /* BEGIN MESSAGE DOCUMENTATION Message: up_sat_: adding PROJ project with authorization AUTH S: as (severity0) T: $run M: A system security administrator has added the project PROJ with an authorization greater than system low. A: $ignore Message: up_sat_: bumping NAME.PROJ, project authorization reduced S: as (severity1) T: $run M: A system security administrator has installed a new SAT that reduces the authorization for the user identified by NAME on the project PROJ below the current value assigned to this project. Therefore, the user is being bumped from the system. A: $ignore Message: up_sat_: bumping NAME.PROJ, project deleted S: as (severity1) T: $run M: The system administrator has deleted the project PROJ. All of its users are bumped. A: $ignore Message: up_sat_: bumping NAME.PROJ, over max users on project S: as (severity1) T: $run M: The user named has been bumped because the system administrator has reduced the maximum number of users that can be logged in on the project PROJ. A: $ignore Message: up_sat_: changing authorization of PROJ project from OLD to NEW S: as (severity0) T: $run M: A system security administrator has installed a new SAT that changes the authorization of the project PROJ. OLD is the previous authorization for the project; NEW is the authorization now assigned to the project. A: $ignore Message: up_sat_: ERROR_MESSAGE. cannot make temp S: as (severity1) T: $run M: A temporary segment could not be created while attempting to install a new system administrator's table. The system attempts to proceed. A: $inform Message: up_sat_: ERROR_MESSAGE. sat.ht.temp S: as (severity2) T: $run M: A temporary segment could not be created while attempting to build a hash table for a new system administrator's table (SAT). The new SAT has been installed, but the old hash table is still in use, so any new projects are unusable. A: $inform Message: up_sat_: ERROR_MESSAGE. sat.ht S: as (severity2) T: $run M: The system was unable to replace the SAT hash table, during installation of a new SAT. The new SAT has been installed, but the old hash table is still in use, so any new projects are unusable. A: $inform Message: up_sat_: project PROJ on free list state nonzero S: as (severity2) T: $run M: The free chain for the SAT seems to include a project that does not have state zero. The system abandons the free chain and attempts to proceed. A: $inform_sa END MESSAGE DOCUMENTATION */ end up_sat_;  up_sysctl_.pl1 07/13/88 1141.1r w 07/13/88 0938.7 271764 /****^ *********************************************************** * * * 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 */ up_sysctl_: procedure (bv_msg_ptr); /* Update System Control = Event-call driven proc which executes as part of the answering service in the system control process. It is invoked by an event signal indicating that installation of a system table is requested. It locates the appropriate table in a special directory whose name is "update" and which is appended to the current system directory (i.e., sysdir || ">update"), and after proper validation installs the table in its appropriate place. Initially coded by Michael J. Spier, February 13, 1970 Revised 10/70 THVV Modified 6/72 to give project administrators access to their PDT. J. Phillipps Modified 741029 by PG to handle authorization-only updates, etc. Modified 760804 by THVV for sending mail Modified 03/16/78 by C. D. Tavares to add up_rtdt_ Modified May 1978 by T. Casey to lengthen answer from up_xxx_ and print it if nonblank, even for successful installs. Modified 25 Sept 1979 by T. Casey to make max installs settable and to log all wakeups. Modified March 1980 by T. Casey to add metering. Modified June 1981 by T. Casey for MR9.0 to do only one install per wakeup. Modified July 1981 by E. N. Kittlitz for better proj_admin_seg error handling. Modified November 1981, E. N. Kittlitz. user_table_entry conversion. Modified December 1981, E. N. Kittlitz. eliminate proj_admin_seg by publishing IPC channel in whotab. Modified December 1981 B. I. Margulies to eliminate ttt installations. Modified February 1982, E. N. Kittlitz. part of the xxx.install.acs changes. Modified April 1982, E. N. Kittlitz. set ring brackets on the segment. Modified May 1982, E. N. Kittlitz. New AS initialization. Modified: 10/05/84 by R. Michael Tague: Changed $check_acs to use as_data_$acsdir as the containing directory for the ACS segments and to return a bit (36) mode value instead of fixed bin (5). Modified 1984-10-09 BIM to fix above to return standard bit(36) modes. Modified 1985-04-19 E. Swenson to fix any_other handler. */ /****^ HISTORY COMMENTS: 1) change(86-06-05,GJohnson), approve(86-06-05,MCR7387), audit(86-06-10,Martinson), install(86-07-11,MR12.0-1092): Correct error message documentation. 2) change(87-04-26,GDixon), approve(87-07-13,MCR7741), audit(87-07-16,Hartogs), install(87-08-04,MR12.1-1055): Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1 END HISTORY COMMENTS */ /* NOTE NOTE NOTE: this program depends on star_ returning things in the order they were appended to the directory. This should be changed. The wakeup from the user should contain the UID of the segment, and there should be some protection for lost wakeups. --enk */ /* parameters */ declare bv_msg_ptr ptr parameter; /* entries */ dcl (as_meter_$enter, as_meter_$exit) entry (fixed bin); dcl asu_$find_process entry (bit (36) aligned, fixed bin, ptr); dcl sys_log_$error_log entry options (variable); dcl condition_ entry (char (*), entry); dcl reversion_ entry (char (*)); dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl freen_ entry (ptr); /* subr. to release storage allocated by star */ dcl get_group_id_ entry () returns (char (32)); /* returns my access name */ dcl get_process_id_ entry () returns (bit (36)); /* returns my processid */ dcl as_dump_ entry (char (*) aligned); dcl get_system_free_area_ entry (ptr); dcl sys_log_ entry options (variable); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl ios_$order entry (char (*) aligned, char (*) aligned, ptr, bit (72) aligned); dcl ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$decl_ev_call_chn entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35)); dcl ipc_$drain_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$mask_ev_calls entry (fixed bin (35)); /* keeps stuff from happening */ dcl ipc_$unmask_ev_calls entry (fixed bin (35)); /* lets it happen again */ dcl (up_pdt_, up_sat_, up_mgt_, up_cdt_, up_rtdt_) entry (ptr, fixed bin, char (*), char (*), ptr, ptr, ptr, char (*), fixed bin (35)); dcl hcs_$replace_acl entry (char (*), char (*), ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); dcl hcs_$get_access_class entry (char (*), char (*), bit (72), fixed bin (35)); dcl hcs_$get_author entry (char (*), char (*), fixed bin, char (*) aligned, fixed bin (35)); dcl hcs_$get_user_access_modes entry (char (*), char (*), char (*), fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl hcs_$wakeup entry (bit (*) aligned, fixed bin (71), fixed bin (71), fixed bin (35)); dcl hphcs_$set_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl send_mail_$access_class entry (char (*), char (*), ptr, bit (72), fixed bin (35)); dcl (addr, clock, divide, fixed, length, null, rtrim, substr, unspec) builtin; /* DECLARATION OF EXTERNAL STATIC VARIABLES */ dcl error_table_$messages_deferred fixed bin (35) ext; dcl error_table_$messages_off fixed bin (35) ext; /* DECLARATION OF INTERNAL STATIC VARIABLES */ dcl areap ptr init (null); dcl maildir char (168) int static; /* name of update dir */ dcl 1 acla (1) int static aligned, /* Handy canned ACL: 1st element is for sysctl */ 2 userid char (32), /* (my name) */ 2 mode bit (36), 2 rpad bit (36) init ("0"b), 2 rcode fixed bin (35); dcl ring_brackets (3) fixed bin (3) int static init (7, 7, 7) options (constant); /* DECLARATION OF AUTOMATIC STORAGE VARIABLES */ dcl idir char (168); /* Not used. */ dcl iname char (32); /* Name of table installed. */ dcl update_program variable entry (ptr, fixed bin, char (*), char (*), ptr, ptr, ptr, char (*), fixed bin (35)); dcl (i, j, k, n_branches, wordcount) fixed bin; dcl code fixed bin (35); dcl bitcount fixed bin (24), type fixed bin (2); dcl short char (8) aligned, long char (100) aligned; dcl message char (200); dcl failed bit (1) init ("1"b); dcl hisid char (32) aligned; /* author of table */ dcl (iptr, bptr, nptr) ptr; /* ptrs */ dcl segp ptr; /* ptr to segment. */ dcl mailseg char (32); /* always "**" */ dcl status bit (72) aligned; /* IOS status */ dcl his_auth bit (72); /* Sender access class */ dcl name char (4) aligned; /* kind of table (PDT, etc) */ dcl answer char (160) init (""); /* result from installer */ dcl n_installs fixed bin; dcl deferred bit (1) aligned; dcl wakeup_msg char (8); /* copy of message in wakeup data */ dcl (n_deferred, n_pending) fixed bin; /* counters for defered and pending installs */ /* based */ declare 1 event based (bv_msg_ptr) aligned, 2 event_channel fixed bin (71), 2 event_message fixed bin (71), 2 sending_process_id bit (36), 2 device_signal bit (18) unaligned, 2 sending_ring bit (18) unaligned, 2 data_ptr ptr; declare event_string char (8) based (addr (event.event_message)); dcl 1 branch (20) based (bptr) aligned, /* structure returned by star */ (2 type bit (2), /* segment type */ 2 nname bit (16), /* number of names */ 2 nindex bit (18)) unaligned; /* index of first */ dcl names (30) char (32) aligned based (nptr); /* names returned by star */ dcl 1 tbl aligned based (segp), /* dummy declaration of table */ %include author; 2 dummy; %page; if ^sc_stat_$Multics then return; /* not initialized */ ansp = as_data_$ansp; anstbl.current_time = clock (); call as_meter_$enter (INSTALL_METER); call ipc_$mask_ev_calls (code); /* no recursive updating */ /* See what kind of wakeup we got */ if event.event_message = 0 then /* the install command presently sends a zero message */ wakeup_msg = "install"; /* pretend it can speak English */ else wakeup_msg = event_string; /* copy real message using char overlay */ /* We can't do an install when the anstbl is locked - we might be replacing a table out from under dialup_ */ if anstbl.lock_count > 0 then do; /* are we busy? */ anstbl.update_pending = "1"b; /* someone is logging in. we'll get back to this */ call sys_log_ (sv, "up_sysctl_: ^a wakeup with anstbl locked", wakeup_msg); go to unmask_return; /* but give up for now */ end; else anstbl.update_pending = "0"b; /* clear pending flag. */ /* Initialize a few variables. */ unspec (send_mail_info) = "0"b; send_mail_info.version = 1; send_mail_info.wakeup = "1"b; send_mail_info.always_add = "1"b; send_mail_info.sent_from = "install"; mailseg = "**"; /* set up name of update dir & look for anything */ call get_system_free_area_ (areap); bptr, nptr = null; /* Before listing the update directory, we'll drain the event channel. That way, we won't lose wakeups that arrive after we have started processing. */ call ipc_$drain_chn (anstbl.update_channel, code); if code ^= 0 then do; call convert_ipc_code_ (code); /* it better not say "there were none" */ call sys_log_$error_log (1, code, "up_sysctl_", "draining update channel."); end; /* what else can we do but go on? */ /* List the update directory. All segments in it are tables to be installed. */ call hcs_$star_ (maildir, mailseg, 10b, areap, n_branches, bptr, nptr, code); if code ^= 0 then n_branches = 0; /* if directory empty, false alarm */ if n_branches = 0 | sv > 0 then do; /* if it is empty, or we're in debug mode, log the wakeup */ if n_branches = 0 then /* log potential harrassment */ call asu_$find_process (event.sending_process_id, (0), utep); else utep = null; if utep = null then call sys_log_ (sv, "up_sysctl_: ^a wakeup with ^d installs pending", wakeup_msg, n_branches); else call sys_log_ (sv, "up_sysctl_: ^a wakeup from ^a.^a with ^d installs pending", wakeup_msg, ute.person, ute.project, n_branches); end; if n_branches = 0 then goto update_return; /* quit if nothing to do */ n_deferred, n_pending = 0; /* clear counters */ n_installs = 0; /* we'll count installs against our limit per wakeup */ /* Since we're not going to try to do all the installs at once, we want to take them in the order in which they were requested - oldest first. hcs_$star returns them in that order. */ do i = 1 to n_branches; /* go thru entries in update directory */ j = fixed (branch (i).nindex, 17); /* where's a name? */ mailseg = names (j); /* what's in a name? */ call condition_ ("any_other", ucs); /* Set up a handler in case of a fault. */ call hphcs_$set_ring_brackets (maildir, mailseg, ring_brackets, code); /* try to get it. ignore failure */ call hcs_$replace_acl (maildir, mailseg, addr (acla), 1, "0"b, code); if code ^= 0 then go to try_next; /* make sure nobody has access to segment */ failed = "1"b; deferred = ""b; idir, iname, answer = " "; /* clear args to update proc */ /* Initiate the table to be installed. */ call hcs_$initiate_count (maildir, mailseg, "", bitcount, 0, segp, code); if segp ^= null then do; /* segment must be there... */ wordcount = divide (bitcount + 35, 36, 17, 0); name = tbl.author.table; /* obtain kind of segment */ /* Check author's ID and acces class. */ call hcs_$get_access_class (maildir, mailseg, his_auth, code); if code ^= 0 then go to flop; call hcs_$get_author (maildir, mailseg, 1, hisid, code); if code ^= 0 then go to flop; /* obtain true author of seg. */ if tbl.author.proc_group_id ^= hisid then do; answer = "userid should be " || tbl.author.proc_group_id; go to signal; end; /* See what kind of table it is. */ if name = "SAT " then update_program = up_sat_; else if name = "PDT " then update_program = up_pdt_; else if name = "MGT " then update_program = up_mgt_; else if name = "CDT " then update_program = up_cdt_; else if name = "RTDT" then update_program = up_rtdt_; else do; /* Unknown table type. */ answer = "Invalid table type " || name; go to signal; end; /* Check for installs (all or PDT) suspended */ if max_installs = 0 | (name = "PDT" & NO_PDT_sw) then do; /* if this one must be deferred */ if tbl.author.deferral_notified then do; /* if we already notified then do; the installer */ n_deferred = n_deferred + 1; /* count defered installs for later message to operator */ goto try_next; /* go see if there is anything else to do */ end; deferred = "1"b; /* tell following code we deferred this one */ goto signal; /* go build message saying what happened */ end; /* We're going to try to install this one. Trying takes as much time, whether it succeeds or fails, so we'll count the attempt against our limit of installs per wakeup */ n_installs = n_installs + 1; /* Here's where we actually do the install. */ call update_program (segp, wordcount, idir, iname, iptr, ansp, ip, answer, code); /* Now, see how it turned out */ flop: if code = 0 then failed = "0"b; else do; /* Otherwise, fuss. */ if answer = "" then do; /* See if can be explained. */ call convert_status_code_ (code, short, long); answer = long; end; end; signal: call reversion_ ("any_other"); /* Build a message saying what we did. */ if iname = "" then iname = name; /* Make name of segment */ if deferred then do; /* if we deferred it, say that */ call ioa_$rsnnl ("Installation of ^a for ^a deferred;", message, j, iname, hisid); tbl.author.deferral_notified = "1"b; /* remember that we notified the installer */ n_deferred = n_deferred + 1; /* count deferred installs for later message to operator */ end; else if failed then /* or if there was an error, say that */ call ioa_$rsnnl ("Unable to install ^a for ^a. ^a", message, j, iname, hisid, answer); else /* or if we succeeded, say that */ call ioa_$rsnnl ("Installed ^a for ^a^[^;^x^a^].", message, j, iname, hisid, (answer = ""), answer); /* a successful install can sometimes produce a warning message */ /* Tell the operator what we did. */ n_pending = n_branches - i + n_deferred;/* # not looked at + # deferred */ call sys_log_ (1, "up_sysctl_: ^a^[^x(^d pending)^]", message, (n_pending > 0), n_pending); /* Tell the installer what we did. */ k = length (rtrim (hisid)) - 2; /* length of "Person.Project" without the ".a" */ call send_mail_to_installer; if code ^= 0 & code ^= error_table_$messages_off & code ^= error_table_$messages_deferred then call sys_log_$error_log (0, code, "up_sysctl_", "unable to notify ^a of installation of ^a", hisid, iname); /* If we deferred his install, send him an additional explanatory message. (It's pointless to repeatedly print the explanation as part of the operator message.) If we got a serious error sending the first message, we won't bother sending the second one. */ else /* if we did not get a serious error sending the first message */ if deferred then do; /* and it was deferred, send the second message */ call ioa_$rsnnl ("^[all^;PDT^] installs are suspended - please do not re-issue install command.", message, j, (max_installs = 0)); call send_mail_to_installer; end; /* Delete the table from the update directory */ if ^deferred then /* unless we deferred this installation */ call hcs_$delentry_seg (segp, code); /* delete the segment */ end; /* end segment successfully initiated */ try_next: if n_installs >= max_installs then /* if we have installed our limit */ if max_installs > 0 then /* (and the limit isn't zero) */ goto more_later; /* get out of the loop for now */ end; /* end loop thru entries in update directory */ more_later: if i < n_branches then /* if we had not gotten to the last entry */ call send_upsysctl_wakeup; /* send ourselves a wakeup, to do the rest later */ else /* if we aren't coming back for a while */ if n_deferred > 0 then /* if there are deferred installs, nag a little */ call sys_log_ (1, "up_sysctl_: ^[all^;PDT^] installs are suspended; ^d pending", (max_installs = 0), n_deferred); update_return: if bptr ^= null then call freen_ (bptr); /* clean up free storage */ if nptr ^= null then call freen_ (nptr); /* ... */ unmask_return: code = 0; /* get unmasked */ do i = 1 to 100 while (code = 0); /* .. so more logins can go */ call ipc_$unmask_ev_calls (code); /* .. */ if i > 1 then if code = 0 then call ioa_ ("up_sysctl_: error - event calls were masked"); end; call as_meter_$exit (INSTALL_METER); return; /* all done. */ /* We transfer to this label if an unclaimed signal occurs */ cleanup: if segp ^= null then do; /* do we have a user segment? */ if answer = "" then answer = "fault"; go to signal; /* tell him we couldn't */ end; else go to update_return; /* no segment, just give up */ send_mail_to_installer: proc; call send_mail_$access_class (substr (hisid, 1, k), substr (message, 1, j), addr (send_mail_info), his_auth, code); return; end send_mail_to_installer; send_upsysctl_wakeup: proc; /* to send ourselves a wakeup to keep installs going */ dcl upsysctl_msg fixed bin (71) aligned; /* argument to hcs_$send_wakeup */ dcl upsysctl_string char (8) based (addr (upsysctl_msg)); /* overlay to store chars in it */ upsysctl_string = "upsysctl"; call hcs_$wakeup (anstbl.as_procid, anstbl.update_channel, upsysctl_msg, code); if code ^= 0 then call sys_log_$error_log (1, code, "up_sysctl", "Sending upsysctl wakeup"); return; end send_upsysctl_wakeup; set_max_installs: entry; /* FOR EMERGENCY USE ONLY */ dcl cu_$arg_count entry returns (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl argp ptr, argl fixed bin, arg char (argl) based (argp); dcl (argno, nargs) fixed bin; dcl cv_dec_check_ entry (char (*) aligned, fixed bin (35)) returns (fixed bin (35)); dcl max_installs fixed bin int static init (1); /* default is 1 install per wakeup; zero shuts off all installs */ dcl NO_PDT_sw bit (1) aligned int static init (""b); /* "1"b shuts off just PDT installs */ dcl sv fixed bin int static init (0); /* severity of log messages */ nargs = cu_$arg_count (); if nargs = 0 then call sys_log_ (-1, "USAGE: set_max_installs 0|1|-pdt_off|-pdt_on| -loud|-quiet"); else do argno = 1 to nargs; /* go thru all arguments */ call cu_$arg_ptr (argno, argp, argl, code); /* look at next argument */ if arg = "-pdt_off" then /* in desperate situations */ NO_PDT_sw = "1"b; /* administrator can shut off PDT installs */ else if arg = "-pdt_on" then do; /* hopefully he remembers to turn them back on */ if NO_PDT_sw then /* if we're actually turning them back on */ call send_upsysctl_wakeup; /* send ourselves a wakeup to get them started */ NO_PDT_sw = ""b; end; else if arg = "-loud" then sv = 1; /* for debugging */ else if arg = "-quiet" then sv = 0; /* back to normal */ else do; /* must be a number */ i = cv_dec_check_ ((arg), code); if (code ^= 0) | (i < 0) | (i > 1) then call sys_log_ (-1, "set_max_installs: ^a is not 0 or 1", arg); else do; if max_installs = 0 & i = 1 then /* if we're actually turning installs back on */ call send_upsysctl_wakeup; /* send ourselves a wakeup to get them started */ max_installs = i; end; /* end it is 0 or 1 */ end; /* end must be a number */ end; /* end loop thru arguments */ return; %page; /* Procedure which is called by "signal_" if any unclaimed fault comes up. */ ucs: proc (mc_ptr, condition, crawlout, infoptr, contin); dcl mc_ptr ptr parameter; dcl condition char (*) parameter; dcl crawlout ptr parameter; dcl infoptr ptr parameter; dcl contin bit (1) parameter; dcl mbuf char (120) aligned, mlth fixed bin; dcl non_local_exit bit (1); dcl as_check_condition_ entry (char (*), bit (1), bit (1)); call as_check_condition_ (condition, contin, non_local_exit); if contin | non_local_exit then return; if iname ^= " " then do; /* we know what we were doing at fault time */ call ioa_$rsnnl ("up_sysctl_: ^a installing ^a for ^a", mbuf, mlth, condition, iname, tbl.author.proc_group_id); end; else call ioa_$rsnnl ("up_sysctl_: Error ^a", mbuf, mlth, condition); call sys_log_ (2, "^a", mbuf); call as_dump_ (mbuf); call ios_$order ("user_i/o", "start", null, status); answer = condition; go to cleanup; /* Fall down, gracefully. */ end ucs; %page; /* Access checking entry, used by up_xxx_ programs. Determines effective access of installer to >instaldir>xxx.install.acs. If the segment does not exist, it is created. */ check_acs: entry (a_acs_name, a_group_id, a_ring, a_mode, a_code); dcl a_acs_name char (*); dcl a_group_id char (*); dcl a_ring fixed bin; dcl a_mode bit (36) aligned; dcl a_code fixed bin (35); /* AIM? what's that? */ call hcs_$get_user_access_modes (as_data_$acsdir, a_acs_name, a_group_id, a_ring, a_mode, ""b, a_code); if a_code = error_table_$noentry then begin; dcl rings (3) fixed bin (3) init (5, 5, 5); /* note: we presume process is system_low */ /* (not that it's likely to matter) */ call sys_log_ (1, "up_sysctl_$check_acs: ^a not found. It will be created.", pathname_ (as_data_$acsdir, a_acs_name)); call hcs_$append_branchx (as_data_$acsdir, a_acs_name, RW_ACCESS_BIN, rings, "*.SysAdmin.*", 0, 0, 0, code); if code ^= 0 then do; call sys_log_$error_log (1, code, "up_sysctl_$check_acs", "Unable to create ^a.", pathname_ (as_data_$acsdir, a_acs_name)); a_mode = "0"b; return; end; call hcs_$get_user_access_modes (as_data_$acsdir, a_acs_name, a_group_id, a_ring, a_mode, ""b, a_code); end; return; /* Initialization entry to setup segments used to hold event channels for installing new tables. PG 741101 */ init: entry; /* automatic */ declare sat_ptr ptr, group_id char (32), process_id bit (36); /* entries */ declare convert_ipc_code_ entry (fixed bin (35)); declare hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); declare as_add_admin_acl_$dir entry (char (*), char (*), ptr, entry, bit (*), fixed bin (35)); declare hcs_$append_branchx entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35)); declare sub_err_ entry () options (variable); declare up_sysctl_$up_sysctl_ entry (); /* external static */ declare error_table_$noentry fixed bin (35) ext static; declare error_table_$out_of_sequence fixed bin (35) ext static; /* program */ if ^sc_stat_$Multics_typed | sc_stat_$Go_typed then do; code = error_table_$out_of_sequence; go to init_sub_error; end; ansp = as_data_$ansp; process_id = get_process_id_ (); group_id = get_group_id_ (); maildir = rtrim (anstbl.sysdir) || ">update"; acla (1).userid = group_id; /* set up canned ACL */ acla (1).mode = "101"b; /* First make sure the installation "update" directory is present. */ call hcs_$status_minf (anstbl.sysdir, "update", 1, type, bitcount, code); if code = error_table_$noentry then do; /* not there, try to create */ type = 2; /* we are creating a directory */ call hcs_$append_branchx (anstbl.sysdir, "update", 01011b /* SMA */, ring_brackets, group_id, 1b, 0b, 0, code); if code = 0 then call as_add_admin_acl_$dir (anstbl.sysdir, "update", sat_ptr, hcs_$add_dir_acl_entries, "001"b /* A */, code); end; if (code ^= 0) | (type ^= 2) then do; call sys_log_$error_log (2, code, "up_sysctl_$init", "Cannot find/create ^a>update", anstbl.sysdir); go to init_sub_error; end; /* create and publish IPC channel for installation wakeups */ call ipc_$create_ev_chn (anstbl.update_channel, code); if code ^= 0 then go to ipc_failed; call ipc_$decl_ev_call_chn (anstbl.update_channel, up_sysctl_$up_sysctl_, null, INSTALL_PRIO, code); if code ^= 0 then go to ipc_failed; whotab.installation_request_pid = process_id; whotab.installation_request_channel = anstbl.update_channel; return; ipc_failed: call convert_ipc_code_ (code); /* convert non-standard ipc code to std code */ call sys_log_$error_log (2, code, "up_sysctl_$init", "Cannot make IPC channel."); init_sub_error: call sub_err_ (code, "up_sysctl_$init", "s"); %page; %include access_mode_values; %page; %include answer_table; %page; %include as_data_; %page; %include as_data_definitions_; %page; %include as_meter_numbers; %page; %include as_wakeup_priorities; %page; %include sc_stat_; %page; %include send_mail_info; %page; %include user_attributes; %page; %include user_table_entry; %page; %include user_table_header; %page; %include whotab; %page; /* BEGIN MESSAGE DOCUMENTATION Message: up_sysctl_: error - event calls were masked S: sc (error_output) T: $run M: $err The system attempts to recover and keep running. A: $notify Message: up_sysctl_: CONDITION installing TABLE for USER S: as (severity1) T: $run M: Some unexpected error occurred while installing a system table. An Answering Service dump was performed. Further attempts to install system tables may fail until a reset or force is done, but logins and logouts should be able to proceed normally. A: $inform_sa Message: up_sysctl_: Error: REASON S: as (severity2) T: $run M: Some error occurred while installing a system table. An Answering Service dump was performed. Further attempts to install system tables may fail until a force or reset is done, but logins and logouts should be able to proceed as usual. A: $inform_sa Message: up_sysctl_$init: ERROR_MESSAGE. cannot find/create >system_control_1>update S: as (severity2) T: $init M: The directory used to update system tables is missing and cannot be created. No installations of new system tables cannot be done. Logins and logouts can go on as usual. A: $inform_sa Message: up_sysctl_$init: ERROR_MESSAGE. Cannot make IPC channel. S: as (severity2) T: $init M: It was not possible to establish the IPC channel which is used to allow users to indicate that an Answering Service table installation is to be performed. Installations will not occur. A: $inform_sa Message: up_sysctl_: Unable to install TABLE for USERID. userid should be USERID1 S: as (severity1) T: $run M: A user attempted to install a system table by pretending to be some other user. A: $inform_sa Message: up_sysctl_: Unable to install TABLE for USERID. TEXT S: as (severity1) T: $run M: The user USERID attempted to change the system table TABLE but something was wrong. The reason is given by TEXT. A: $ignore Message: up_sysctl_: installed TABLE for USERID S: as (severity1) T: $run M: An mgt, sat, cdt, pdt, or rtdt has been installed. A: $ignore Message: up_sysctl_: NAME wakeup with N installs pending up_sysctl_: NAME wakeup from PERSON.PROJECT with N installs pending S: as (severity0) T: $run M: A request to perform a table installation was received. There were N tables found ready for installation at the time of the wakeup. If N is 0, the PERSON.PROJECT of the originator of the request is also logged. This message is normally severity0, but the administrator may cause it to be severity1. A: $contact The administrator may request that he be notified if this occurs. If a large number of these messages are logged with N = 0, it may indicate that a user is harassing the installation mechanism. Message: up_sysctl_$check_acs: PATHNAME not found. It will be created. S: as (severity1) T: $run M: The named segment, which controls a table installation operation, does not exist. The segment will be created with an ACL allowing *.SysDaemon.* and *.SysAdmin.* to perform the appropriate table installation. A: $contact The system administrator should be notified, so that the ACL of the segment may be adjusted to reflect those users that may install the table. Message: up_sysctl_$check_acs: MESSAGE. Unable to create PATHNAME. S: as (severity1) T: $run M: The named segment does not exist, and it was not possible to create it. Any table installations controlled by this segment will be ignored. (The table submitted for installation will be deleted.) A: $notify Notify the system administrator. Normal servicing of table installations will not proceed until this situation is rectified. END MESSAGE DOCUMENTATION */ end up_sysctl_; 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