



		    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
